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.
45 #include "backtrace.h"
56 #include "redisplay.h"
57 #include "specifier.h"
61 #ifdef DOUG_LEA_MALLOC
65 EXFUN (Fgarbage_collect, 0);
67 /* Return the true size of a struct with a variable-length array field. */
68 #define STRETCHY_STRUCT_SIZEOF(stretchy_struct_type, \
69 stretchy_array_field, \
70 stretchy_array_length) \
71 (offsetof (stretchy_struct_type, stretchy_array_field) + \
72 (offsetof (stretchy_struct_type, stretchy_array_field[1]) - \
73 offsetof (stretchy_struct_type, stretchy_array_field[0])) * \
74 (stretchy_array_length))
76 #if 0 /* this is _way_ too slow to be part of the standard debug options */
77 #if defined(DEBUG_XEMACS) && defined(MULE)
78 #define VERIFY_STRING_CHARS_INTEGRITY
82 /* Define this to use malloc/free with no freelist for all datatypes,
83 the hope being that some debugging tools may help detect
84 freed memory references */
85 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
87 #define ALLOC_NO_POOLS
91 static int debug_allocation;
92 static int debug_allocation_backtrace_length;
95 /* Number of bytes of consing done since the last gc */
96 EMACS_INT consing_since_gc;
97 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
99 #define debug_allocation_backtrace() \
101 if (debug_allocation_backtrace_length > 0) \
102 debug_short_backtrace (debug_allocation_backtrace_length); \
106 #define INCREMENT_CONS_COUNTER(foosize, type) \
108 if (debug_allocation) \
110 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
111 debug_allocation_backtrace (); \
113 INCREMENT_CONS_COUNTER_1 (foosize); \
115 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
117 if (debug_allocation > 1) \
119 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
120 debug_allocation_backtrace (); \
122 INCREMENT_CONS_COUNTER_1 (foosize); \
125 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
126 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
127 INCREMENT_CONS_COUNTER_1 (size)
130 #define DECREMENT_CONS_COUNTER(size) do { \
131 consing_since_gc -= (size); \
132 if (consing_since_gc < 0) \
133 consing_since_gc = 0; \
136 /* Number of bytes of consing since gc before another gc should be done. */
137 EMACS_INT gc_cons_threshold;
139 /* Nonzero during gc */
142 /* Number of times GC has happened at this level or below.
143 * Level 0 is most volatile, contrary to usual convention.
144 * (Of course, there's only one level at present) */
145 EMACS_INT gc_generation_number[1];
147 /* This is just for use by the printer, to allow things to print uniquely */
148 static int lrecord_uid_counter;
150 /* Nonzero when calling certain hooks or doing other things where
152 int gc_currently_forbidden;
155 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
156 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
158 /* "Garbage collecting" */
159 Lisp_Object Vgc_message;
160 Lisp_Object Vgc_pointer_glyph;
161 static CONST char gc_default_message[] = "Garbage collecting";
162 Lisp_Object Qgarbage_collecting;
164 #ifndef VIRT_ADDR_VARIES
166 #endif /* VIRT_ADDR_VARIES */
167 EMACS_INT malloc_sbrk_used;
169 #ifndef VIRT_ADDR_VARIES
171 #endif /* VIRT_ADDR_VARIES */
172 EMACS_INT malloc_sbrk_unused;
174 /* Non-zero means we're in the process of doing the dump */
177 #ifdef ERROR_CHECK_TYPECHECK
179 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
184 c_readonly (Lisp_Object obj)
186 return POINTER_TYPE_P (XGCTYPE (obj)) && C_READONLY (obj);
190 lisp_readonly (Lisp_Object obj)
192 return POINTER_TYPE_P (XGCTYPE (obj)) && LISP_READONLY (obj);
196 /* Maximum amount of C stack to save when a GC happens. */
198 #ifndef MAX_SAVE_STACK
199 #define MAX_SAVE_STACK 0 /* 16000 */
202 /* Non-zero means ignore malloc warnings. Set during initialization. */
203 int ignore_malloc_warnings;
206 static void *breathing_space;
209 release_breathing_space (void)
213 void *tmp = breathing_space;
219 /* malloc calls this if it finds we are near exhausting storage */
221 malloc_warning (CONST char *str)
223 if (ignore_malloc_warnings)
229 "Killing some buffers may delay running out of memory.\n"
230 "However, certainly by the time you receive the 95%% warning,\n"
231 "you should clean up, kill this Emacs, and start a new one.",
235 /* Called if malloc returns zero */
239 /* Force a GC next time eval is called.
240 It's better to loop garbage-collecting (we might reclaim enough
241 to win) than to loop beeping and barfing "Memory exhausted"
243 consing_since_gc = gc_cons_threshold + 1;
244 release_breathing_space ();
246 /* Flush some histories which might conceivably contain garbalogical
248 if (!NILP (Fboundp (Qvalues)))
249 Fset (Qvalues, Qnil);
250 Vcommand_history = Qnil;
252 error ("Memory exhausted");
255 /* like malloc and realloc but check for no memory left, and block input. */
262 xmalloc (size_t size)
264 void *val = malloc (size);
266 if (!val && (size != 0)) memory_full ();
275 xcalloc (size_t nelem, size_t elsize)
277 void *val = calloc (nelem, elsize);
279 if (!val && (nelem != 0)) memory_full ();
284 xmalloc_and_zero (size_t size)
286 return xcalloc (size, sizeof (char));
294 xrealloc (void *block, size_t size)
296 /* We must call malloc explicitly when BLOCK is 0, since some
297 reallocs don't do this. */
298 void *val = block ? realloc (block, size) : malloc (size);
300 if (!val && (size != 0)) memory_full ();
305 #ifdef ERROR_CHECK_MALLOC
306 xfree_1 (void *block)
311 #ifdef ERROR_CHECK_MALLOC
312 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
313 error until much later on for many system mallocs, such as
314 the one that comes with Solaris 2.3. FMH!! */
315 assert (block != (void *) 0xDEADBEEF);
317 #endif /* ERROR_CHECK_MALLOC */
321 #ifdef ERROR_CHECK_GC
324 typedef unsigned int four_byte_t;
325 #elif SIZEOF_LONG == 4
326 typedef unsigned long four_byte_t;
327 #elif SIZEOF_SHORT == 4
328 typedef unsigned short four_byte_t;
330 What kind of strange-ass system are we running on?
334 deadbeef_memory (void *ptr, size_t size)
336 four_byte_t *ptr4 = (four_byte_t *) ptr;
337 size_t beefs = size >> 2;
339 /* In practice, size will always be a multiple of four. */
341 (*ptr4++) = 0xDEADBEEF;
344 #else /* !ERROR_CHECK_GC */
347 #define deadbeef_memory(ptr, size)
349 #endif /* !ERROR_CHECK_GC */
356 xstrdup (CONST char *str)
358 int len = strlen (str) + 1; /* for stupid terminating 0 */
360 void *val = xmalloc (len);
361 if (val == 0) return 0;
362 memcpy (val, str, len);
368 strdup (CONST char *s)
372 #endif /* NEED_STRDUP */
376 allocate_lisp_storage (size_t size)
378 void *p = xmalloc (size);
383 /* lrecords are chained together through their "next.v" field.
384 * After doing the mark phase, the GC will walk this linked
385 * list and free any record which hasn't been marked.
387 static struct lcrecord_header *all_lcrecords;
390 alloc_lcrecord (size_t size, CONST struct lrecord_implementation *implementation)
392 struct lcrecord_header *lcheader;
394 #ifdef ERROR_CHECK_GC
395 if (implementation->static_size == 0)
396 assert (implementation->size_in_bytes_method);
398 assert (implementation->static_size == size);
401 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
402 set_lheader_implementation (&(lcheader->lheader), implementation);
403 lcheader->next = all_lcrecords;
404 #if 1 /* mly prefers to see small ID numbers */
405 lcheader->uid = lrecord_uid_counter++;
406 #else /* jwz prefers to see real addrs */
407 lcheader->uid = (int) &lcheader;
410 all_lcrecords = lcheader;
411 INCREMENT_CONS_COUNTER (size, implementation->name);
415 #if 0 /* Presently unused */
416 /* Very, very poor man's EGC?
417 * This may be slow and thrash pages all over the place.
418 * Only call it if you really feel you must (and if the
419 * lrecord was fairly recently allocated).
420 * Otherwise, just let the GC do its job -- that's what it's there for
423 free_lcrecord (struct lcrecord_header *lcrecord)
425 if (all_lcrecords == lcrecord)
427 all_lcrecords = lcrecord->next;
431 struct lrecord_header *header = all_lcrecords;
434 struct lrecord_header *next = header->next;
435 if (next == lcrecord)
437 header->next = lrecord->next;
446 if (lrecord->implementation->finalizer)
447 lrecord->implementation->finalizer (lrecord, 0);
455 disksave_object_finalization_1 (void)
457 struct lcrecord_header *header;
459 for (header = all_lcrecords; header; header = header->next)
461 if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
463 ((LHEADER_IMPLEMENTATION(&header->lheader)->finalizer)
469 /* This must not be called -- it just serves as for EQ test
470 * If lheader->implementation->finalizer is this_marks_a_marked_record,
471 * then lrecord has been marked by the GC sweeper
472 * header->implementation is put back to its correct value by
475 this_marks_a_marked_record (void *dummy0, int dummy1)
480 /* Semi-kludge -- lrecord_symbol_value_forward objects get stuck
481 in CONST space and you get SEGV's if you attempt to mark them.
482 This sits in lheader->implementation->marker. */
485 this_one_is_unmarkable (Lisp_Object obj, void (*markobj) (Lisp_Object))
491 /* XGCTYPE for records */
493 gc_record_type_p (Lisp_Object frob, CONST struct lrecord_implementation *type)
495 CONST struct lrecord_implementation *imp;
497 if (XGCTYPE (frob) != Lisp_Type_Record)
500 imp = XRECORD_LHEADER_IMPLEMENTATION (frob);
505 /************************************************************************/
506 /* Debugger support */
507 /************************************************************************/
508 /* Give gdb/dbx enough information to decode Lisp Objects. We make
509 sure certain symbols are always defined, so gdb doesn't complain
510 about expressions in src/gdbinit. See src/gdbinit or src/dbxrc to
511 see how this is used. */
513 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
514 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
516 #ifdef USE_UNION_TYPE
517 unsigned char dbg_USE_UNION_TYPE = 1;
519 unsigned char dbg_USE_UNION_TYPE = 0;
522 unsigned char Lisp_Type_Int = 100;
523 unsigned char Lisp_Type_Cons = 101;
524 unsigned char Lisp_Type_String = 102;
525 unsigned char Lisp_Type_Vector = 103;
526 unsigned char Lisp_Type_Symbol = 104;
529 unsigned char lrecord_char_table_entry;
530 unsigned char lrecord_charset;
532 unsigned char lrecord_coding_system;
536 #ifndef HAVE_TOOLBARS
537 unsigned char lrecord_toolbar_button;
541 unsigned char lrecord_tooltalk_message;
542 unsigned char lrecord_tooltalk_pattern;
545 #ifndef HAVE_DATABASE
546 unsigned char lrecord_database;
549 unsigned char dbg_valbits = VALBITS;
550 unsigned char dbg_gctypebits = GCTYPEBITS;
552 /* Macros turned into functions for ease of debugging.
553 Debuggers don't know about macros! */
554 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
556 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
558 return EQ (obj1, obj2);
562 /************************************************************************/
563 /* Fixed-size type macros */
564 /************************************************************************/
566 /* For fixed-size types that are commonly used, we malloc() large blocks
567 of memory at a time and subdivide them into chunks of the correct
568 size for an object of that type. This is more efficient than
569 malloc()ing each object separately because we save on malloc() time
570 and overhead due to the fewer number of malloc()ed blocks, and
571 also because we don't need any extra pointers within each object
572 to keep them threaded together for GC purposes. For less common
573 (and frequently large-size) types, we use lcrecords, which are
574 malloc()ed individually and chained together through a pointer
575 in the lcrecord header. lcrecords do not need to be fixed-size
576 (i.e. two objects of the same type need not have the same size;
577 however, the size of a particular object cannot vary dynamically).
578 It is also much easier to create a new lcrecord type because no
579 additional code needs to be added to alloc.c. Finally, lcrecords
580 may be more efficient when there are only a small number of them.
582 The types that are stored in these large blocks (or "frob blocks")
583 are cons, float, compiled-function, symbol, marker, extent, event,
586 Note that strings are special in that they are actually stored in
587 two parts: a structure containing information about the string, and
588 the actual data associated with the string. The former structure
589 (a struct Lisp_String) is a fixed-size structure and is managed the
590 same way as all the other such types. This structure contains a
591 pointer to the actual string data, which is stored in structures of
592 type struct string_chars_block. Each string_chars_block consists
593 of a pointer to a struct Lisp_String, followed by the data for that
594 string, followed by another pointer to a struct Lisp_String,
595 followed by the data for that string, etc. At GC time, the data in
596 these blocks is compacted by searching sequentially through all the
597 blocks and compressing out any holes created by unmarked strings.
598 Strings that are more than a certain size (bigger than the size of
599 a string_chars_block, although something like half as big might
600 make more sense) are malloc()ed separately and not stored in
601 string_chars_blocks. Furthermore, no one string stretches across
602 two string_chars_blocks.
604 Vectors are each malloc()ed separately, similar to lcrecords.
606 In the following discussion, we use conses, but it applies equally
607 well to the other fixed-size types.
609 We store cons cells inside of cons_blocks, allocating a new
610 cons_block with malloc() whenever necessary. Cons cells reclaimed
611 by GC are put on a free list to be reallocated before allocating
612 any new cons cells from the latest cons_block. Each cons_block is
613 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
614 the versions in malloc.c and gmalloc.c) really allocates in units
615 of powers of two and uses 4 bytes for its own overhead.
617 What GC actually does is to search through all the cons_blocks,
618 from the most recently allocated to the oldest, and put all
619 cons cells that are not marked (whether or not they're already
620 free) on a cons_free_list. The cons_free_list is a stack, and
621 so the cons cells in the oldest-allocated cons_block end up
622 at the head of the stack and are the first to be reallocated.
623 If any cons_block is entirely free, it is freed with free()
624 and its cons cells removed from the cons_free_list. Because
625 the cons_free_list ends up basically in memory order, we have
626 a high locality of reference (assuming a reasonable turnover
627 of allocating and freeing) and have a reasonable probability
628 of entirely freeing up cons_blocks that have been more recently
629 allocated. This stage is called the "sweep stage" of GC, and
630 is executed after the "mark stage", which involves starting
631 from all places that are known to point to in-use Lisp objects
632 (e.g. the obarray, where are all symbols are stored; the
633 current catches and condition-cases; the backtrace list of
634 currently executing functions; the gcpro list; etc.) and
635 recursively marking all objects that are accessible.
637 At the beginning of the sweep stage, the conses in the cons
638 blocks are in one of three states: in use and marked, in use
639 but not marked, and not in use (already freed). Any conses
640 that are marked have been marked in the mark stage just
641 executed, because as part of the sweep stage we unmark any
642 marked objects. The way we tell whether or not a cons cell
643 is in use is through the FREE_STRUCT_P macro. This basically
644 looks at the first 4 bytes (or however many bytes a pointer
645 fits in) to see if all the bits in those bytes are 1. The
646 resulting value (0xFFFFFFFF) is not a valid pointer and is
647 not a valid Lisp_Object. All current fixed-size types have
648 a pointer or Lisp_Object as their first element with the
649 exception of strings; they have a size value, which can
650 never be less than zero, and so 0xFFFFFFFF is invalid for
651 strings as well. Now assuming that a cons cell is in use,
652 the way we tell whether or not it is marked is to look at
653 the mark bit of its car (each Lisp_Object has one bit
654 reserved as a mark bit, in case it's needed). Note that
655 different types of objects use different fields to indicate
656 whether the object is marked, but the principle is the same.
658 Conses on the free_cons_list are threaded through a pointer
659 stored in the bytes directly after the bytes that are set
660 to 0xFFFFFFFF (we cannot overwrite these because the cons
661 is still in a cons_block and needs to remain marked as
662 not in use for the next time that GC happens). This
663 implies that all fixed-size types must be at least big
664 enough to store two pointers, which is indeed the case
665 for all current fixed-size types.
667 Some types of objects need additional "finalization" done
668 when an object is converted from in use to not in use;
669 this is the purpose of the ADDITIONAL_FREE_type macro.
670 For example, markers need to be removed from the chain
671 of markers that is kept in each buffer. This is because
672 markers in a buffer automatically disappear if the marker
673 is no longer referenced anywhere (the same does not
674 apply to extents, however).
676 WARNING: Things are in an extremely bizarre state when
677 the ADDITIONAL_FREE_type macros are called, so beware!
679 When ERROR_CHECK_GC is defined, we do things differently
680 so as to maximize our chances of catching places where
681 there is insufficient GCPROing. The thing we want to
682 avoid is having an object that we're using but didn't
683 GCPRO get freed by GC and then reallocated while we're
684 in the process of using it -- this will result in something
685 seemingly unrelated getting trashed, and is extremely
686 difficult to track down. If the object gets freed but
687 not reallocated, we can usually catch this because we
688 set all bytes of a freed object to 0xDEADBEEF. (The
689 first four bytes, however, are 0xFFFFFFFF, and the next
690 four are a pointer used to chain freed objects together;
691 we play some tricks with this pointer to make it more
692 bogus, so crashes are more likely to occur right away.)
694 We want freed objects to stay free as long as possible,
695 so instead of doing what we do above, we maintain the
696 free objects in a first-in first-out queue. We also
697 don't recompute the free list each GC, unlike above;
698 this ensures that the queue ordering is preserved.
699 [This means that we are likely to have worse locality
700 of reference, and that we can never free a frob block
701 once it's allocated. (Even if we know that all cells
702 in it are free, there's no easy way to remove all those
703 cells from the free list because the objects on the
704 free list are unlikely to be in memory order.)]
705 Furthermore, we never take objects off the free list
706 unless there's a large number (usually 1000, but
707 varies depending on type) of them already on the list.
708 This way, we ensure that an object that gets freed will
709 remain free for the next 1000 (or whatever) times that
710 an object of that type is allocated.
713 #ifndef MALLOC_OVERHEAD
715 #define MALLOC_OVERHEAD 0
716 #elif defined (rcheck)
717 #define MALLOC_OVERHEAD 20
719 #define MALLOC_OVERHEAD 8
721 #endif /* MALLOC_OVERHEAD */
723 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
724 /* If we released our reserve (due to running out of memory),
725 and we have a fair amount free once again,
726 try to set aside another reserve in case we run out once more.
728 This is called when a relocatable block is freed in ralloc.c. */
729 void refill_memory_reserve (void);
731 refill_memory_reserve ()
733 if (breathing_space == 0)
734 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
738 #ifdef ALLOC_NO_POOLS
739 # define TYPE_ALLOC_SIZE(type, structtype) 1
741 # define TYPE_ALLOC_SIZE(type, structtype) \
742 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
743 / sizeof (structtype))
744 #endif /* ALLOC_NO_POOLS */
746 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
748 struct type##_block \
750 struct type##_block *prev; \
751 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
754 static struct type##_block *current_##type##_block; \
755 static int current_##type##_block_index; \
757 static structtype *type##_free_list; \
758 static structtype *type##_free_list_tail; \
761 init_##type##_alloc (void) \
763 current_##type##_block = 0; \
764 current_##type##_block_index = \
765 countof (current_##type##_block->block); \
766 type##_free_list = 0; \
767 type##_free_list_tail = 0; \
770 static int gc_count_num_##type##_in_use; \
771 static int gc_count_num_##type##_freelist
773 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
774 if (current_##type##_block_index \
775 == countof (current_##type##_block->block)) \
777 struct type##_block *AFTFB_new = (struct type##_block *) \
778 allocate_lisp_storage (sizeof (struct type##_block)); \
779 AFTFB_new->prev = current_##type##_block; \
780 current_##type##_block = AFTFB_new; \
781 current_##type##_block_index = 0; \
784 &(current_##type##_block->block[current_##type##_block_index++]); \
787 /* Allocate an instance of a type that is stored in blocks.
788 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
791 #ifdef ERROR_CHECK_GC
793 /* Note: if you get crashes in this function, suspect incorrect calls
794 to free_cons() and friends. This happened once because the cons
795 cell was not GC-protected and was getting collected before
796 free_cons() was called. */
798 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
801 if (gc_count_num_##type##_freelist > \
802 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
804 result = type##_free_list; \
805 /* Before actually using the chain pointer, we complement all its \
806 bits; see FREE_FIXED_TYPE(). */ \
808 (structtype *) ~(unsigned long) \
809 (* (structtype **) ((char *) result + sizeof (void *))); \
810 gc_count_num_##type##_freelist--; \
813 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
814 MARK_STRUCT_AS_NOT_FREE (result); \
817 #else /* !ERROR_CHECK_GC */
819 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
822 if (type##_free_list) \
824 result = type##_free_list; \
826 * (structtype **) ((char *) result + sizeof (void *)); \
829 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
830 MARK_STRUCT_AS_NOT_FREE (result); \
833 #endif /* !ERROR_CHECK_GC */
835 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
838 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
839 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
842 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
845 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
846 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
849 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
850 to a Lisp object and invalid as an actual Lisp_Object value. We have
851 to make sure that this value cannot be an integer in Lisp_Object form.
852 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
853 On a 32-bit system, the type bits will be non-zero, making the value
854 be a pointer, and the pointer will be misaligned.
856 Even if Emacs is run on some weirdo system that allows and allocates
857 byte-aligned pointers, this pointer is at the very top of the address
858 space and so it's almost inconceivable that it could ever be valid. */
861 # define INVALID_POINTER_VALUE 0xFFFFFFFF
863 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
865 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
867 You have some weird system and need to supply a reasonable value here.
870 #define FREE_STRUCT_P(ptr) \
871 (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
872 #define MARK_STRUCT_AS_FREE(ptr) \
873 (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
874 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
875 (* (void **) ptr = 0)
877 #ifdef ERROR_CHECK_GC
879 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
880 do { if (type##_free_list_tail) \
882 /* When we store the chain pointer, we complement all \
883 its bits; this should significantly increase its \
884 bogosity in case someone tries to use the value, and \
885 should make us dump faster if someone stores something \
886 over the pointer because when it gets un-complemented in \
887 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
888 extremely bogus. */ \
890 ((char *) type##_free_list_tail + sizeof (void *)) = \
891 (structtype *) ~(unsigned long) ptr; \
894 type##_free_list = ptr; \
895 type##_free_list_tail = ptr; \
898 #else /* !ERROR_CHECK_GC */
900 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
901 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
903 type##_free_list = (ptr); \
906 #endif /* !ERROR_CHECK_GC */
908 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
910 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
911 structtype *FFT_ptr = (ptr); \
912 ADDITIONAL_FREE_##type (FFT_ptr); \
913 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
914 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
915 MARK_STRUCT_AS_FREE (FFT_ptr); \
918 /* Like FREE_FIXED_TYPE() but used when we are explicitly
919 freeing a structure through free_cons(), free_marker(), etc.
920 rather than through the normal process of sweeping.
921 We attempt to undo the changes made to the allocation counters
922 as a result of this structure being allocated. This is not
923 completely necessary but helps keep things saner: e.g. this way,
924 repeatedly allocating and freeing a cons will not result in
925 the consing-since-gc counter advancing, which would cause a GC
926 and somewhat defeat the purpose of explicitly freeing. */
928 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
929 do { FREE_FIXED_TYPE (type, structtype, ptr); \
930 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
931 gc_count_num_##type##_freelist++; \
936 /************************************************************************/
937 /* Cons allocation */
938 /************************************************************************/
940 DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons);
941 /* conses are used and freed so often that we set this really high */
942 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
943 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
946 mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object))
948 if (GC_NILP (XCDR (obj)))
951 markobj (XCAR (obj));
956 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
958 while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1))
962 if (! CONSP (ob1) || ! CONSP (ob2))
963 return internal_equal (ob1, ob2, depth + 1);
968 static const struct lrecord_description cons_description[] = {
969 { XD_LISP_OBJECT, offsetof(struct Lisp_Cons, car), 2 },
973 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
974 mark_cons, print_cons, 0,
977 * No `hash' method needed.
978 * internal_hash knows how to
985 DEFUN ("cons", Fcons, 2, 2, 0, /*
986 Create a new cons, give it CAR and CDR as components, and return it.
990 /* This cannot GC. */
994 ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
995 set_lheader_implementation (&(c->lheader), &lrecord_cons);
1002 /* This is identical to Fcons() but it used for conses that we're
1003 going to free later, and is useful when trying to track down
1006 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
1009 struct Lisp_Cons *c;
1011 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1012 set_lheader_implementation (&(c->lheader), &lrecord_cons);
1019 DEFUN ("list", Flist, 0, MANY, 0, /*
1020 Return a newly created list with specified arguments as elements.
1021 Any number of arguments, even zero arguments, are allowed.
1023 (int nargs, Lisp_Object *args))
1025 Lisp_Object val = Qnil;
1026 Lisp_Object *argp = args + nargs;
1029 val = Fcons (*--argp, val);
1034 list1 (Lisp_Object obj0)
1036 /* This cannot GC. */
1037 return Fcons (obj0, Qnil);
1041 list2 (Lisp_Object obj0, Lisp_Object obj1)
1043 /* This cannot GC. */
1044 return Fcons (obj0, Fcons (obj1, Qnil));
1048 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1050 /* This cannot GC. */
1051 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1055 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1057 /* This cannot GC. */
1058 return Fcons (obj0, Fcons (obj1, obj2));
1062 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1064 return Fcons (Fcons (key, value), alist);
1068 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1070 /* This cannot GC. */
1071 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1075 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1078 /* This cannot GC. */
1079 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1083 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1084 Lisp_Object obj4, Lisp_Object obj5)
1086 /* This cannot GC. */
1087 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1090 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1091 Return a new list of length LENGTH, with each element being INIT.
1095 CHECK_NATNUM (length);
1098 Lisp_Object val = Qnil;
1099 int size = XINT (length);
1102 val = Fcons (init, val);
1108 /************************************************************************/
1109 /* Float allocation */
1110 /************************************************************************/
1112 #ifdef LISP_FLOAT_TYPE
1114 DECLARE_FIXED_TYPE_ALLOC (float, struct Lisp_Float);
1115 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1118 make_float (double float_value)
1121 struct Lisp_Float *f;
1123 ALLOCATE_FIXED_TYPE (float, struct Lisp_Float, f);
1124 set_lheader_implementation (&(f->lheader), &lrecord_float);
1125 float_data (f) = float_value;
1130 #endif /* LISP_FLOAT_TYPE */
1133 /************************************************************************/
1134 /* Vector allocation */
1135 /************************************************************************/
1138 mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
1140 Lisp_Vector *ptr = XVECTOR (obj);
1141 int len = vector_length (ptr);
1144 for (i = 0; i < len - 1; i++)
1145 markobj (ptr->contents[i]);
1146 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1150 size_vector (CONST void *lheader)
1152 return STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents,
1153 ((Lisp_Vector *) lheader)->size);
1157 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1159 int len = XVECTOR_LENGTH (obj1);
1160 if (len != XVECTOR_LENGTH (obj2))
1164 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1165 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1167 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1173 static const struct lrecord_description vector_description[] = {
1174 { XD_LONG, offsetof(struct Lisp_Vector, size) },
1175 { XD_LISP_OBJECT, offsetof(struct Lisp_Vector, contents), XD_INDIRECT(0) }
1178 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1179 mark_vector, print_vector, 0,
1182 * No `hash' method needed for
1183 * vectors. internal_hash
1184 * knows how to handle vectors.
1188 size_vector, Lisp_Vector);
1190 /* #### should allocate `small' vectors from a frob-block */
1191 static Lisp_Vector *
1192 make_vector_internal (size_t sizei)
1194 /* no vector_next */
1195 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1196 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1203 make_vector (size_t length, Lisp_Object init)
1205 Lisp_Vector *vecp = make_vector_internal (length);
1206 Lisp_Object *p = vector_data (vecp);
1213 XSETVECTOR (vector, vecp);
1218 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1219 Return a new vector of length LENGTH, with each element being INIT.
1220 See also the function `vector'.
1224 CONCHECK_NATNUM (length);
1225 return make_vector (XINT (length), init);
1228 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1229 Return a newly created vector with specified arguments as elements.
1230 Any number of arguments, even zero arguments, are allowed.
1232 (int nargs, Lisp_Object *args))
1234 Lisp_Vector *vecp = make_vector_internal (nargs);
1235 Lisp_Object *p = vector_data (vecp);
1242 XSETVECTOR (vector, vecp);
1248 vector1 (Lisp_Object obj0)
1250 return Fvector (1, &obj0);
1254 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1256 Lisp_Object args[2];
1259 return Fvector (2, args);
1263 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1265 Lisp_Object args[3];
1269 return Fvector (3, args);
1272 #if 0 /* currently unused */
1275 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1278 Lisp_Object args[4];
1283 return Fvector (4, args);
1287 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1288 Lisp_Object obj3, Lisp_Object obj4)
1290 Lisp_Object args[5];
1296 return Fvector (5, args);
1300 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1301 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1303 Lisp_Object args[6];
1310 return Fvector (6, args);
1314 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1315 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1318 Lisp_Object args[7];
1326 return Fvector (7, args);
1330 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1331 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1332 Lisp_Object obj6, Lisp_Object obj7)
1334 Lisp_Object args[8];
1343 return Fvector (8, args);
1347 /************************************************************************/
1348 /* Bit Vector allocation */
1349 /************************************************************************/
1351 static Lisp_Object all_bit_vectors;
1353 /* #### should allocate `small' bit vectors from a frob-block */
1354 static struct Lisp_Bit_Vector *
1355 make_bit_vector_internal (size_t sizei)
1357 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1358 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1359 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1360 set_lheader_implementation (&(p->lheader), &lrecord_bit_vector);
1362 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1364 bit_vector_length (p) = sizei;
1365 bit_vector_next (p) = all_bit_vectors;
1366 /* make sure the extra bits in the last long are 0; the calling
1367 functions might not set them. */
1368 p->bits[num_longs - 1] = 0;
1369 XSETBIT_VECTOR (all_bit_vectors, p);
1374 make_bit_vector (size_t length, Lisp_Object init)
1376 struct Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1377 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1382 memset (p->bits, 0, num_longs * sizeof (long));
1385 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1386 memset (p->bits, ~0, num_longs * sizeof (long));
1387 /* But we have to make sure that the unused bits in the
1388 last long are 0, so that equal/hash is easy. */
1390 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1394 Lisp_Object bit_vector;
1395 XSETBIT_VECTOR (bit_vector, p);
1401 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1404 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1406 for (i = 0; i < length; i++)
1407 set_bit_vector_bit (p, i, bytevec[i]);
1410 Lisp_Object bit_vector;
1411 XSETBIT_VECTOR (bit_vector, p);
1416 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1417 Return a new bit vector of length LENGTH. with each bit being INIT.
1418 Each element is set to INIT. See also the function `bit-vector'.
1422 CONCHECK_NATNUM (length);
1424 return make_bit_vector (XINT (length), init);
1427 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1428 Return a newly created bit vector with specified arguments as elements.
1429 Any number of arguments, even zero arguments, are allowed.
1431 (int nargs, Lisp_Object *args))
1434 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1436 for (i = 0; i < nargs; i++)
1438 CHECK_BIT (args[i]);
1439 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1443 Lisp_Object bit_vector;
1444 XSETBIT_VECTOR (bit_vector, p);
1450 /************************************************************************/
1451 /* Compiled-function allocation */
1452 /************************************************************************/
1454 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1455 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1458 make_compiled_function (void)
1460 Lisp_Compiled_Function *f;
1463 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1464 set_lheader_implementation (&(f->lheader), &lrecord_compiled_function);
1467 f->specpdl_depth = 0;
1468 f->flags.documentationp = 0;
1469 f->flags.interactivep = 0;
1470 f->flags.domainp = 0; /* I18N3 */
1471 f->instructions = Qzero;
1472 f->constants = Qzero;
1474 f->doc_and_interactive = Qnil;
1475 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1476 f->annotated = Qnil;
1478 XSETCOMPILED_FUNCTION (fun, f);
1482 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1483 Return a new compiled-function object.
1484 Usage: (arglist instructions constants stack-depth
1485 &optional doc-string interactive)
1486 Note that, unlike all other emacs-lisp functions, calling this with five
1487 arguments is NOT the same as calling it with six arguments, the last of
1488 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1489 that this function was defined with `(interactive)'. If the arg is not
1490 specified, then that means the function is not interactive.
1491 This is terrible behavior which is retained for compatibility with old
1492 `.elc' files which expect these semantics.
1494 (int nargs, Lisp_Object *args))
1496 /* In a non-insane world this function would have this arglist...
1497 (arglist instructions constants stack_depth &optional doc_string interactive)
1499 Lisp_Object fun = make_compiled_function ();
1500 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1502 Lisp_Object arglist = args[0];
1503 Lisp_Object instructions = args[1];
1504 Lisp_Object constants = args[2];
1505 Lisp_Object stack_depth = args[3];
1506 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1507 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1509 if (nargs < 4 || nargs > 6)
1510 return Fsignal (Qwrong_number_of_arguments,
1511 list2 (intern ("make-byte-code"), make_int (nargs)));
1513 /* Check for valid formal parameter list now, to allow us to use
1514 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1516 Lisp_Object symbol, tail;
1517 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1519 CHECK_SYMBOL (symbol);
1520 if (EQ (symbol, Qt) ||
1521 EQ (symbol, Qnil) ||
1522 SYMBOL_IS_KEYWORD (symbol))
1523 signal_simple_error_2
1524 ("Invalid constant symbol in formal parameter list",
1528 f->arglist = arglist;
1530 /* `instructions' is a string or a cons (string . int) for a
1531 lazy-loaded function. */
1532 if (CONSP (instructions))
1534 CHECK_STRING (XCAR (instructions));
1535 CHECK_INT (XCDR (instructions));
1539 CHECK_STRING (instructions);
1541 f->instructions = instructions;
1543 if (!NILP (constants))
1544 CHECK_VECTOR (constants);
1545 f->constants = constants;
1547 CHECK_NATNUM (stack_depth);
1548 f->stack_depth = XINT (stack_depth);
1550 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1551 if (!NILP (Vcurrent_compiled_function_annotation))
1552 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1553 else if (!NILP (Vload_file_name_internal_the_purecopy))
1554 f->annotated = Vload_file_name_internal_the_purecopy;
1555 else if (!NILP (Vload_file_name_internal))
1557 struct gcpro gcpro1;
1558 GCPRO1 (fun); /* don't let fun get reaped */
1559 Vload_file_name_internal_the_purecopy =
1560 Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
1561 f->annotated = Vload_file_name_internal_the_purecopy;
1564 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1566 /* doc_string may be nil, string, int, or a cons (string . int).
1567 interactive may be list or string (or unbound). */
1568 f->doc_and_interactive = Qunbound;
1570 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1571 f->doc_and_interactive = Vfile_domain;
1573 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1575 f->doc_and_interactive
1576 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1577 Fcons (interactive, f->doc_and_interactive));
1579 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1581 f->doc_and_interactive
1582 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1583 Fcons (doc_string, f->doc_and_interactive));
1585 if (UNBOUNDP (f->doc_and_interactive))
1586 f->doc_and_interactive = Qnil;
1592 /************************************************************************/
1593 /* Symbol allocation */
1594 /************************************************************************/
1596 DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol);
1597 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1599 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1600 Return a newly allocated uninterned symbol whose name is NAME.
1601 Its value and function definition are void, and its property list is nil.
1606 struct Lisp_Symbol *p;
1608 CHECK_STRING (name);
1610 ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p);
1611 set_lheader_implementation (&(p->lheader), &lrecord_symbol);
1612 p->name = XSTRING (name);
1614 p->value = Qunbound;
1615 p->function = Qunbound;
1616 symbol_next (p) = 0;
1617 XSETSYMBOL (val, p);
1622 /************************************************************************/
1623 /* Extent allocation */
1624 /************************************************************************/
1626 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1627 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1630 allocate_extent (void)
1634 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1635 set_lheader_implementation (&(e->lheader), &lrecord_extent);
1636 extent_object (e) = Qnil;
1637 set_extent_start (e, -1);
1638 set_extent_end (e, -1);
1643 extent_face (e) = Qnil;
1644 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1645 e->flags.detachable = 1;
1651 /************************************************************************/
1652 /* Event allocation */
1653 /************************************************************************/
1655 DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event);
1656 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1659 allocate_event (void)
1662 struct Lisp_Event *e;
1664 ALLOCATE_FIXED_TYPE (event, struct Lisp_Event, e);
1665 set_lheader_implementation (&(e->lheader), &lrecord_event);
1672 /************************************************************************/
1673 /* Marker allocation */
1674 /************************************************************************/
1676 DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker);
1677 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1679 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1680 Return a new marker which does not point at any place.
1685 struct Lisp_Marker *p;
1687 ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1688 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1691 marker_next (p) = 0;
1692 marker_prev (p) = 0;
1693 p->insertion_type = 0;
1694 XSETMARKER (val, p);
1699 noseeum_make_marker (void)
1702 struct Lisp_Marker *p;
1704 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1705 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1708 marker_next (p) = 0;
1709 marker_prev (p) = 0;
1710 p->insertion_type = 0;
1711 XSETMARKER (val, p);
1716 /************************************************************************/
1717 /* String allocation */
1718 /************************************************************************/
1720 /* The data for "short" strings generally resides inside of structs of type
1721 string_chars_block. The Lisp_String structure is allocated just like any
1722 other Lisp object (except for vectors), and these are freelisted when
1723 they get garbage collected. The data for short strings get compacted,
1724 but the data for large strings do not.
1726 Previously Lisp_String structures were relocated, but this caused a lot
1727 of bus-errors because the C code didn't include enough GCPRO's for
1728 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1729 that the reference would get relocated).
1731 This new method makes things somewhat bigger, but it is MUCH safer. */
1733 DECLARE_FIXED_TYPE_ALLOC (string, struct Lisp_String);
1734 /* strings are used and freed quite often */
1735 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1736 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1739 mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object))
1741 struct Lisp_String *ptr = XSTRING (obj);
1743 if (GC_CONSP (ptr->plist) && GC_EXTENT_INFOP (XCAR (ptr->plist)))
1744 flush_cached_extent_info (XCAR (ptr->plist));
1749 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1752 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1753 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1756 static const struct lrecord_description string_description[] = {
1757 { XD_STRING_DATA, offsetof(Lisp_String, data) },
1758 { XD_LISP_OBJECT, offsetof(Lisp_String, plist), 1 },
1762 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
1763 mark_string, print_string,
1765 * No `finalize', or `hash' methods.
1766 * internal_hash already knows how
1767 * to hash strings and finalization
1769 * ADDITIONAL_FREE_string macro,
1770 * which is the standard way to do
1771 * finalization when using
1772 * SWEEP_FIXED_TYPE_BLOCK().
1776 struct Lisp_String);
1778 /* String blocks contain this many useful bytes. */
1779 #define STRING_CHARS_BLOCK_SIZE \
1780 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1781 ((2 * sizeof (struct string_chars_block *)) \
1782 + sizeof (EMACS_INT))))
1783 /* Block header for small strings. */
1784 struct string_chars_block
1787 struct string_chars_block *next;
1788 struct string_chars_block *prev;
1789 /* Contents of string_chars_block->string_chars are interleaved
1790 string_chars structures (see below) and the actual string data */
1791 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1794 struct string_chars_block *first_string_chars_block;
1795 struct string_chars_block *current_string_chars_block;
1797 /* If SIZE is the length of a string, this returns how many bytes
1798 * the string occupies in string_chars_block->string_chars
1799 * (including alignment padding).
1801 #define STRING_FULLSIZE(s) \
1802 ALIGN_SIZE (((s) + 1 + sizeof (struct Lisp_String *)),\
1803 ALIGNOF (struct Lisp_String *))
1805 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1806 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1808 #define CHARS_TO_STRING_CHAR(x) \
1809 ((struct string_chars *) \
1810 (((char *) (x)) - (slot_offset (struct string_chars, chars[0]))))
1815 struct Lisp_String *string;
1816 unsigned char chars[1];
1819 struct unused_string_chars
1821 struct Lisp_String *string;
1826 init_string_chars_alloc (void)
1828 first_string_chars_block = xnew (struct string_chars_block);
1829 first_string_chars_block->prev = 0;
1830 first_string_chars_block->next = 0;
1831 first_string_chars_block->pos = 0;
1832 current_string_chars_block = first_string_chars_block;
1835 static struct string_chars *
1836 allocate_string_chars_struct (struct Lisp_String *string_it_goes_with,
1839 struct string_chars *s_chars;
1841 /* Allocate the string's actual data */
1842 if (BIG_STRING_FULLSIZE_P (fullsize))
1844 s_chars = (struct string_chars *) xmalloc (fullsize);
1846 else if (fullsize <=
1847 (countof (current_string_chars_block->string_chars)
1848 - current_string_chars_block->pos))
1850 /* This string can fit in the current string chars block */
1851 s_chars = (struct string_chars *)
1852 (current_string_chars_block->string_chars
1853 + current_string_chars_block->pos);
1854 current_string_chars_block->pos += fullsize;
1858 /* Make a new current string chars block */
1859 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1861 current_string_chars_block->next = new_scb;
1862 new_scb->prev = current_string_chars_block;
1864 current_string_chars_block = new_scb;
1865 new_scb->pos = fullsize;
1866 s_chars = (struct string_chars *)
1867 current_string_chars_block->string_chars;
1870 s_chars->string = string_it_goes_with;
1872 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1878 make_uninit_string (Bytecount length)
1880 struct Lisp_String *s;
1881 struct string_chars *s_chars;
1882 EMACS_INT fullsize = STRING_FULLSIZE (length);
1885 if ((length < 0) || (fullsize <= 0))
1888 /* Allocate the string header */
1889 ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
1890 set_lheader_implementation (&(s->lheader), &lrecord_string);
1892 s_chars = allocate_string_chars_struct (s, fullsize);
1894 set_string_data (s, &(s_chars->chars[0]));
1895 set_string_length (s, length);
1898 set_string_byte (s, length, 0);
1900 XSETSTRING (val, s);
1904 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1905 static void verify_string_chars_integrity (void);
1908 /* Resize the string S so that DELTA bytes can be inserted starting
1909 at POS. If DELTA < 0, it means deletion starting at POS. If
1910 POS < 0, resize the string but don't copy any characters. Use
1911 this if you're planning on completely overwriting the string.
1915 resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta)
1917 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1918 verify_string_chars_integrity ();
1921 #ifdef ERROR_CHECK_BUFPOS
1924 assert (pos <= string_length (s));
1926 assert (pos + (-delta) <= string_length (s));
1931 assert ((-delta) <= string_length (s));
1933 #endif /* ERROR_CHECK_BUFPOS */
1935 if (pos >= 0 && delta < 0)
1936 /* If DELTA < 0, the functions below will delete the characters
1937 before POS. We want to delete characters *after* POS, however,
1938 so convert this to the appropriate form. */
1942 /* simplest case: no size change. */
1946 Bytecount oldfullsize = STRING_FULLSIZE (string_length (s));
1947 Bytecount newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1949 if (oldfullsize == newfullsize)
1951 /* next simplest case; size change but the necessary
1952 allocation size won't change (up or down; code somewhere
1953 depends on there not being any unused allocation space,
1954 modulo any alignment constraints). */
1957 Bufbyte *addroff = pos + string_data (s);
1959 memmove (addroff + delta, addroff,
1960 /* +1 due to zero-termination. */
1961 string_length (s) + 1 - pos);
1964 else if (BIG_STRING_FULLSIZE_P (oldfullsize) &&
1965 BIG_STRING_FULLSIZE_P (newfullsize))
1967 /* next simplest case; the string is big enough to be malloc()ed
1968 itself, so we just realloc.
1970 It's important not to let the string get below the threshold
1971 for making big strings and still remain malloc()ed; if that
1972 were the case, repeated calls to this function on the same
1973 string could result in memory leakage. */
1974 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1978 Bufbyte *addroff = pos + string_data (s);
1980 memmove (addroff + delta, addroff,
1981 /* +1 due to zero-termination. */
1982 string_length (s) + 1 - pos);
1987 /* worst case. We make a new string_chars struct and copy
1988 the string's data into it, inserting/deleting the delta
1989 in the process. The old string data will either get
1990 freed by us (if it was malloc()ed) or will be reclaimed
1991 in the normal course of garbage collection. */
1992 struct string_chars *s_chars =
1993 allocate_string_chars_struct (s, newfullsize);
1994 Bufbyte *new_addr = &(s_chars->chars[0]);
1995 Bufbyte *old_addr = string_data (s);
1998 memcpy (new_addr, old_addr, pos);
1999 memcpy (new_addr + pos + delta, old_addr + pos,
2000 string_length (s) + 1 - pos);
2002 set_string_data (s, new_addr);
2003 if (BIG_STRING_FULLSIZE_P (oldfullsize))
2007 /* We need to mark this chunk of the string_chars_block
2008 as unused so that compact_string_chars() doesn't
2010 struct string_chars *old_s_chars =
2011 (struct string_chars *) ((char *) old_addr -
2012 sizeof (struct Lisp_String *));
2013 /* Sanity check to make sure we aren't hosed by strange
2014 alignment/padding. */
2015 assert (old_s_chars->string == s);
2016 MARK_STRUCT_AS_FREE (old_s_chars);
2017 ((struct unused_string_chars *) old_s_chars)->fullsize =
2022 set_string_length (s, string_length (s) + delta);
2023 /* If pos < 0, the string won't be zero-terminated.
2024 Terminate now just to make sure. */
2025 string_data (s)[string_length (s)] = '\0';
2031 XSETSTRING (string, s);
2032 /* We also have to adjust all of the extent indices after the
2033 place we did the change. We say "pos - 1" because
2034 adjust_extents() is exclusive of the starting position
2036 adjust_extents (string, pos - 1, string_length (s),
2041 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2042 verify_string_chars_integrity ();
2049 set_string_char (struct Lisp_String *s, Charcount i, Emchar c)
2051 Bufbyte newstr[MAX_EMCHAR_LEN];
2052 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2053 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2054 Bytecount newlen = set_charptr_emchar (newstr, c);
2056 if (oldlen != newlen)
2057 resize_string (s, bytoff, newlen - oldlen);
2058 /* Remember, string_data (s) might have changed so we can't cache it. */
2059 memcpy (string_data (s) + bytoff, newstr, newlen);
2064 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2065 Return a new string of length LENGTH, with each character being INIT.
2066 LENGTH must be an integer and INIT must be a character.
2070 CHECK_NATNUM (length);
2071 CHECK_CHAR_COERCE_INT (init);
2073 Bufbyte init_str[MAX_EMCHAR_LEN];
2074 int len = set_charptr_emchar (init_str, XCHAR (init));
2075 Lisp_Object val = make_uninit_string (len * XINT (length));
2078 /* Optimize the single-byte case */
2079 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2083 Bufbyte *ptr = XSTRING_DATA (val);
2085 for (i = XINT (length); i; i--)
2087 Bufbyte *init_ptr = init_str;
2091 case 6: *ptr++ = *init_ptr++;
2092 case 5: *ptr++ = *init_ptr++;
2094 case 4: *ptr++ = *init_ptr++;
2095 case 3: *ptr++ = *init_ptr++;
2096 case 2: *ptr++ = *init_ptr++;
2097 case 1: *ptr++ = *init_ptr++;
2105 DEFUN ("string", Fstring, 0, MANY, 0, /*
2106 Concatenate all the argument characters and make the result a string.
2108 (int nargs, Lisp_Object *args))
2110 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2111 Bufbyte *p = storage;
2113 for (; nargs; nargs--, args++)
2115 Lisp_Object lisp_char = *args;
2116 CHECK_CHAR_COERCE_INT (lisp_char);
2117 p += set_charptr_emchar (p, XCHAR (lisp_char));
2119 return make_string (storage, p - storage);
2123 /* Take some raw memory, which MUST already be in internal format,
2124 and package it up into a Lisp string. */
2126 make_string (CONST Bufbyte *contents, Bytecount length)
2130 /* Make sure we find out about bad make_string's when they happen */
2131 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2132 bytecount_to_charcount (contents, length); /* Just for the assertions */
2135 val = make_uninit_string (length);
2136 memcpy (XSTRING_DATA (val), contents, length);
2140 /* Take some raw memory, encoded in some external data format,
2141 and convert it into a Lisp string. */
2143 make_ext_string (CONST Extbyte *contents, EMACS_INT length,
2144 enum external_data_format fmt)
2149 GET_CHARPTR_INT_DATA_ALLOCA (contents, length, fmt, intstr, intlen);
2150 return make_string (intstr, intlen);
2154 build_string (CONST char *str)
2156 /* Some strlen's crash and burn if passed null. */
2157 return make_string ((CONST Bufbyte *) str, (str ? strlen(str) : 0));
2161 build_ext_string (CONST char *str, enum external_data_format fmt)
2163 /* Some strlen's crash and burn if passed null. */
2164 return make_ext_string ((CONST Extbyte *) str, (str ? strlen(str) : 0), fmt);
2168 build_translated_string (CONST char *str)
2170 return build_string (GETTEXT (str));
2174 make_string_nocopy (CONST Bufbyte *contents, Bytecount length)
2176 struct Lisp_String *s;
2179 /* Make sure we find out about bad make_string_nocopy's when they happen */
2180 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2181 bytecount_to_charcount (contents, length); /* Just for the assertions */
2184 /* Allocate the string header */
2185 ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
2186 set_lheader_implementation (&(s->lheader), &lrecord_string);
2187 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2189 set_string_data (s, (Bufbyte *)contents);
2190 set_string_length (s, length);
2192 XSETSTRING (val, s);
2197 /************************************************************************/
2198 /* lcrecord lists */
2199 /************************************************************************/
2201 /* Lcrecord lists are used to manage the allocation of particular
2202 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2203 malloc() and garbage-collection junk) as much as possible.
2204 It is similar to the Blocktype class.
2208 1) Create an lcrecord-list object using make_lcrecord_list().
2209 This is often done at initialization. Remember to staticpro
2210 this object! The arguments to make_lcrecord_list() are the
2211 same as would be passed to alloc_lcrecord().
2212 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2213 and pass the lcrecord-list earlier created.
2214 3) When done with the lcrecord, call free_managed_lcrecord().
2215 The standard freeing caveats apply: ** make sure there are no
2216 pointers to the object anywhere! **
2217 4) Calling free_managed_lcrecord() is just like kissing the
2218 lcrecord goodbye as if it were garbage-collected. This means:
2219 -- the contents of the freed lcrecord are undefined, and the
2220 contents of something produced by allocate_managed_lcrecord()
2221 are undefined, just like for alloc_lcrecord().
2222 -- the mark method for the lcrecord's type will *NEVER* be called
2224 -- the finalize method for the lcrecord's type will be called
2225 at the time that free_managed_lcrecord() is called.
2230 mark_lcrecord_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
2232 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2233 Lisp_Object chain = list->free;
2235 while (!NILP (chain))
2237 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2238 struct free_lcrecord_header *free_header =
2239 (struct free_lcrecord_header *) lheader;
2241 #ifdef ERROR_CHECK_GC
2242 CONST struct lrecord_implementation *implementation
2243 = LHEADER_IMPLEMENTATION(lheader);
2245 /* There should be no other pointers to the free list. */
2246 assert (!MARKED_RECORD_HEADER_P (lheader));
2247 /* Only lcrecords should be here. */
2248 assert (!implementation->basic_p);
2249 /* Only free lcrecords should be here. */
2250 assert (free_header->lcheader.free);
2251 /* The type of the lcrecord must be right. */
2252 assert (implementation == list->implementation);
2253 /* So must the size. */
2254 assert (implementation->static_size == 0
2255 || implementation->static_size == list->size);
2256 #endif /* ERROR_CHECK_GC */
2258 MARK_RECORD_HEADER (lheader);
2259 chain = free_header->chain;
2265 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2266 mark_lcrecord_list, internal_object_printer,
2267 0, 0, 0, 0, struct lcrecord_list);
2269 make_lcrecord_list (size_t size,
2270 CONST struct lrecord_implementation *implementation)
2272 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2273 &lrecord_lcrecord_list);
2276 p->implementation = implementation;
2279 XSETLCRECORD_LIST (val, p);
2284 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2286 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2287 if (!NILP (list->free))
2289 Lisp_Object val = list->free;
2290 struct free_lcrecord_header *free_header =
2291 (struct free_lcrecord_header *) XPNTR (val);
2293 #ifdef ERROR_CHECK_GC
2294 struct lrecord_header *lheader =
2295 (struct lrecord_header *) free_header;
2296 CONST struct lrecord_implementation *implementation
2297 = LHEADER_IMPLEMENTATION (lheader);
2299 /* There should be no other pointers to the free list. */
2300 assert (!MARKED_RECORD_HEADER_P (lheader));
2301 /* Only lcrecords should be here. */
2302 assert (!implementation->basic_p);
2303 /* Only free lcrecords should be here. */
2304 assert (free_header->lcheader.free);
2305 /* The type of the lcrecord must be right. */
2306 assert (implementation == list->implementation);
2307 /* So must the size. */
2308 assert (implementation->static_size == 0
2309 || implementation->static_size == list->size);
2310 #endif /* ERROR_CHECK_GC */
2311 list->free = free_header->chain;
2312 free_header->lcheader.free = 0;
2319 XSETOBJ (val, Lisp_Type_Record,
2320 alloc_lcrecord (list->size, list->implementation));
2326 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2328 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2329 struct free_lcrecord_header *free_header =
2330 (struct free_lcrecord_header *) XPNTR (lcrecord);
2331 struct lrecord_header *lheader =
2332 (struct lrecord_header *) free_header;
2333 CONST struct lrecord_implementation *implementation
2334 = LHEADER_IMPLEMENTATION (lheader);
2336 #ifdef ERROR_CHECK_GC
2337 /* Make sure the size is correct. This will catch, for example,
2338 putting a window configuration on the wrong free list. */
2339 if (implementation->size_in_bytes_method)
2340 assert (implementation->size_in_bytes_method (lheader) == list->size);
2342 assert (implementation->static_size == list->size);
2343 #endif /* ERROR_CHECK_GC */
2345 if (implementation->finalizer)
2346 implementation->finalizer (lheader, 0);
2347 free_header->chain = list->free;
2348 free_header->lcheader.free = 1;
2349 list->free = lcrecord;
2355 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2356 Kept for compatibility, returns its argument.
2358 Make a copy of OBJECT in pure storage.
2359 Recursively copies contents of vectors and cons cells.
2360 Does not copy symbols.
2369 /************************************************************************/
2370 /* Garbage Collection */
2371 /************************************************************************/
2373 /* This will be used more extensively In The Future */
2374 static int last_lrecord_type_index_assigned;
2376 CONST struct lrecord_implementation *lrecord_implementations_table[128];
2377 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
2379 struct gcpro *gcprolist;
2381 /* 415 used Mly 29-Jun-93 */
2382 /* 1327 used slb 28-Feb-98 */
2384 #define NSTATICS 4000
2386 #define NSTATICS 2000
2388 /* Not "static" because of linker lossage on some systems */
2389 Lisp_Object *staticvec[NSTATICS]
2390 /* Force it into data space! */
2392 static int staticidx;
2394 /* Put an entry in staticvec, pointing at the variable whose address is given
2397 staticpro (Lisp_Object *varaddress)
2399 if (staticidx >= countof (staticvec))
2400 /* #### This is now a dubious abort() since this routine may be called */
2401 /* by Lisp attempting to load a DLL. */
2403 staticvec[staticidx++] = varaddress;
2407 /* Mark reference to a Lisp_Object. If the object referred to has not been
2408 seen yet, recursively mark all the references contained in it. */
2411 mark_object (Lisp_Object obj)
2415 #ifdef ERROR_CHECK_GC
2416 assert (! (GC_EQ (obj, Qnull_pointer)));
2418 /* Checks we used to perform */
2419 /* if (EQ (obj, Qnull_pointer)) return; */
2420 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2421 /* if (PURIFIED (XPNTR (obj))) return; */
2423 if (XGCTYPE (obj) == Lisp_Type_Record)
2425 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2426 #if defined (ERROR_CHECK_GC)
2427 assert (lheader->type <= last_lrecord_type_index_assigned);
2429 if (C_READONLY_RECORD_HEADER_P (lheader))
2432 if (! MARKED_RECORD_HEADER_P (lheader) &&
2433 ! UNMARKABLE_RECORD_HEADER_P (lheader))
2435 CONST struct lrecord_implementation *implementation =
2436 LHEADER_IMPLEMENTATION (lheader);
2437 MARK_RECORD_HEADER (lheader);
2438 #ifdef ERROR_CHECK_GC
2439 if (!implementation->basic_p)
2440 assert (! ((struct lcrecord_header *) lheader)->free);
2442 if (implementation->marker)
2444 obj = implementation->marker (obj, mark_object);
2445 if (!GC_NILP (obj)) goto tail_recurse;
2451 /* mark all of the conses in a list and mark the final cdr; but
2452 DO NOT mark the cars.
2454 Use only for internal lists! There should never be other pointers
2455 to the cons cells, because if so, the cars will remain unmarked
2456 even when they maybe should be marked. */
2458 mark_conses_in_list (Lisp_Object obj)
2462 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2464 if (CONS_MARKED_P (XCONS (rest)))
2466 MARK_CONS (XCONS (rest));
2473 /* Find all structures not marked, and free them. */
2475 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2476 static int gc_count_bit_vector_storage;
2477 static int gc_count_num_short_string_in_use;
2478 static int gc_count_string_total_size;
2479 static int gc_count_short_string_total_size;
2481 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2485 lrecord_type_index (CONST struct lrecord_implementation *implementation)
2487 int type_index = *(implementation->lrecord_type_index);
2488 /* Have to do this circuitous validation test because of problems
2489 dumping out initialized variables (ie can't set xxx_type_index to -1
2490 because that would make xxx_type_index read-only in a dumped emacs. */
2491 if (type_index < 0 || type_index > max_lrecord_type
2492 || lrecord_implementations_table[type_index] != implementation)
2494 assert (last_lrecord_type_index_assigned < max_lrecord_type);
2495 type_index = ++last_lrecord_type_index_assigned;
2496 lrecord_implementations_table[type_index] = implementation;
2497 *(implementation->lrecord_type_index) = type_index;
2502 /* stats on lcrecords in use - kinda kludgy */
2506 int instances_in_use;
2508 int instances_freed;
2510 int instances_on_free_list;
2511 } lcrecord_stats [countof (lrecord_implementations_table)];
2514 tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p)
2516 CONST struct lrecord_implementation *implementation =
2517 LHEADER_IMPLEMENTATION (h);
2518 int type_index = lrecord_type_index (implementation);
2520 if (((struct lcrecord_header *) h)->free)
2523 lcrecord_stats[type_index].instances_on_free_list++;
2527 size_t sz = (implementation->size_in_bytes_method
2528 ? implementation->size_in_bytes_method (h)
2529 : implementation->static_size);
2533 lcrecord_stats[type_index].instances_freed++;
2534 lcrecord_stats[type_index].bytes_freed += sz;
2538 lcrecord_stats[type_index].instances_in_use++;
2539 lcrecord_stats[type_index].bytes_in_use += sz;
2545 /* Free all unmarked records */
2547 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2549 struct lcrecord_header *header;
2551 /* int total_size = 0; */
2553 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2555 /* First go through and call all the finalize methods.
2556 Then go through and free the objects. There used to
2557 be only one loop here, with the call to the finalizer
2558 occurring directly before the xfree() below. That
2559 is marginally faster but much less safe -- if the
2560 finalize method for an object needs to reference any
2561 other objects contained within it (and many do),
2562 we could easily be screwed by having already freed that
2565 for (header = *prev; header; header = header->next)
2567 struct lrecord_header *h = &(header->lheader);
2568 if (!C_READONLY_RECORD_HEADER_P(h)
2569 && !MARKED_RECORD_HEADER_P (h)
2570 && ! (header->free))
2572 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2573 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2577 for (header = *prev; header; )
2579 struct lrecord_header *h = &(header->lheader);
2580 if (C_READONLY_RECORD_HEADER_P(h) || MARKED_RECORD_HEADER_P (h))
2582 if (MARKED_RECORD_HEADER_P (h))
2583 UNMARK_RECORD_HEADER (h);
2585 /* total_size += n->implementation->size_in_bytes (h);*/
2586 /* ### May modify header->next on a C_READONLY lcrecord */
2587 prev = &(header->next);
2589 tick_lcrecord_stats (h, 0);
2593 struct lcrecord_header *next = header->next;
2595 tick_lcrecord_stats (h, 1);
2596 /* used to call finalizer right here. */
2602 /* *total = total_size; */
2607 sweep_bit_vectors_1 (Lisp_Object *prev,
2608 int *used, int *total, int *storage)
2610 Lisp_Object bit_vector;
2613 int total_storage = 0;
2615 /* BIT_VECTORP fails because the objects are marked, which changes
2616 their implementation */
2617 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2619 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2621 if (C_READONLY_RECORD_HEADER_P(&(v->lheader)) || MARKED_RECORD_P (bit_vector))
2623 if (MARKED_RECORD_P (bit_vector))
2624 UNMARK_RECORD_HEADER (&(v->lheader));
2628 STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2629 BIT_VECTOR_LONG_STORAGE (len));
2631 /* ### May modify next on a C_READONLY bitvector */
2632 prev = &(bit_vector_next (v));
2637 Lisp_Object next = bit_vector_next (v);
2644 *total = total_size;
2645 *storage = total_storage;
2648 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2649 to make macros prettier. */
2651 #ifdef ERROR_CHECK_GC
2653 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2655 struct typename##_block *SFTB_current; \
2656 struct typename##_block **SFTB_prev; \
2658 int num_free = 0, num_used = 0; \
2660 for (SFTB_prev = ¤t_##typename##_block, \
2661 SFTB_current = current_##typename##_block, \
2662 SFTB_limit = current_##typename##_block_index; \
2668 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2670 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2672 if (FREE_STRUCT_P (SFTB_victim)) \
2676 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2680 else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2683 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2688 UNMARK_##typename (SFTB_victim); \
2691 SFTB_prev = &(SFTB_current->prev); \
2692 SFTB_current = SFTB_current->prev; \
2693 SFTB_limit = countof (current_##typename##_block->block); \
2696 gc_count_num_##typename##_in_use = num_used; \
2697 gc_count_num_##typename##_freelist = num_free; \
2700 #else /* !ERROR_CHECK_GC */
2702 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2704 struct typename##_block *SFTB_current; \
2705 struct typename##_block **SFTB_prev; \
2707 int num_free = 0, num_used = 0; \
2709 typename##_free_list = 0; \
2711 for (SFTB_prev = ¤t_##typename##_block, \
2712 SFTB_current = current_##typename##_block, \
2713 SFTB_limit = current_##typename##_block_index; \
2718 int SFTB_empty = 1; \
2719 obj_type *SFTB_old_free_list = typename##_free_list; \
2721 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2723 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2725 if (FREE_STRUCT_P (SFTB_victim)) \
2728 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2730 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2735 else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2738 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2744 UNMARK_##typename (SFTB_victim); \
2749 SFTB_prev = &(SFTB_current->prev); \
2750 SFTB_current = SFTB_current->prev; \
2752 else if (SFTB_current == current_##typename##_block \
2753 && !SFTB_current->prev) \
2755 /* No real point in freeing sole allocation block */ \
2760 struct typename##_block *SFTB_victim_block = SFTB_current; \
2761 if (SFTB_victim_block == current_##typename##_block) \
2762 current_##typename##_block_index \
2763 = countof (current_##typename##_block->block); \
2764 SFTB_current = SFTB_current->prev; \
2766 *SFTB_prev = SFTB_current; \
2767 xfree (SFTB_victim_block); \
2768 /* Restore free list to what it was before victim was swept */ \
2769 typename##_free_list = SFTB_old_free_list; \
2770 num_free -= SFTB_limit; \
2773 SFTB_limit = countof (current_##typename##_block->block); \
2776 gc_count_num_##typename##_in_use = num_used; \
2777 gc_count_num_##typename##_freelist = num_free; \
2780 #endif /* !ERROR_CHECK_GC */
2788 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2789 #define ADDITIONAL_FREE_cons(ptr)
2791 SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons);
2794 /* Explicitly free a cons cell. */
2796 free_cons (struct Lisp_Cons *ptr)
2798 #ifdef ERROR_CHECK_GC
2799 /* If the CAR is not an int, then it will be a pointer, which will
2800 always be four-byte aligned. If this cons cell has already been
2801 placed on the free list, however, its car will probably contain
2802 a chain pointer to the next cons on the list, which has cleverly
2803 had all its 0's and 1's inverted. This allows for a quick
2804 check to make sure we're not freeing something already freed. */
2805 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2806 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2807 #endif /* ERROR_CHECK_GC */
2809 #ifndef ALLOC_NO_POOLS
2810 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, struct Lisp_Cons, ptr);
2811 #endif /* ALLOC_NO_POOLS */
2814 /* explicitly free a list. You **must make sure** that you have
2815 created all the cons cells that make up this list and that there
2816 are no pointers to any of these cons cells anywhere else. If there
2817 are, you will lose. */
2820 free_list (Lisp_Object list)
2822 Lisp_Object rest, next;
2824 for (rest = list; !NILP (rest); rest = next)
2827 free_cons (XCONS (rest));
2831 /* explicitly free an alist. You **must make sure** that you have
2832 created all the cons cells that make up this alist and that there
2833 are no pointers to any of these cons cells anywhere else. If there
2834 are, you will lose. */
2837 free_alist (Lisp_Object alist)
2839 Lisp_Object rest, next;
2841 for (rest = alist; !NILP (rest); rest = next)
2844 free_cons (XCONS (XCAR (rest)));
2845 free_cons (XCONS (rest));
2850 sweep_compiled_functions (void)
2852 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2853 #define ADDITIONAL_FREE_compiled_function(ptr)
2855 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2859 #ifdef LISP_FLOAT_TYPE
2863 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2864 #define ADDITIONAL_FREE_float(ptr)
2866 SWEEP_FIXED_TYPE_BLOCK (float, struct Lisp_Float);
2868 #endif /* LISP_FLOAT_TYPE */
2871 sweep_symbols (void)
2873 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2874 #define ADDITIONAL_FREE_symbol(ptr)
2876 SWEEP_FIXED_TYPE_BLOCK (symbol, struct Lisp_Symbol);
2880 sweep_extents (void)
2882 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2883 #define ADDITIONAL_FREE_extent(ptr)
2885 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2891 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2892 #define ADDITIONAL_FREE_event(ptr)
2894 SWEEP_FIXED_TYPE_BLOCK (event, struct Lisp_Event);
2898 sweep_markers (void)
2900 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2901 #define ADDITIONAL_FREE_marker(ptr) \
2902 do { Lisp_Object tem; \
2903 XSETMARKER (tem, ptr); \
2904 unchain_marker (tem); \
2907 SWEEP_FIXED_TYPE_BLOCK (marker, struct Lisp_Marker);
2910 /* Explicitly free a marker. */
2912 free_marker (struct Lisp_Marker *ptr)
2914 #ifdef ERROR_CHECK_GC
2915 /* Perhaps this will catch freeing an already-freed marker. */
2917 XSETMARKER (temmy, ptr);
2918 assert (GC_MARKERP (temmy));
2919 #endif /* ERROR_CHECK_GC */
2921 #ifndef ALLOC_NO_POOLS
2922 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr);
2923 #endif /* ALLOC_NO_POOLS */
2927 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2930 verify_string_chars_integrity (void)
2932 struct string_chars_block *sb;
2934 /* Scan each existing string block sequentially, string by string. */
2935 for (sb = first_string_chars_block; sb; sb = sb->next)
2938 /* POS is the index of the next string in the block. */
2939 while (pos < sb->pos)
2941 struct string_chars *s_chars =
2942 (struct string_chars *) &(sb->string_chars[pos]);
2943 struct Lisp_String *string;
2947 /* If the string_chars struct is marked as free (i.e. the STRING
2948 pointer is 0xFFFFFFFF) then this is an unused chunk of string
2949 storage. (See below.) */
2951 if (FREE_STRUCT_P (s_chars))
2953 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
2958 string = s_chars->string;
2959 /* Must be 32-bit aligned. */
2960 assert ((((int) string) & 3) == 0);
2962 size = string_length (string);
2963 fullsize = STRING_FULLSIZE (size);
2965 assert (!BIG_STRING_FULLSIZE_P (fullsize));
2966 assert (string_data (string) == s_chars->chars);
2969 assert (pos == sb->pos);
2973 #endif /* MULE && ERROR_CHECK_GC */
2975 /* Compactify string chars, relocating the reference to each --
2976 free any empty string_chars_block we see. */
2978 compact_string_chars (void)
2980 struct string_chars_block *to_sb = first_string_chars_block;
2982 struct string_chars_block *from_sb;
2984 /* Scan each existing string block sequentially, string by string. */
2985 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
2988 /* FROM_POS is the index of the next string in the block. */
2989 while (from_pos < from_sb->pos)
2991 struct string_chars *from_s_chars =
2992 (struct string_chars *) &(from_sb->string_chars[from_pos]);
2993 struct string_chars *to_s_chars;
2994 struct Lisp_String *string;
2998 /* If the string_chars struct is marked as free (i.e. the STRING
2999 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3000 storage. This happens under Mule when a string's size changes
3001 in such a way that its fullsize changes. (Strings can change
3002 size because a different-length character can be substituted
3003 for another character.) In this case, after the bogus string
3004 pointer is the "fullsize" of this entry, i.e. how many bytes
3007 if (FREE_STRUCT_P (from_s_chars))
3009 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3010 from_pos += fullsize;
3014 string = from_s_chars->string;
3015 assert (!(FREE_STRUCT_P (string)));
3017 size = string_length (string);
3018 fullsize = STRING_FULLSIZE (size);
3020 if (BIG_STRING_FULLSIZE_P (fullsize))
3023 /* Just skip it if it isn't marked. */
3024 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3026 from_pos += fullsize;
3030 /* If it won't fit in what's left of TO_SB, close TO_SB out
3031 and go on to the next string_chars_block. We know that TO_SB
3032 cannot advance past FROM_SB here since FROM_SB is large enough
3033 to currently contain this string. */
3034 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3036 to_sb->pos = to_pos;
3037 to_sb = to_sb->next;
3041 /* Compute new address of this string
3042 and update TO_POS for the space being used. */
3043 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3045 /* Copy the string_chars to the new place. */
3046 if (from_s_chars != to_s_chars)
3047 memmove (to_s_chars, from_s_chars, fullsize);
3049 /* Relocate FROM_S_CHARS's reference */
3050 set_string_data (string, &(to_s_chars->chars[0]));
3052 from_pos += fullsize;
3057 /* Set current to the last string chars block still used and
3058 free any that follow. */
3060 struct string_chars_block *victim;
3062 for (victim = to_sb->next; victim; )
3064 struct string_chars_block *next = victim->next;
3069 current_string_chars_block = to_sb;
3070 current_string_chars_block->pos = to_pos;
3071 current_string_chars_block->next = 0;
3075 #if 1 /* Hack to debug missing purecopy's */
3076 static int debug_string_purity;
3079 debug_string_purity_print (struct Lisp_String *p)
3082 Charcount s = string_char_length (p);
3083 putc ('\"', stderr);
3084 for (i = 0; i < s; i++)
3086 Emchar ch = string_char (p, i);
3087 if (ch < 32 || ch >= 126)
3088 stderr_out ("\\%03o", ch);
3089 else if (ch == '\\' || ch == '\"')
3090 stderr_out ("\\%c", ch);
3092 stderr_out ("%c", ch);
3094 stderr_out ("\"\n");
3100 sweep_strings (void)
3102 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3103 int debug = debug_string_purity;
3105 #define UNMARK_string(ptr) \
3106 do { struct Lisp_String *p = (ptr); \
3107 int size = string_length (p); \
3108 UNMARK_RECORD_HEADER (&(p->lheader)); \
3109 num_bytes += size; \
3110 if (!BIG_STRING_SIZE_P (size)) \
3111 { num_small_bytes += size; \
3114 if (debug) debug_string_purity_print (p); \
3116 #define ADDITIONAL_FREE_string(p) \
3117 do { int size = string_length (p); \
3118 if (BIG_STRING_SIZE_P (size)) \
3119 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
3122 SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String);
3124 gc_count_num_short_string_in_use = num_small_used;
3125 gc_count_string_total_size = num_bytes;
3126 gc_count_short_string_total_size = num_small_bytes;
3130 /* I hate duplicating all this crap! */
3132 marked_p (Lisp_Object obj)
3134 #ifdef ERROR_CHECK_GC
3135 assert (! (GC_EQ (obj, Qnull_pointer)));
3137 /* Checks we used to perform. */
3138 /* if (EQ (obj, Qnull_pointer)) return 1; */
3139 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3140 /* if (PURIFIED (XPNTR (obj))) return 1; */
3142 if (XGCTYPE (obj) == Lisp_Type_Record)
3144 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3145 #if defined (ERROR_CHECK_GC)
3146 assert (lheader->type <= last_lrecord_type_index_assigned);
3148 return C_READONLY_RECORD_HEADER_P (lheader) || MARKED_RECORD_HEADER_P (lheader);
3156 /* Free all unmarked records. Do this at the very beginning,
3157 before anything else, so that the finalize methods can safely
3158 examine items in the objects. sweep_lcrecords_1() makes
3159 sure to call all the finalize methods *before* freeing anything,
3160 to complete the safety. */
3163 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3166 compact_string_chars ();
3168 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3169 macros) must be *extremely* careful to make sure they're not
3170 referencing freed objects. The only two existing finalize
3171 methods (for strings and markers) pass muster -- the string
3172 finalizer doesn't look at anything but its own specially-
3173 created block, and the marker finalizer only looks at live
3174 buffers (which will never be freed) and at the markers before
3175 and after it in the chain (which, by induction, will never be
3176 freed because if so, they would have already removed themselves
3179 /* Put all unmarked strings on free list, free'ing the string chars
3180 of large unmarked strings */
3183 /* Put all unmarked conses on free list */
3186 /* Free all unmarked bit vectors */
3187 sweep_bit_vectors_1 (&all_bit_vectors,
3188 &gc_count_num_bit_vector_used,
3189 &gc_count_bit_vector_total_size,
3190 &gc_count_bit_vector_storage);
3192 /* Free all unmarked compiled-function objects */
3193 sweep_compiled_functions ();
3195 #ifdef LISP_FLOAT_TYPE
3196 /* Put all unmarked floats on free list */
3200 /* Put all unmarked symbols on free list */
3203 /* Put all unmarked extents on free list */
3206 /* Put all unmarked markers on free list.
3207 Dechain each one first from the buffer into which it points. */
3214 /* Clearing for disksave. */
3217 disksave_object_finalization (void)
3219 /* It's important that certain information from the environment not get
3220 dumped with the executable (pathnames, environment variables, etc.).
3221 To make it easier to tell when this has happened with strings(1) we
3222 clear some known-to-be-garbage blocks of memory, so that leftover
3223 results of old evaluation don't look like potential problems.
3224 But first we set some notable variables to nil and do one more GC,
3225 to turn those strings into garbage.
3228 /* Yeah, this list is pretty ad-hoc... */
3229 Vprocess_environment = Qnil;
3230 Vexec_directory = Qnil;
3231 Vdata_directory = Qnil;
3232 Vsite_directory = Qnil;
3233 Vdoc_directory = Qnil;
3234 Vconfigure_info_directory = Qnil;
3237 /* Vdump_load_path = Qnil; */
3238 /* Release hash tables for locate_file */
3239 Flocate_file_clear_hashing (Qt);
3240 uncache_home_directory();
3242 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3243 defined(LOADHIST_BUILTIN))
3244 Vload_history = Qnil;
3246 Vshell_file_name = Qnil;
3248 garbage_collect_1 ();
3250 /* Run the disksave finalization methods of all live objects. */
3251 disksave_object_finalization_1 ();
3253 /* Zero out the uninitialized (really, unused) part of the containers
3254 for the live strings. */
3256 struct string_chars_block *scb;
3257 for (scb = first_string_chars_block; scb; scb = scb->next)
3259 int count = sizeof (scb->string_chars) - scb->pos;
3261 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3263 /* from the block's fill ptr to the end */
3264 memset ((scb->string_chars + scb->pos), 0, count);
3269 /* There, that ought to be enough... */
3275 restore_gc_inhibit (Lisp_Object val)
3277 gc_currently_forbidden = XINT (val);
3281 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3282 static int gc_hooks_inhibited;
3286 garbage_collect_1 (void)
3288 #if MAX_SAVE_STACK > 0
3289 char stack_top_variable;
3290 extern char *stack_bottom;
3295 Lisp_Object pre_gc_cursor;
3296 struct gcpro gcpro1;
3299 || gc_currently_forbidden
3301 || preparing_for_armageddon)
3304 /* We used to call selected_frame() here.
3306 The following functions cannot be called inside GC
3307 so we move to after the above tests. */
3310 Lisp_Object device = Fselected_device (Qnil);
3311 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3313 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3315 signal_simple_error ("No frames exist on device", device);
3319 pre_gc_cursor = Qnil;
3322 GCPRO1 (pre_gc_cursor);
3324 /* Very important to prevent GC during any of the following
3325 stuff that might run Lisp code; otherwise, we'll likely
3326 have infinite GC recursion. */
3327 speccount = specpdl_depth ();
3328 record_unwind_protect (restore_gc_inhibit,
3329 make_int (gc_currently_forbidden));
3330 gc_currently_forbidden = 1;
3332 if (!gc_hooks_inhibited)
3333 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3335 /* Now show the GC cursor/message. */
3336 if (!noninteractive)
3338 if (FRAME_WIN_P (f))
3340 Lisp_Object frame = make_frame (f);
3341 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3342 FRAME_SELECTED_WINDOW (f),
3344 pre_gc_cursor = f->pointer;
3345 if (POINTER_IMAGE_INSTANCEP (cursor)
3346 /* don't change if we don't know how to change back. */
3347 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3350 Fset_frame_pointer (frame, cursor);
3354 /* Don't print messages to the stream device. */
3355 if (!cursor_changed && !FRAME_STREAM_P (f))
3357 char *msg = (STRINGP (Vgc_message)
3358 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3360 Lisp_Object args[2], whole_msg;
3361 args[0] = build_string (msg ? msg :
3362 GETTEXT ((CONST char *) gc_default_message));
3363 args[1] = build_string ("...");
3364 whole_msg = Fconcat (2, args);
3365 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3366 Qgarbage_collecting);
3370 /***** Now we actually start the garbage collection. */
3374 gc_generation_number[0]++;
3376 #if MAX_SAVE_STACK > 0
3378 /* Save a copy of the contents of the stack, for debugging. */
3381 /* Static buffer in which we save a copy of the C stack at each GC. */
3382 static char *stack_copy;
3383 static size_t stack_copy_size;
3385 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3386 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3387 if (stack_size < MAX_SAVE_STACK)
3389 if (stack_copy_size < stack_size)
3391 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3392 stack_copy_size = stack_size;
3396 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3400 #endif /* MAX_SAVE_STACK > 0 */
3402 /* Do some totally ad-hoc resource clearing. */
3403 /* #### generalize this? */
3404 clear_event_resource ();
3405 cleanup_specifiers ();
3407 /* Mark all the special slots that serve as the roots of accessibility. */
3411 for (i = 0; i < staticidx; i++)
3412 mark_object (*(staticvec[i]));
3418 for (tail = gcprolist; tail; tail = tail->next)
3419 for (i = 0; i < tail->nvars; i++)
3420 mark_object (tail->var[i]);
3424 struct specbinding *bind;
3425 for (bind = specpdl; bind != specpdl_ptr; bind++)
3427 mark_object (bind->symbol);
3428 mark_object (bind->old_value);
3433 struct catchtag *catch;
3434 for (catch = catchlist; catch; catch = catch->next)
3436 mark_object (catch->tag);
3437 mark_object (catch->val);
3442 struct backtrace *backlist;
3443 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3445 int nargs = backlist->nargs;
3448 mark_object (*backlist->function);
3449 if (nargs == UNEVALLED || nargs == MANY)
3450 mark_object (backlist->args[0]);
3452 for (i = 0; i < nargs; i++)
3453 mark_object (backlist->args[i]);
3457 mark_redisplay (mark_object);
3458 mark_profiling_info (mark_object);
3460 /* OK, now do the after-mark stuff. This is for things that
3461 are only marked when something else is marked (e.g. weak hash tables).
3462 There may be complex dependencies between such objects -- e.g.
3463 a weak hash table might be unmarked, but after processing a later
3464 weak hash table, the former one might get marked. So we have to
3465 iterate until nothing more gets marked. */
3467 while (finish_marking_weak_hash_tables (marked_p, mark_object) > 0 ||
3468 finish_marking_weak_lists (marked_p, mark_object) > 0)
3471 /* And prune (this needs to be called after everything else has been
3472 marked and before we do any sweeping). */
3473 /* #### this is somewhat ad-hoc and should probably be an object
3475 prune_weak_hash_tables (marked_p);
3476 prune_weak_lists (marked_p);
3477 prune_specifiers (marked_p);
3478 prune_syntax_tables (marked_p);
3482 consing_since_gc = 0;
3483 #ifndef DEBUG_XEMACS
3484 /* Allow you to set it really fucking low if you really want ... */
3485 if (gc_cons_threshold < 10000)
3486 gc_cons_threshold = 10000;
3491 /******* End of garbage collection ********/
3493 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3495 /* Now remove the GC cursor/message */
3496 if (!noninteractive)
3499 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3500 else if (!FRAME_STREAM_P (f))
3502 char *msg = (STRINGP (Vgc_message)
3503 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3506 /* Show "...done" only if the echo area would otherwise be empty. */
3507 if (NILP (clear_echo_area (selected_frame (),
3508 Qgarbage_collecting, 0)))
3510 Lisp_Object args[2], whole_msg;
3511 args[0] = build_string (msg ? msg :
3512 GETTEXT ((CONST char *)
3513 gc_default_message));
3514 args[1] = build_string ("... done");
3515 whole_msg = Fconcat (2, args);
3516 echo_area_message (selected_frame (), (Bufbyte *) 0,
3518 Qgarbage_collecting);
3523 /* now stop inhibiting GC */
3524 unbind_to (speccount, Qnil);
3526 if (!breathing_space)
3528 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3535 /* Debugging aids. */
3538 gc_plist_hack (CONST char *name, int value, Lisp_Object tail)
3540 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3541 or portable numeric datatypes, or bit-vectors, or characters, or
3542 arrays, or exceptions, or ...) */
3543 return cons3 (intern (name), make_int (value), tail);
3546 #define HACK_O_MATIC(type, name, pl) do { \
3548 struct type##_block *x = current_##type##_block; \
3549 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3550 (pl) = gc_plist_hack ((name), s, (pl)); \
3553 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3554 Reclaim storage for Lisp objects no longer needed.
3555 Return info on amount of space in use:
3556 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3557 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3559 where `PLIST' is a list of alternating keyword/value pairs providing
3560 more detailed information.
3561 Garbage collection happens automatically if you cons more than
3562 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3566 Lisp_Object pl = Qnil;
3568 int gc_count_vector_total_size = 0;
3570 garbage_collect_1 ();
3572 for (i = 0; i < last_lrecord_type_index_assigned; i++)
3574 if (lcrecord_stats[i].bytes_in_use != 0
3575 || lcrecord_stats[i].bytes_freed != 0
3576 || lcrecord_stats[i].instances_on_free_list != 0)
3579 CONST char *name = lrecord_implementations_table[i]->name;
3580 int len = strlen (name);
3581 /* save this for the FSFmacs-compatible part of the summary */
3582 if (i == *lrecord_vector.lrecord_type_index)
3583 gc_count_vector_total_size =
3584 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3586 sprintf (buf, "%s-storage", name);
3587 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3588 /* Okay, simple pluralization check for `symbol-value-varalias' */
3589 if (name[len-1] == 's')
3590 sprintf (buf, "%ses-freed", name);
3592 sprintf (buf, "%ss-freed", name);
3593 if (lcrecord_stats[i].instances_freed != 0)
3594 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3595 if (name[len-1] == 's')
3596 sprintf (buf, "%ses-on-free-list", name);
3598 sprintf (buf, "%ss-on-free-list", name);
3599 if (lcrecord_stats[i].instances_on_free_list != 0)
3600 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3602 if (name[len-1] == 's')
3603 sprintf (buf, "%ses-used", name);
3605 sprintf (buf, "%ss-used", name);
3606 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3610 HACK_O_MATIC (extent, "extent-storage", pl);
3611 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3612 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3613 HACK_O_MATIC (event, "event-storage", pl);
3614 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3615 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3616 HACK_O_MATIC (marker, "marker-storage", pl);
3617 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3618 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3619 #ifdef LISP_FLOAT_TYPE
3620 HACK_O_MATIC (float, "float-storage", pl);
3621 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3622 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3623 #endif /* LISP_FLOAT_TYPE */
3624 HACK_O_MATIC (string, "string-header-storage", pl);
3625 pl = gc_plist_hack ("long-strings-total-length",
3626 gc_count_string_total_size
3627 - gc_count_short_string_total_size, pl);
3628 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3629 pl = gc_plist_hack ("short-strings-total-length",
3630 gc_count_short_string_total_size, pl);
3631 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3632 pl = gc_plist_hack ("long-strings-used",
3633 gc_count_num_string_in_use
3634 - gc_count_num_short_string_in_use, pl);
3635 pl = gc_plist_hack ("short-strings-used",
3636 gc_count_num_short_string_in_use, pl);
3638 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3639 pl = gc_plist_hack ("compiled-functions-free",
3640 gc_count_num_compiled_function_freelist, pl);
3641 pl = gc_plist_hack ("compiled-functions-used",
3642 gc_count_num_compiled_function_in_use, pl);
3644 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3645 pl = gc_plist_hack ("bit-vectors-total-length",
3646 gc_count_bit_vector_total_size, pl);
3647 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3649 HACK_O_MATIC (symbol, "symbol-storage", pl);
3650 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3651 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3653 HACK_O_MATIC (cons, "cons-storage", pl);
3654 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3655 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3657 /* The things we do for backwards-compatibility */
3659 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3660 make_int (gc_count_num_cons_freelist)),
3661 Fcons (make_int (gc_count_num_symbol_in_use),
3662 make_int (gc_count_num_symbol_freelist)),
3663 Fcons (make_int (gc_count_num_marker_in_use),
3664 make_int (gc_count_num_marker_freelist)),
3665 make_int (gc_count_string_total_size),
3666 make_int (gc_count_vector_total_size),
3671 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3672 Return the number of bytes consed since the last garbage collection.
3673 \"Consed\" is a misnomer in that this actually counts allocation
3674 of all different kinds of objects, not just conses.
3676 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3680 return make_int (consing_since_gc);
3683 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
3684 Return the address of the last byte Emacs has allocated, divided by 1024.
3685 This may be helpful in debugging Emacs's memory usage.
3686 The value is divided by 1024 to make sure it will fit in a lisp integer.
3690 return make_int ((EMACS_INT) sbrk (0) / 1024);
3696 object_dead_p (Lisp_Object obj)
3698 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3699 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3700 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3701 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3702 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3703 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3704 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3707 #ifdef MEMORY_USAGE_STATS
3709 /* Attempt to determine the actual amount of space that is used for
3710 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3712 It seems that the following holds:
3714 1. When using the old allocator (malloc.c):
3716 -- blocks are always allocated in chunks of powers of two. For
3717 each block, there is an overhead of 8 bytes if rcheck is not
3718 defined, 20 bytes if it is defined. In other words, a
3719 one-byte allocation needs 8 bytes of overhead for a total of
3720 9 bytes, and needs to have 16 bytes of memory chunked out for
3723 2. When using the new allocator (gmalloc.c):
3725 -- blocks are always allocated in chunks of powers of two up
3726 to 4096 bytes. Larger blocks are allocated in chunks of
3727 an integral multiple of 4096 bytes. The minimum block
3728 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3729 is defined. There is no per-block overhead, but there
3730 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3733 3. When using the system malloc, anything goes, but they are
3734 generally slower and more space-efficient than the GNU
3735 allocators. One possibly reasonable assumption to make
3736 for want of better data is that sizeof (void *), or maybe
3737 2 * sizeof (void *), is required as overhead and that
3738 blocks are allocated in the minimum required size except
3739 that some minimum block size is imposed (e.g. 16 bytes). */
3742 malloced_storage_size (void *ptr, size_t claimed_size,
3743 struct overhead_stats *stats)
3745 size_t orig_claimed_size = claimed_size;
3749 if (claimed_size < 2 * sizeof (void *))
3750 claimed_size = 2 * sizeof (void *);
3751 # ifdef SUNOS_LOCALTIME_BUG
3752 if (claimed_size < 16)
3755 if (claimed_size < 4096)
3759 /* compute the log base two, more or less, then use it to compute
3760 the block size needed. */
3762 /* It's big, it's heavy, it's wood! */
3763 while ((claimed_size /= 2) != 0)
3766 /* It's better than bad, it's good! */
3772 /* We have to come up with some average about the amount of
3774 if ((size_t) (rand () & 4095) < claimed_size)
3775 claimed_size += 3 * sizeof (void *);
3779 claimed_size += 4095;
3780 claimed_size &= ~4095;
3781 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3784 #elif defined (SYSTEM_MALLOC)
3786 if (claimed_size < 16)
3788 claimed_size += 2 * sizeof (void *);
3790 #else /* old GNU allocator */
3792 # ifdef rcheck /* #### may not be defined here */
3800 /* compute the log base two, more or less, then use it to compute
3801 the block size needed. */
3803 /* It's big, it's heavy, it's wood! */
3804 while ((claimed_size /= 2) != 0)
3807 /* It's better than bad, it's good! */
3815 #endif /* old GNU allocator */
3819 stats->was_requested += orig_claimed_size;
3820 stats->malloc_overhead += claimed_size - orig_claimed_size;
3822 return claimed_size;
3826 fixed_type_block_overhead (size_t size)
3828 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3829 size_t overhead = 0;
3830 size_t storage_size = malloced_storage_size (0, per_block, 0);
3831 while (size >= per_block)
3834 overhead += sizeof (void *) + per_block - storage_size;
3836 if (rand () % per_block < size)
3837 overhead += sizeof (void *) + per_block - storage_size;
3841 #endif /* MEMORY_USAGE_STATS */
3844 /* Initialization */
3846 init_alloc_once_early (void)
3850 last_lrecord_type_index_assigned = -1;
3851 for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
3853 lrecord_implementations_table[iii] = 0;
3858 * defined subr lrecords were initialized with lheader->type == 0.
3859 * See subr_lheader_initializer in lisp.h. Force type index 0 to be
3860 * assigned to lrecord_subr so that those predefined indexes match
3863 lrecord_type_index (&lrecord_subr);
3864 assert (*(lrecord_subr.lrecord_type_index) == 0);
3866 * The same is true for symbol_value_forward objects, except the
3869 lrecord_type_index (&lrecord_symbol_value_forward);
3870 assert (*(lrecord_symbol_value_forward.lrecord_type_index) == 1);
3872 gc_generation_number[0] = 0;
3873 /* purify_flag 1 is correct even if CANNOT_DUMP.
3874 * loadup.el will set to nil at end. */
3876 breathing_space = 0;
3877 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3878 XSETINT (Vgc_message, 0);
3880 ignore_malloc_warnings = 1;
3881 #ifdef DOUG_LEA_MALLOC
3882 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3883 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3884 #if 0 /* Moved to emacs.c */
3885 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3888 init_string_alloc ();
3889 init_string_chars_alloc ();
3891 init_symbol_alloc ();
3892 init_compiled_function_alloc ();
3893 #ifdef LISP_FLOAT_TYPE
3894 init_float_alloc ();
3895 #endif /* LISP_FLOAT_TYPE */
3896 init_marker_alloc ();
3897 init_extent_alloc ();
3898 init_event_alloc ();
3900 ignore_malloc_warnings = 0;
3902 consing_since_gc = 0;
3904 gc_cons_threshold = 500000; /* XEmacs change */
3906 gc_cons_threshold = 15000; /* debugging */
3908 #ifdef VIRT_ADDR_VARIES
3909 malloc_sbrk_unused = 1<<22; /* A large number */
3910 malloc_sbrk_used = 100000; /* as reasonable as any number */
3911 #endif /* VIRT_ADDR_VARIES */
3912 lrecord_uid_counter = 259;
3913 debug_string_purity = 0;
3916 gc_currently_forbidden = 0;
3917 gc_hooks_inhibited = 0;
3919 #ifdef ERROR_CHECK_TYPECHECK
3920 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3923 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3925 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3927 #endif /* ERROR_CHECK_TYPECHECK */
3930 int pure_bytes_used = 0;
3939 syms_of_alloc (void)
3941 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
3942 defsymbol (&Qpost_gc_hook, "post-gc-hook");
3943 defsymbol (&Qgarbage_collecting, "garbage-collecting");
3948 DEFSUBR (Fbit_vector);
3949 DEFSUBR (Fmake_byte_code);
3950 DEFSUBR (Fmake_list);
3951 DEFSUBR (Fmake_vector);
3952 DEFSUBR (Fmake_bit_vector);
3953 DEFSUBR (Fmake_string);
3955 DEFSUBR (Fmake_symbol);
3956 DEFSUBR (Fmake_marker);
3957 DEFSUBR (Fpurecopy);
3958 DEFSUBR (Fgarbage_collect);
3959 DEFSUBR (Fmemory_limit);
3960 DEFSUBR (Fconsing_since_gc);
3964 vars_of_alloc (void)
3966 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
3967 *Number of bytes of consing between garbage collections.
3968 \"Consing\" is a misnomer in that this actually counts allocation
3969 of all different kinds of objects, not just conses.
3970 Garbage collection can happen automatically once this many bytes have been
3971 allocated since the last garbage collection. All data types count.
3973 Garbage collection happens automatically when `eval' or `funcall' are
3974 called. (Note that `funcall' is called implicitly as part of evaluation.)
3975 By binding this temporarily to a large number, you can effectively
3976 prevent garbage collection during a part of the program.
3978 See also `consing-since-gc'.
3981 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
3982 Number of bytes of sharable Lisp data allocated so far.
3986 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
3987 Number of bytes of unshared memory allocated in this session.
3990 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
3991 Number of bytes of unshared memory remaining available in this session.
3996 DEFVAR_INT ("debug-allocation", &debug_allocation /*
3997 If non-zero, print out information to stderr about all objects allocated.
3998 See also `debug-allocation-backtrace-length'.
4000 debug_allocation = 0;
4002 DEFVAR_INT ("debug-allocation-backtrace-length",
4003 &debug_allocation_backtrace_length /*
4004 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4006 debug_allocation_backtrace_length = 2;
4009 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4010 Non-nil means loading Lisp code in order to dump an executable.
4011 This means that certain objects should be allocated in readonly space.
4014 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4015 Function or functions to be run just before each garbage collection.
4016 Interrupts, garbage collection, and errors are inhibited while this hook
4017 runs, so be extremely careful in what you add here. In particular, avoid
4018 consing, and do not interact with the user.
4020 Vpre_gc_hook = Qnil;
4022 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4023 Function or functions to be run just after each garbage collection.
4024 Interrupts, garbage collection, and errors are inhibited while this hook
4025 runs, so be extremely careful in what you add here. In particular, avoid
4026 consing, and do not interact with the user.
4028 Vpost_gc_hook = Qnil;
4030 DEFVAR_LISP ("gc-message", &Vgc_message /*
4031 String to print to indicate that a garbage collection is in progress.
4032 This is printed in the echo area. If the selected frame is on a
4033 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4034 image instance) in the domain of the selected frame, the mouse pointer
4035 will change instead of this message being printed.
4037 Vgc_message = make_string_nocopy ((CONST Bufbyte *) gc_default_message,
4038 countof (gc_default_message) - 1);
4040 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4041 Pointer glyph used to indicate that a garbage collection is in progress.
4042 If the selected window is on a window system and this glyph specifies a
4043 value (i.e. a pointer image instance) in the domain of the selected
4044 window, the pointer will be changed as specified during garbage collection.
4045 Otherwise, a message will be printed in the echo area, as controlled
4051 complex_vars_of_alloc (void)
4053 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);