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"
63 #ifdef DOUG_LEA_MALLOC
67 EXFUN (Fgarbage_collect, 0);
69 /* Return the true size of a struct with a variable-length array field. */
70 #define STRETCHY_STRUCT_SIZEOF(stretchy_struct_type, \
71 stretchy_array_field, \
72 stretchy_array_length) \
73 (offsetof (stretchy_struct_type, stretchy_array_field) + \
74 (offsetof (stretchy_struct_type, stretchy_array_field[1]) - \
75 offsetof (stretchy_struct_type, stretchy_array_field[0])) * \
76 (stretchy_array_length))
78 #if 0 /* this is _way_ too slow to be part of the standard debug options */
79 #if defined(DEBUG_XEMACS) && defined(MULE)
80 #define VERIFY_STRING_CHARS_INTEGRITY
84 /* Define this to use malloc/free with no freelist for all datatypes,
85 the hope being that some debugging tools may help detect
86 freed memory references */
87 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
89 #define ALLOC_NO_POOLS
93 static int debug_allocation;
94 static int debug_allocation_backtrace_length;
97 /* Number of bytes of consing done since the last gc */
98 EMACS_INT consing_since_gc;
99 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
101 #define debug_allocation_backtrace() \
103 if (debug_allocation_backtrace_length > 0) \
104 debug_short_backtrace (debug_allocation_backtrace_length); \
108 #define INCREMENT_CONS_COUNTER(foosize, type) \
110 if (debug_allocation) \
112 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
113 debug_allocation_backtrace (); \
115 INCREMENT_CONS_COUNTER_1 (foosize); \
117 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
119 if (debug_allocation > 1) \
121 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
122 debug_allocation_backtrace (); \
124 INCREMENT_CONS_COUNTER_1 (foosize); \
127 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
128 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
129 INCREMENT_CONS_COUNTER_1 (size)
132 #define DECREMENT_CONS_COUNTER(size) do { \
133 consing_since_gc -= (size); \
134 if (consing_since_gc < 0) \
135 consing_since_gc = 0; \
138 /* Number of bytes of consing since gc before another gc should be done. */
139 EMACS_INT gc_cons_threshold;
141 /* Nonzero during gc */
144 /* Number of times GC has happened at this level or below.
145 * Level 0 is most volatile, contrary to usual convention.
146 * (Of course, there's only one level at present) */
147 EMACS_INT gc_generation_number[1];
149 /* This is just for use by the printer, to allow things to print uniquely */
150 static int lrecord_uid_counter;
152 /* Nonzero when calling certain hooks or doing other things where
154 int gc_currently_forbidden;
157 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
158 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
160 /* "Garbage collecting" */
161 Lisp_Object Vgc_message;
162 Lisp_Object Vgc_pointer_glyph;
163 static CONST char gc_default_message[] = "Garbage collecting";
164 Lisp_Object Qgarbage_collecting;
166 #ifndef VIRT_ADDR_VARIES
168 #endif /* VIRT_ADDR_VARIES */
169 EMACS_INT malloc_sbrk_used;
171 #ifndef VIRT_ADDR_VARIES
173 #endif /* VIRT_ADDR_VARIES */
174 EMACS_INT malloc_sbrk_unused;
176 /* Non-zero means we're in the process of doing the dump */
179 #ifdef ERROR_CHECK_TYPECHECK
181 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
186 c_readonly (Lisp_Object obj)
188 return POINTER_TYPE_P (XGCTYPE (obj)) && C_READONLY (obj);
192 lisp_readonly (Lisp_Object obj)
194 return POINTER_TYPE_P (XGCTYPE (obj)) && LISP_READONLY (obj);
198 /* Maximum amount of C stack to save when a GC happens. */
200 #ifndef MAX_SAVE_STACK
201 #define MAX_SAVE_STACK 0 /* 16000 */
204 /* Non-zero means ignore malloc warnings. Set during initialization. */
205 int ignore_malloc_warnings;
208 static void *breathing_space;
211 release_breathing_space (void)
215 void *tmp = breathing_space;
221 /* malloc calls this if it finds we are near exhausting storage */
223 malloc_warning (CONST char *str)
225 if (ignore_malloc_warnings)
231 "Killing some buffers may delay running out of memory.\n"
232 "However, certainly by the time you receive the 95%% warning,\n"
233 "you should clean up, kill this Emacs, and start a new one.",
237 /* Called if malloc returns zero */
241 /* Force a GC next time eval is called.
242 It's better to loop garbage-collecting (we might reclaim enough
243 to win) than to loop beeping and barfing "Memory exhausted"
245 consing_since_gc = gc_cons_threshold + 1;
246 release_breathing_space ();
248 /* Flush some histories which might conceivably contain garbalogical
250 if (!NILP (Fboundp (Qvalues)))
251 Fset (Qvalues, Qnil);
252 Vcommand_history = Qnil;
254 error ("Memory exhausted");
257 /* like malloc and realloc but check for no memory left, and block input. */
264 xmalloc (size_t size)
266 void *val = malloc (size);
268 if (!val && (size != 0)) memory_full ();
277 xcalloc (size_t nelem, size_t elsize)
279 void *val = calloc (nelem, elsize);
281 if (!val && (nelem != 0)) memory_full ();
286 xmalloc_and_zero (size_t size)
288 return xcalloc (size, sizeof (char));
296 xrealloc (void *block, size_t size)
298 /* We must call malloc explicitly when BLOCK is 0, since some
299 reallocs don't do this. */
300 void *val = block ? realloc (block, size) : malloc (size);
302 if (!val && (size != 0)) memory_full ();
307 #ifdef ERROR_CHECK_MALLOC
308 xfree_1 (void *block)
313 #ifdef ERROR_CHECK_MALLOC
314 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
315 error until much later on for many system mallocs, such as
316 the one that comes with Solaris 2.3. FMH!! */
317 assert (block != (void *) 0xDEADBEEF);
319 #endif /* ERROR_CHECK_MALLOC */
323 #ifdef ERROR_CHECK_GC
326 typedef unsigned int four_byte_t;
327 #elif SIZEOF_LONG == 4
328 typedef unsigned long four_byte_t;
329 #elif SIZEOF_SHORT == 4
330 typedef unsigned short four_byte_t;
332 What kind of strange-ass system are we running on?
336 deadbeef_memory (void *ptr, size_t size)
338 four_byte_t *ptr4 = (four_byte_t *) ptr;
339 size_t beefs = size >> 2;
341 /* In practice, size will always be a multiple of four. */
343 (*ptr4++) = 0xDEADBEEF;
346 #else /* !ERROR_CHECK_GC */
349 #define deadbeef_memory(ptr, size)
351 #endif /* !ERROR_CHECK_GC */
358 xstrdup (CONST char *str)
360 int len = strlen (str) + 1; /* for stupid terminating 0 */
362 void *val = xmalloc (len);
363 if (val == 0) return 0;
364 memcpy (val, str, len);
370 strdup (CONST char *s)
374 #endif /* NEED_STRDUP */
378 allocate_lisp_storage (size_t size)
380 void *p = xmalloc (size);
385 /* lrecords are chained together through their "next.v" field.
386 * After doing the mark phase, the GC will walk this linked
387 * list and free any record which hasn't been marked.
389 static struct lcrecord_header *all_lcrecords;
392 alloc_lcrecord (size_t size, CONST struct lrecord_implementation *implementation)
394 struct lcrecord_header *lcheader;
396 #ifdef ERROR_CHECK_GC
397 if (implementation->static_size == 0)
398 assert (implementation->size_in_bytes_method);
400 assert (implementation->static_size == size);
403 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
404 set_lheader_implementation (&(lcheader->lheader), implementation);
405 lcheader->next = all_lcrecords;
406 #if 1 /* mly prefers to see small ID numbers */
407 lcheader->uid = lrecord_uid_counter++;
408 #else /* jwz prefers to see real addrs */
409 lcheader->uid = (int) &lcheader;
412 all_lcrecords = lcheader;
413 INCREMENT_CONS_COUNTER (size, implementation->name);
417 #if 0 /* Presently unused */
418 /* Very, very poor man's EGC?
419 * This may be slow and thrash pages all over the place.
420 * Only call it if you really feel you must (and if the
421 * lrecord was fairly recently allocated).
422 * Otherwise, just let the GC do its job -- that's what it's there for
425 free_lcrecord (struct lcrecord_header *lcrecord)
427 if (all_lcrecords == lcrecord)
429 all_lcrecords = lcrecord->next;
433 struct lrecord_header *header = all_lcrecords;
436 struct lrecord_header *next = header->next;
437 if (next == lcrecord)
439 header->next = lrecord->next;
448 if (lrecord->implementation->finalizer)
449 lrecord->implementation->finalizer (lrecord, 0);
457 disksave_object_finalization_1 (void)
459 struct lcrecord_header *header;
461 for (header = all_lcrecords; header; header = header->next)
463 if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
465 ((LHEADER_IMPLEMENTATION(&header->lheader)->finalizer)
471 /* This must not be called -- it just serves as for EQ test
472 * If lheader->implementation->finalizer is this_marks_a_marked_record,
473 * then lrecord has been marked by the GC sweeper
474 * header->implementation is put back to its correct value by
477 this_marks_a_marked_record (void *dummy0, int dummy1)
482 /* Semi-kludge -- lrecord_symbol_value_forward objects get stuck
483 in CONST space and you get SEGV's if you attempt to mark them.
484 This sits in lheader->implementation->marker. */
487 this_one_is_unmarkable (Lisp_Object obj, void (*markobj) (Lisp_Object))
493 /* XGCTYPE for records */
495 gc_record_type_p (Lisp_Object frob, CONST struct lrecord_implementation *type)
497 CONST struct lrecord_implementation *imp;
499 if (XGCTYPE (frob) != Lisp_Type_Record)
502 imp = XRECORD_LHEADER_IMPLEMENTATION (frob);
507 /************************************************************************/
508 /* Debugger support */
509 /************************************************************************/
510 /* Give gdb/dbx enough information to decode Lisp Objects. We make
511 sure certain symbols are always defined, so gdb doesn't complain
512 about expressions in src/gdbinit. See src/gdbinit or src/dbxrc to
513 see how this is used. */
515 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
516 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
518 #ifdef USE_UNION_TYPE
519 unsigned char dbg_USE_UNION_TYPE = 1;
521 unsigned char dbg_USE_UNION_TYPE = 0;
524 unsigned char Lisp_Type_Int = 100;
525 unsigned char Lisp_Type_Cons = 101;
526 unsigned char Lisp_Type_String = 102;
527 unsigned char Lisp_Type_Vector = 103;
528 unsigned char Lisp_Type_Symbol = 104;
531 unsigned char lrecord_char_table_entry;
532 unsigned char lrecord_charset;
534 unsigned char lrecord_coding_system;
538 #ifndef HAVE_TOOLBARS
539 unsigned char lrecord_toolbar_button;
543 unsigned char lrecord_tooltalk_message;
544 unsigned char lrecord_tooltalk_pattern;
547 #ifndef HAVE_DATABASE
548 unsigned char lrecord_database;
551 unsigned char dbg_valbits = VALBITS;
552 unsigned char dbg_gctypebits = GCTYPEBITS;
554 /* Macros turned into functions for ease of debugging.
555 Debuggers don't know about macros! */
556 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
558 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
560 return EQ (obj1, obj2);
564 /************************************************************************/
565 /* Fixed-size type macros */
566 /************************************************************************/
568 /* For fixed-size types that are commonly used, we malloc() large blocks
569 of memory at a time and subdivide them into chunks of the correct
570 size for an object of that type. This is more efficient than
571 malloc()ing each object separately because we save on malloc() time
572 and overhead due to the fewer number of malloc()ed blocks, and
573 also because we don't need any extra pointers within each object
574 to keep them threaded together for GC purposes. For less common
575 (and frequently large-size) types, we use lcrecords, which are
576 malloc()ed individually and chained together through a pointer
577 in the lcrecord header. lcrecords do not need to be fixed-size
578 (i.e. two objects of the same type need not have the same size;
579 however, the size of a particular object cannot vary dynamically).
580 It is also much easier to create a new lcrecord type because no
581 additional code needs to be added to alloc.c. Finally, lcrecords
582 may be more efficient when there are only a small number of them.
584 The types that are stored in these large blocks (or "frob blocks")
585 are cons, float, compiled-function, symbol, marker, extent, event,
588 Note that strings are special in that they are actually stored in
589 two parts: a structure containing information about the string, and
590 the actual data associated with the string. The former structure
591 (a struct Lisp_String) is a fixed-size structure and is managed the
592 same way as all the other such types. This structure contains a
593 pointer to the actual string data, which is stored in structures of
594 type struct string_chars_block. Each string_chars_block consists
595 of a pointer to a struct Lisp_String, followed by the data for that
596 string, followed by another pointer to a struct Lisp_String,
597 followed by the data for that string, etc. At GC time, the data in
598 these blocks is compacted by searching sequentially through all the
599 blocks and compressing out any holes created by unmarked strings.
600 Strings that are more than a certain size (bigger than the size of
601 a string_chars_block, although something like half as big might
602 make more sense) are malloc()ed separately and not stored in
603 string_chars_blocks. Furthermore, no one string stretches across
604 two string_chars_blocks.
606 Vectors are each malloc()ed separately, similar to lcrecords.
608 In the following discussion, we use conses, but it applies equally
609 well to the other fixed-size types.
611 We store cons cells inside of cons_blocks, allocating a new
612 cons_block with malloc() whenever necessary. Cons cells reclaimed
613 by GC are put on a free list to be reallocated before allocating
614 any new cons cells from the latest cons_block. Each cons_block is
615 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
616 the versions in malloc.c and gmalloc.c) really allocates in units
617 of powers of two and uses 4 bytes for its own overhead.
619 What GC actually does is to search through all the cons_blocks,
620 from the most recently allocated to the oldest, and put all
621 cons cells that are not marked (whether or not they're already
622 free) on a cons_free_list. The cons_free_list is a stack, and
623 so the cons cells in the oldest-allocated cons_block end up
624 at the head of the stack and are the first to be reallocated.
625 If any cons_block is entirely free, it is freed with free()
626 and its cons cells removed from the cons_free_list. Because
627 the cons_free_list ends up basically in memory order, we have
628 a high locality of reference (assuming a reasonable turnover
629 of allocating and freeing) and have a reasonable probability
630 of entirely freeing up cons_blocks that have been more recently
631 allocated. This stage is called the "sweep stage" of GC, and
632 is executed after the "mark stage", which involves starting
633 from all places that are known to point to in-use Lisp objects
634 (e.g. the obarray, where are all symbols are stored; the
635 current catches and condition-cases; the backtrace list of
636 currently executing functions; the gcpro list; etc.) and
637 recursively marking all objects that are accessible.
639 At the beginning of the sweep stage, the conses in the cons
640 blocks are in one of three states: in use and marked, in use
641 but not marked, and not in use (already freed). Any conses
642 that are marked have been marked in the mark stage just
643 executed, because as part of the sweep stage we unmark any
644 marked objects. The way we tell whether or not a cons cell
645 is in use is through the FREE_STRUCT_P macro. This basically
646 looks at the first 4 bytes (or however many bytes a pointer
647 fits in) to see if all the bits in those bytes are 1. The
648 resulting value (0xFFFFFFFF) is not a valid pointer and is
649 not a valid Lisp_Object. All current fixed-size types have
650 a pointer or Lisp_Object as their first element with the
651 exception of strings; they have a size value, which can
652 never be less than zero, and so 0xFFFFFFFF is invalid for
653 strings as well. Now assuming that a cons cell is in use,
654 the way we tell whether or not it is marked is to look at
655 the mark bit of its car (each Lisp_Object has one bit
656 reserved as a mark bit, in case it's needed). Note that
657 different types of objects use different fields to indicate
658 whether the object is marked, but the principle is the same.
660 Conses on the free_cons_list are threaded through a pointer
661 stored in the bytes directly after the bytes that are set
662 to 0xFFFFFFFF (we cannot overwrite these because the cons
663 is still in a cons_block and needs to remain marked as
664 not in use for the next time that GC happens). This
665 implies that all fixed-size types must be at least big
666 enough to store two pointers, which is indeed the case
667 for all current fixed-size types.
669 Some types of objects need additional "finalization" done
670 when an object is converted from in use to not in use;
671 this is the purpose of the ADDITIONAL_FREE_type macro.
672 For example, markers need to be removed from the chain
673 of markers that is kept in each buffer. This is because
674 markers in a buffer automatically disappear if the marker
675 is no longer referenced anywhere (the same does not
676 apply to extents, however).
678 WARNING: Things are in an extremely bizarre state when
679 the ADDITIONAL_FREE_type macros are called, so beware!
681 When ERROR_CHECK_GC is defined, we do things differently
682 so as to maximize our chances of catching places where
683 there is insufficient GCPROing. The thing we want to
684 avoid is having an object that we're using but didn't
685 GCPRO get freed by GC and then reallocated while we're
686 in the process of using it -- this will result in something
687 seemingly unrelated getting trashed, and is extremely
688 difficult to track down. If the object gets freed but
689 not reallocated, we can usually catch this because we
690 set all bytes of a freed object to 0xDEADBEEF. (The
691 first four bytes, however, are 0xFFFFFFFF, and the next
692 four are a pointer used to chain freed objects together;
693 we play some tricks with this pointer to make it more
694 bogus, so crashes are more likely to occur right away.)
696 We want freed objects to stay free as long as possible,
697 so instead of doing what we do above, we maintain the
698 free objects in a first-in first-out queue. We also
699 don't recompute the free list each GC, unlike above;
700 this ensures that the queue ordering is preserved.
701 [This means that we are likely to have worse locality
702 of reference, and that we can never free a frob block
703 once it's allocated. (Even if we know that all cells
704 in it are free, there's no easy way to remove all those
705 cells from the free list because the objects on the
706 free list are unlikely to be in memory order.)]
707 Furthermore, we never take objects off the free list
708 unless there's a large number (usually 1000, but
709 varies depending on type) of them already on the list.
710 This way, we ensure that an object that gets freed will
711 remain free for the next 1000 (or whatever) times that
712 an object of that type is allocated.
715 #ifndef MALLOC_OVERHEAD
717 #define MALLOC_OVERHEAD 0
718 #elif defined (rcheck)
719 #define MALLOC_OVERHEAD 20
721 #define MALLOC_OVERHEAD 8
723 #endif /* MALLOC_OVERHEAD */
725 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
726 /* If we released our reserve (due to running out of memory),
727 and we have a fair amount free once again,
728 try to set aside another reserve in case we run out once more.
730 This is called when a relocatable block is freed in ralloc.c. */
731 void refill_memory_reserve (void);
733 refill_memory_reserve ()
735 if (breathing_space == 0)
736 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
740 #ifdef ALLOC_NO_POOLS
741 # define TYPE_ALLOC_SIZE(type, structtype) 1
743 # define TYPE_ALLOC_SIZE(type, structtype) \
744 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
745 / sizeof (structtype))
746 #endif /* ALLOC_NO_POOLS */
748 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
750 struct type##_block \
752 struct type##_block *prev; \
753 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
756 static struct type##_block *current_##type##_block; \
757 static int current_##type##_block_index; \
759 static structtype *type##_free_list; \
760 static structtype *type##_free_list_tail; \
763 init_##type##_alloc (void) \
765 current_##type##_block = 0; \
766 current_##type##_block_index = \
767 countof (current_##type##_block->block); \
768 type##_free_list = 0; \
769 type##_free_list_tail = 0; \
772 static int gc_count_num_##type##_in_use; \
773 static int gc_count_num_##type##_freelist
775 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
776 if (current_##type##_block_index \
777 == countof (current_##type##_block->block)) \
779 struct type##_block *AFTFB_new = (struct type##_block *) \
780 allocate_lisp_storage (sizeof (struct type##_block)); \
781 AFTFB_new->prev = current_##type##_block; \
782 current_##type##_block = AFTFB_new; \
783 current_##type##_block_index = 0; \
786 &(current_##type##_block->block[current_##type##_block_index++]); \
789 /* Allocate an instance of a type that is stored in blocks.
790 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
793 #ifdef ERROR_CHECK_GC
795 /* Note: if you get crashes in this function, suspect incorrect calls
796 to free_cons() and friends. This happened once because the cons
797 cell was not GC-protected and was getting collected before
798 free_cons() was called. */
800 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
803 if (gc_count_num_##type##_freelist > \
804 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
806 result = type##_free_list; \
807 /* Before actually using the chain pointer, we complement all its \
808 bits; see FREE_FIXED_TYPE(). */ \
810 (structtype *) ~(unsigned long) \
811 (* (structtype **) ((char *) result + sizeof (void *))); \
812 gc_count_num_##type##_freelist--; \
815 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
816 MARK_STRUCT_AS_NOT_FREE (result); \
819 #else /* !ERROR_CHECK_GC */
821 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
824 if (type##_free_list) \
826 result = type##_free_list; \
828 * (structtype **) ((char *) result + sizeof (void *)); \
831 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
832 MARK_STRUCT_AS_NOT_FREE (result); \
835 #endif /* !ERROR_CHECK_GC */
837 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
840 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
841 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
844 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
847 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
848 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
851 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
852 to a Lisp object and invalid as an actual Lisp_Object value. We have
853 to make sure that this value cannot be an integer in Lisp_Object form.
854 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
855 On a 32-bit system, the type bits will be non-zero, making the value
856 be a pointer, and the pointer will be misaligned.
858 Even if Emacs is run on some weirdo system that allows and allocates
859 byte-aligned pointers, this pointer is at the very top of the address
860 space and so it's almost inconceivable that it could ever be valid. */
863 # define INVALID_POINTER_VALUE 0xFFFFFFFF
865 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
867 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
869 You have some weird system and need to supply a reasonable value here.
872 #define FREE_STRUCT_P(ptr) \
873 (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
874 #define MARK_STRUCT_AS_FREE(ptr) \
875 (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
876 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
877 (* (void **) ptr = 0)
879 #ifdef ERROR_CHECK_GC
881 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
882 do { if (type##_free_list_tail) \
884 /* When we store the chain pointer, we complement all \
885 its bits; this should significantly increase its \
886 bogosity in case someone tries to use the value, and \
887 should make us dump faster if someone stores something \
888 over the pointer because when it gets un-complemented in \
889 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
890 extremely bogus. */ \
892 ((char *) type##_free_list_tail + sizeof (void *)) = \
893 (structtype *) ~(unsigned long) ptr; \
896 type##_free_list = ptr; \
897 type##_free_list_tail = ptr; \
900 #else /* !ERROR_CHECK_GC */
902 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
903 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
905 type##_free_list = (ptr); \
908 #endif /* !ERROR_CHECK_GC */
910 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
912 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
913 structtype *FFT_ptr = (ptr); \
914 ADDITIONAL_FREE_##type (FFT_ptr); \
915 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
916 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
917 MARK_STRUCT_AS_FREE (FFT_ptr); \
920 /* Like FREE_FIXED_TYPE() but used when we are explicitly
921 freeing a structure through free_cons(), free_marker(), etc.
922 rather than through the normal process of sweeping.
923 We attempt to undo the changes made to the allocation counters
924 as a result of this structure being allocated. This is not
925 completely necessary but helps keep things saner: e.g. this way,
926 repeatedly allocating and freeing a cons will not result in
927 the consing-since-gc counter advancing, which would cause a GC
928 and somewhat defeat the purpose of explicitly freeing. */
930 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
931 do { FREE_FIXED_TYPE (type, structtype, ptr); \
932 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
933 gc_count_num_##type##_freelist++; \
938 /************************************************************************/
939 /* Cons allocation */
940 /************************************************************************/
942 DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons);
943 /* conses are used and freed so often that we set this really high */
944 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
945 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
948 mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object))
950 if (GC_NILP (XCDR (obj)))
953 markobj (XCAR (obj));
958 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
960 while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1))
964 if (! CONSP (ob1) || ! CONSP (ob2))
965 return internal_equal (ob1, ob2, depth + 1);
970 static const struct lrecord_description cons_description[] = {
971 { XD_LISP_OBJECT, offsetof(struct Lisp_Cons, car), 2 },
975 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
976 mark_cons, print_cons, 0,
979 * No `hash' method needed.
980 * internal_hash knows how to
987 DEFUN ("cons", Fcons, 2, 2, 0, /*
988 Create a new cons, give it CAR and CDR as components, and return it.
992 /* This cannot GC. */
996 ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
997 set_lheader_implementation (&(c->lheader), &lrecord_cons);
1004 /* This is identical to Fcons() but it used for conses that we're
1005 going to free later, and is useful when trying to track down
1008 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
1011 struct Lisp_Cons *c;
1013 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1014 set_lheader_implementation (&(c->lheader), &lrecord_cons);
1021 DEFUN ("list", Flist, 0, MANY, 0, /*
1022 Return a newly created list with specified arguments as elements.
1023 Any number of arguments, even zero arguments, are allowed.
1025 (int nargs, Lisp_Object *args))
1027 Lisp_Object val = Qnil;
1028 Lisp_Object *argp = args + nargs;
1031 val = Fcons (*--argp, val);
1036 list1 (Lisp_Object obj0)
1038 /* This cannot GC. */
1039 return Fcons (obj0, Qnil);
1043 list2 (Lisp_Object obj0, Lisp_Object obj1)
1045 /* This cannot GC. */
1046 return Fcons (obj0, Fcons (obj1, Qnil));
1050 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1052 /* This cannot GC. */
1053 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1057 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1059 /* This cannot GC. */
1060 return Fcons (obj0, Fcons (obj1, obj2));
1064 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1066 return Fcons (Fcons (key, value), alist);
1070 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1072 /* This cannot GC. */
1073 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1077 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1080 /* This cannot GC. */
1081 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1085 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1086 Lisp_Object obj4, Lisp_Object obj5)
1088 /* This cannot GC. */
1089 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1092 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1093 Return a new list of length LENGTH, with each element being INIT.
1097 CHECK_NATNUM (length);
1100 Lisp_Object val = Qnil;
1101 int size = XINT (length);
1104 val = Fcons (init, val);
1110 /************************************************************************/
1111 /* Float allocation */
1112 /************************************************************************/
1114 #ifdef LISP_FLOAT_TYPE
1116 DECLARE_FIXED_TYPE_ALLOC (float, struct Lisp_Float);
1117 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1120 make_float (double float_value)
1123 struct Lisp_Float *f;
1125 ALLOCATE_FIXED_TYPE (float, struct Lisp_Float, f);
1126 set_lheader_implementation (&(f->lheader), &lrecord_float);
1127 float_data (f) = float_value;
1132 #endif /* LISP_FLOAT_TYPE */
1135 /************************************************************************/
1136 /* Vector allocation */
1137 /************************************************************************/
1140 mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
1142 Lisp_Vector *ptr = XVECTOR (obj);
1143 int len = vector_length (ptr);
1146 for (i = 0; i < len - 1; i++)
1147 markobj (ptr->contents[i]);
1148 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1152 size_vector (CONST void *lheader)
1154 return STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents,
1155 ((Lisp_Vector *) lheader)->size);
1159 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1161 int len = XVECTOR_LENGTH (obj1);
1162 if (len != XVECTOR_LENGTH (obj2))
1166 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1167 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1169 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1175 static const struct lrecord_description vector_description[] = {
1176 { XD_LONG, offsetof(struct Lisp_Vector, size) },
1177 { XD_LISP_OBJECT, offsetof(struct Lisp_Vector, contents), XD_INDIRECT(0) }
1180 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1181 mark_vector, print_vector, 0,
1184 * No `hash' method needed for
1185 * vectors. internal_hash
1186 * knows how to handle vectors.
1190 size_vector, Lisp_Vector);
1192 /* #### should allocate `small' vectors from a frob-block */
1193 static Lisp_Vector *
1194 make_vector_internal (size_t sizei)
1196 /* no vector_next */
1197 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1198 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1205 make_vector (size_t length, Lisp_Object init)
1207 Lisp_Vector *vecp = make_vector_internal (length);
1208 Lisp_Object *p = vector_data (vecp);
1215 XSETVECTOR (vector, vecp);
1220 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1221 Return a new vector of length LENGTH, with each element being INIT.
1222 See also the function `vector'.
1226 CONCHECK_NATNUM (length);
1227 return make_vector (XINT (length), init);
1230 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1231 Return a newly created vector with specified arguments as elements.
1232 Any number of arguments, even zero arguments, are allowed.
1234 (int nargs, Lisp_Object *args))
1236 Lisp_Vector *vecp = make_vector_internal (nargs);
1237 Lisp_Object *p = vector_data (vecp);
1244 XSETVECTOR (vector, vecp);
1250 vector1 (Lisp_Object obj0)
1252 return Fvector (1, &obj0);
1256 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1258 Lisp_Object args[2];
1261 return Fvector (2, args);
1265 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1267 Lisp_Object args[3];
1271 return Fvector (3, args);
1274 #if 0 /* currently unused */
1277 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1280 Lisp_Object args[4];
1285 return Fvector (4, args);
1289 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1290 Lisp_Object obj3, Lisp_Object obj4)
1292 Lisp_Object args[5];
1298 return Fvector (5, args);
1302 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1303 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1305 Lisp_Object args[6];
1312 return Fvector (6, args);
1316 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1317 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1320 Lisp_Object args[7];
1328 return Fvector (7, args);
1332 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1333 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1334 Lisp_Object obj6, Lisp_Object obj7)
1336 Lisp_Object args[8];
1345 return Fvector (8, args);
1349 /************************************************************************/
1350 /* Bit Vector allocation */
1351 /************************************************************************/
1353 static Lisp_Object all_bit_vectors;
1355 /* #### should allocate `small' bit vectors from a frob-block */
1356 static struct Lisp_Bit_Vector *
1357 make_bit_vector_internal (size_t sizei)
1359 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1360 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1361 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1362 set_lheader_implementation (&(p->lheader), &lrecord_bit_vector);
1364 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1366 bit_vector_length (p) = sizei;
1367 bit_vector_next (p) = all_bit_vectors;
1368 /* make sure the extra bits in the last long are 0; the calling
1369 functions might not set them. */
1370 p->bits[num_longs - 1] = 0;
1371 XSETBIT_VECTOR (all_bit_vectors, p);
1376 make_bit_vector (size_t length, Lisp_Object init)
1378 struct Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1379 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1384 memset (p->bits, 0, num_longs * sizeof (long));
1387 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1388 memset (p->bits, ~0, num_longs * sizeof (long));
1389 /* But we have to make sure that the unused bits in the
1390 last long are 0, so that equal/hash is easy. */
1392 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1396 Lisp_Object bit_vector;
1397 XSETBIT_VECTOR (bit_vector, p);
1403 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1406 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1408 for (i = 0; i < length; i++)
1409 set_bit_vector_bit (p, i, bytevec[i]);
1412 Lisp_Object bit_vector;
1413 XSETBIT_VECTOR (bit_vector, p);
1418 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1419 Return a new bit vector of length LENGTH. with each bit being INIT.
1420 Each element is set to INIT. See also the function `bit-vector'.
1424 CONCHECK_NATNUM (length);
1426 return make_bit_vector (XINT (length), init);
1429 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1430 Return a newly created bit vector with specified arguments as elements.
1431 Any number of arguments, even zero arguments, are allowed.
1433 (int nargs, Lisp_Object *args))
1436 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1438 for (i = 0; i < nargs; i++)
1440 CHECK_BIT (args[i]);
1441 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1445 Lisp_Object bit_vector;
1446 XSETBIT_VECTOR (bit_vector, p);
1452 /************************************************************************/
1453 /* Compiled-function allocation */
1454 /************************************************************************/
1456 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1457 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1460 make_compiled_function (void)
1462 Lisp_Compiled_Function *f;
1465 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1466 set_lheader_implementation (&(f->lheader), &lrecord_compiled_function);
1469 f->specpdl_depth = 0;
1470 f->flags.documentationp = 0;
1471 f->flags.interactivep = 0;
1472 f->flags.domainp = 0; /* I18N3 */
1473 f->instructions = Qzero;
1474 f->constants = Qzero;
1476 f->doc_and_interactive = Qnil;
1477 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1478 f->annotated = Qnil;
1480 XSETCOMPILED_FUNCTION (fun, f);
1484 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1485 Return a new compiled-function object.
1486 Usage: (arglist instructions constants stack-depth
1487 &optional doc-string interactive)
1488 Note that, unlike all other emacs-lisp functions, calling this with five
1489 arguments is NOT the same as calling it with six arguments, the last of
1490 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1491 that this function was defined with `(interactive)'. If the arg is not
1492 specified, then that means the function is not interactive.
1493 This is terrible behavior which is retained for compatibility with old
1494 `.elc' files which expect these semantics.
1496 (int nargs, Lisp_Object *args))
1498 /* In a non-insane world this function would have this arglist...
1499 (arglist instructions constants stack_depth &optional doc_string interactive)
1501 Lisp_Object fun = make_compiled_function ();
1502 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1504 Lisp_Object arglist = args[0];
1505 Lisp_Object instructions = args[1];
1506 Lisp_Object constants = args[2];
1507 Lisp_Object stack_depth = args[3];
1508 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1509 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1511 if (nargs < 4 || nargs > 6)
1512 return Fsignal (Qwrong_number_of_arguments,
1513 list2 (intern ("make-byte-code"), make_int (nargs)));
1515 /* Check for valid formal parameter list now, to allow us to use
1516 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1518 Lisp_Object symbol, tail;
1519 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1521 CHECK_SYMBOL (symbol);
1522 if (EQ (symbol, Qt) ||
1523 EQ (symbol, Qnil) ||
1524 SYMBOL_IS_KEYWORD (symbol))
1525 signal_simple_error_2
1526 ("Invalid constant symbol in formal parameter list",
1530 f->arglist = arglist;
1532 /* `instructions' is a string or a cons (string . int) for a
1533 lazy-loaded function. */
1534 if (CONSP (instructions))
1536 CHECK_STRING (XCAR (instructions));
1537 CHECK_INT (XCDR (instructions));
1541 CHECK_STRING (instructions);
1543 f->instructions = instructions;
1545 if (!NILP (constants))
1546 CHECK_VECTOR (constants);
1547 f->constants = constants;
1549 CHECK_NATNUM (stack_depth);
1550 f->stack_depth = XINT (stack_depth);
1552 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1553 if (!NILP (Vcurrent_compiled_function_annotation))
1554 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1555 else if (!NILP (Vload_file_name_internal_the_purecopy))
1556 f->annotated = Vload_file_name_internal_the_purecopy;
1557 else if (!NILP (Vload_file_name_internal))
1559 struct gcpro gcpro1;
1560 GCPRO1 (fun); /* don't let fun get reaped */
1561 Vload_file_name_internal_the_purecopy =
1562 Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
1563 f->annotated = Vload_file_name_internal_the_purecopy;
1566 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1568 /* doc_string may be nil, string, int, or a cons (string . int).
1569 interactive may be list or string (or unbound). */
1570 f->doc_and_interactive = Qunbound;
1572 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1573 f->doc_and_interactive = Vfile_domain;
1575 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1577 f->doc_and_interactive
1578 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1579 Fcons (interactive, f->doc_and_interactive));
1581 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1583 f->doc_and_interactive
1584 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1585 Fcons (doc_string, f->doc_and_interactive));
1587 if (UNBOUNDP (f->doc_and_interactive))
1588 f->doc_and_interactive = Qnil;
1594 /************************************************************************/
1595 /* Symbol allocation */
1596 /************************************************************************/
1598 DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol);
1599 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1601 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1602 Return a newly allocated uninterned symbol whose name is NAME.
1603 Its value and function definition are void, and its property list is nil.
1608 struct Lisp_Symbol *p;
1610 CHECK_STRING (name);
1612 ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p);
1613 set_lheader_implementation (&(p->lheader), &lrecord_symbol);
1614 p->name = XSTRING (name);
1616 p->value = Qunbound;
1617 p->function = Qunbound;
1618 symbol_next (p) = 0;
1619 XSETSYMBOL (val, p);
1624 /************************************************************************/
1625 /* Extent allocation */
1626 /************************************************************************/
1628 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1629 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1632 allocate_extent (void)
1636 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1637 set_lheader_implementation (&(e->lheader), &lrecord_extent);
1638 extent_object (e) = Qnil;
1639 set_extent_start (e, -1);
1640 set_extent_end (e, -1);
1645 extent_face (e) = Qnil;
1646 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1647 e->flags.detachable = 1;
1653 /************************************************************************/
1654 /* Event allocation */
1655 /************************************************************************/
1657 DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event);
1658 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1661 allocate_event (void)
1664 struct Lisp_Event *e;
1666 ALLOCATE_FIXED_TYPE (event, struct Lisp_Event, e);
1667 set_lheader_implementation (&(e->lheader), &lrecord_event);
1674 /************************************************************************/
1675 /* Marker allocation */
1676 /************************************************************************/
1678 DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker);
1679 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1681 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1682 Return a new marker which does not point at any place.
1687 struct Lisp_Marker *p;
1689 ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1690 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1693 marker_next (p) = 0;
1694 marker_prev (p) = 0;
1695 p->insertion_type = 0;
1696 XSETMARKER (val, p);
1701 noseeum_make_marker (void)
1704 struct Lisp_Marker *p;
1706 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1707 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1710 marker_next (p) = 0;
1711 marker_prev (p) = 0;
1712 p->insertion_type = 0;
1713 XSETMARKER (val, p);
1718 /************************************************************************/
1719 /* String allocation */
1720 /************************************************************************/
1722 /* The data for "short" strings generally resides inside of structs of type
1723 string_chars_block. The Lisp_String structure is allocated just like any
1724 other Lisp object (except for vectors), and these are freelisted when
1725 they get garbage collected. The data for short strings get compacted,
1726 but the data for large strings do not.
1728 Previously Lisp_String structures were relocated, but this caused a lot
1729 of bus-errors because the C code didn't include enough GCPRO's for
1730 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1731 that the reference would get relocated).
1733 This new method makes things somewhat bigger, but it is MUCH safer. */
1735 DECLARE_FIXED_TYPE_ALLOC (string, struct Lisp_String);
1736 /* strings are used and freed quite often */
1737 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1738 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1741 mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object))
1743 struct Lisp_String *ptr = XSTRING (obj);
1745 if (GC_CONSP (ptr->plist) && GC_EXTENT_INFOP (XCAR (ptr->plist)))
1746 flush_cached_extent_info (XCAR (ptr->plist));
1751 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1754 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1755 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1758 static const struct lrecord_description string_description[] = {
1759 { XD_STRING_DATA, offsetof(Lisp_String, data) },
1760 { XD_LISP_OBJECT, offsetof(Lisp_String, plist), 1 },
1764 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
1765 mark_string, print_string,
1767 * No `finalize', or `hash' methods.
1768 * internal_hash already knows how
1769 * to hash strings and finalization
1771 * ADDITIONAL_FREE_string macro,
1772 * which is the standard way to do
1773 * finalization when using
1774 * SWEEP_FIXED_TYPE_BLOCK().
1778 struct Lisp_String);
1780 /* String blocks contain this many useful bytes. */
1781 #define STRING_CHARS_BLOCK_SIZE \
1782 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1783 ((2 * sizeof (struct string_chars_block *)) \
1784 + sizeof (EMACS_INT))))
1785 /* Block header for small strings. */
1786 struct string_chars_block
1789 struct string_chars_block *next;
1790 struct string_chars_block *prev;
1791 /* Contents of string_chars_block->string_chars are interleaved
1792 string_chars structures (see below) and the actual string data */
1793 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1796 struct string_chars_block *first_string_chars_block;
1797 struct string_chars_block *current_string_chars_block;
1799 /* If SIZE is the length of a string, this returns how many bytes
1800 * the string occupies in string_chars_block->string_chars
1801 * (including alignment padding).
1803 #define STRING_FULLSIZE(s) \
1804 ALIGN_SIZE (((s) + 1 + sizeof (struct Lisp_String *)),\
1805 ALIGNOF (struct Lisp_String *))
1807 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1808 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1810 #define CHARS_TO_STRING_CHAR(x) \
1811 ((struct string_chars *) \
1812 (((char *) (x)) - (slot_offset (struct string_chars, chars[0]))))
1817 struct Lisp_String *string;
1818 unsigned char chars[1];
1821 struct unused_string_chars
1823 struct Lisp_String *string;
1828 init_string_chars_alloc (void)
1830 first_string_chars_block = xnew (struct string_chars_block);
1831 first_string_chars_block->prev = 0;
1832 first_string_chars_block->next = 0;
1833 first_string_chars_block->pos = 0;
1834 current_string_chars_block = first_string_chars_block;
1837 static struct string_chars *
1838 allocate_string_chars_struct (struct Lisp_String *string_it_goes_with,
1841 struct string_chars *s_chars;
1843 /* Allocate the string's actual data */
1844 if (BIG_STRING_FULLSIZE_P (fullsize))
1846 s_chars = (struct string_chars *) xmalloc (fullsize);
1848 else if (fullsize <=
1849 (countof (current_string_chars_block->string_chars)
1850 - current_string_chars_block->pos))
1852 /* This string can fit in the current string chars block */
1853 s_chars = (struct string_chars *)
1854 (current_string_chars_block->string_chars
1855 + current_string_chars_block->pos);
1856 current_string_chars_block->pos += fullsize;
1860 /* Make a new current string chars block */
1861 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1863 current_string_chars_block->next = new_scb;
1864 new_scb->prev = current_string_chars_block;
1866 current_string_chars_block = new_scb;
1867 new_scb->pos = fullsize;
1868 s_chars = (struct string_chars *)
1869 current_string_chars_block->string_chars;
1872 s_chars->string = string_it_goes_with;
1874 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1880 make_uninit_string (Bytecount length)
1882 struct Lisp_String *s;
1883 struct string_chars *s_chars;
1884 EMACS_INT fullsize = STRING_FULLSIZE (length);
1887 if ((length < 0) || (fullsize <= 0))
1890 /* Allocate the string header */
1891 ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
1892 set_lheader_implementation (&(s->lheader), &lrecord_string);
1894 s_chars = allocate_string_chars_struct (s, fullsize);
1896 set_string_data (s, &(s_chars->chars[0]));
1897 set_string_length (s, length);
1900 set_string_byte (s, length, 0);
1902 XSETSTRING (val, s);
1906 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1907 static void verify_string_chars_integrity (void);
1910 /* Resize the string S so that DELTA bytes can be inserted starting
1911 at POS. If DELTA < 0, it means deletion starting at POS. If
1912 POS < 0, resize the string but don't copy any characters. Use
1913 this if you're planning on completely overwriting the string.
1917 resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta)
1919 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1920 verify_string_chars_integrity ();
1923 #ifdef ERROR_CHECK_BUFPOS
1926 assert (pos <= string_length (s));
1928 assert (pos + (-delta) <= string_length (s));
1933 assert ((-delta) <= string_length (s));
1935 #endif /* ERROR_CHECK_BUFPOS */
1937 if (pos >= 0 && delta < 0)
1938 /* If DELTA < 0, the functions below will delete the characters
1939 before POS. We want to delete characters *after* POS, however,
1940 so convert this to the appropriate form. */
1944 /* simplest case: no size change. */
1948 Bytecount oldfullsize = STRING_FULLSIZE (string_length (s));
1949 Bytecount newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1951 if (oldfullsize == newfullsize)
1953 /* next simplest case; size change but the necessary
1954 allocation size won't change (up or down; code somewhere
1955 depends on there not being any unused allocation space,
1956 modulo any alignment constraints). */
1959 Bufbyte *addroff = pos + string_data (s);
1961 memmove (addroff + delta, addroff,
1962 /* +1 due to zero-termination. */
1963 string_length (s) + 1 - pos);
1966 else if (BIG_STRING_FULLSIZE_P (oldfullsize) &&
1967 BIG_STRING_FULLSIZE_P (newfullsize))
1969 /* next simplest case; the string is big enough to be malloc()ed
1970 itself, so we just realloc.
1972 It's important not to let the string get below the threshold
1973 for making big strings and still remain malloc()ed; if that
1974 were the case, repeated calls to this function on the same
1975 string could result in memory leakage. */
1976 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1980 Bufbyte *addroff = pos + string_data (s);
1982 memmove (addroff + delta, addroff,
1983 /* +1 due to zero-termination. */
1984 string_length (s) + 1 - pos);
1989 /* worst case. We make a new string_chars struct and copy
1990 the string's data into it, inserting/deleting the delta
1991 in the process. The old string data will either get
1992 freed by us (if it was malloc()ed) or will be reclaimed
1993 in the normal course of garbage collection. */
1994 struct string_chars *s_chars =
1995 allocate_string_chars_struct (s, newfullsize);
1996 Bufbyte *new_addr = &(s_chars->chars[0]);
1997 Bufbyte *old_addr = string_data (s);
2000 memcpy (new_addr, old_addr, pos);
2001 memcpy (new_addr + pos + delta, old_addr + pos,
2002 string_length (s) + 1 - pos);
2004 set_string_data (s, new_addr);
2005 if (BIG_STRING_FULLSIZE_P (oldfullsize))
2009 /* We need to mark this chunk of the string_chars_block
2010 as unused so that compact_string_chars() doesn't
2012 struct string_chars *old_s_chars =
2013 (struct string_chars *) ((char *) old_addr -
2014 sizeof (struct Lisp_String *));
2015 /* Sanity check to make sure we aren't hosed by strange
2016 alignment/padding. */
2017 assert (old_s_chars->string == s);
2018 MARK_STRUCT_AS_FREE (old_s_chars);
2019 ((struct unused_string_chars *) old_s_chars)->fullsize =
2024 set_string_length (s, string_length (s) + delta);
2025 /* If pos < 0, the string won't be zero-terminated.
2026 Terminate now just to make sure. */
2027 string_data (s)[string_length (s)] = '\0';
2033 XSETSTRING (string, s);
2034 /* We also have to adjust all of the extent indices after the
2035 place we did the change. We say "pos - 1" because
2036 adjust_extents() is exclusive of the starting position
2038 adjust_extents (string, pos - 1, string_length (s),
2043 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2044 verify_string_chars_integrity ();
2051 set_string_char (struct Lisp_String *s, Charcount i, Emchar c)
2053 Bufbyte newstr[MAX_EMCHAR_LEN];
2054 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2055 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2056 Bytecount newlen = set_charptr_emchar (newstr, c);
2058 if (oldlen != newlen)
2059 resize_string (s, bytoff, newlen - oldlen);
2060 /* Remember, string_data (s) might have changed so we can't cache it. */
2061 memcpy (string_data (s) + bytoff, newstr, newlen);
2066 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2067 Return a new string of length LENGTH, with each character being INIT.
2068 LENGTH must be an integer and INIT must be a character.
2072 CHECK_NATNUM (length);
2073 CHECK_CHAR_COERCE_INT (init);
2075 Bufbyte init_str[MAX_EMCHAR_LEN];
2076 int len = set_charptr_emchar (init_str, XCHAR (init));
2077 Lisp_Object val = make_uninit_string (len * XINT (length));
2080 /* Optimize the single-byte case */
2081 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2085 Bufbyte *ptr = XSTRING_DATA (val);
2087 for (i = XINT (length); i; i--)
2089 Bufbyte *init_ptr = init_str;
2092 case 4: *ptr++ = *init_ptr++;
2093 case 3: *ptr++ = *init_ptr++;
2094 case 2: *ptr++ = *init_ptr++;
2095 case 1: *ptr++ = *init_ptr++;
2103 DEFUN ("string", Fstring, 0, MANY, 0, /*
2104 Concatenate all the argument characters and make the result a string.
2106 (int nargs, Lisp_Object *args))
2108 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2109 Bufbyte *p = storage;
2111 for (; nargs; nargs--, args++)
2113 Lisp_Object lisp_char = *args;
2114 CHECK_CHAR_COERCE_INT (lisp_char);
2115 p += set_charptr_emchar (p, XCHAR (lisp_char));
2117 return make_string (storage, p - storage);
2121 /* Take some raw memory, which MUST already be in internal format,
2122 and package it up into a Lisp string. */
2124 make_string (CONST Bufbyte *contents, Bytecount length)
2128 /* Make sure we find out about bad make_string's when they happen */
2129 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2130 bytecount_to_charcount (contents, length); /* Just for the assertions */
2133 val = make_uninit_string (length);
2134 memcpy (XSTRING_DATA (val), contents, length);
2138 /* Take some raw memory, encoded in some external data format,
2139 and convert it into a Lisp string. */
2141 make_ext_string (CONST Extbyte *contents, EMACS_INT length,
2142 enum external_data_format fmt)
2147 GET_CHARPTR_INT_DATA_ALLOCA (contents, length, fmt, intstr, intlen);
2148 return make_string (intstr, intlen);
2152 build_string (CONST char *str)
2154 /* Some strlen's crash and burn if passed null. */
2155 return make_string ((CONST Bufbyte *) str, (str ? strlen(str) : 0));
2159 build_ext_string (CONST char *str, enum external_data_format fmt)
2161 /* Some strlen's crash and burn if passed null. */
2162 return make_ext_string ((CONST Extbyte *) str, (str ? strlen(str) : 0), fmt);
2166 build_translated_string (CONST char *str)
2168 return build_string (GETTEXT (str));
2172 make_string_nocopy (CONST Bufbyte *contents, Bytecount length)
2174 struct Lisp_String *s;
2177 /* Make sure we find out about bad make_string_nocopy's when they happen */
2178 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2179 bytecount_to_charcount (contents, length); /* Just for the assertions */
2182 /* Allocate the string header */
2183 ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
2184 set_lheader_implementation (&(s->lheader), &lrecord_string);
2185 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2187 set_string_data (s, (Bufbyte *)contents);
2188 set_string_length (s, length);
2190 XSETSTRING (val, s);
2195 /************************************************************************/
2196 /* lcrecord lists */
2197 /************************************************************************/
2199 /* Lcrecord lists are used to manage the allocation of particular
2200 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2201 malloc() and garbage-collection junk) as much as possible.
2202 It is similar to the Blocktype class.
2206 1) Create an lcrecord-list object using make_lcrecord_list().
2207 This is often done at initialization. Remember to staticpro
2208 this object! The arguments to make_lcrecord_list() are the
2209 same as would be passed to alloc_lcrecord().
2210 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2211 and pass the lcrecord-list earlier created.
2212 3) When done with the lcrecord, call free_managed_lcrecord().
2213 The standard freeing caveats apply: ** make sure there are no
2214 pointers to the object anywhere! **
2215 4) Calling free_managed_lcrecord() is just like kissing the
2216 lcrecord goodbye as if it were garbage-collected. This means:
2217 -- the contents of the freed lcrecord are undefined, and the
2218 contents of something produced by allocate_managed_lcrecord()
2219 are undefined, just like for alloc_lcrecord().
2220 -- the mark method for the lcrecord's type will *NEVER* be called
2222 -- the finalize method for the lcrecord's type will be called
2223 at the time that free_managed_lcrecord() is called.
2228 mark_lcrecord_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
2230 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2231 Lisp_Object chain = list->free;
2233 while (!NILP (chain))
2235 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2236 struct free_lcrecord_header *free_header =
2237 (struct free_lcrecord_header *) lheader;
2239 #ifdef ERROR_CHECK_GC
2240 CONST struct lrecord_implementation *implementation
2241 = LHEADER_IMPLEMENTATION(lheader);
2243 /* There should be no other pointers to the free list. */
2244 assert (!MARKED_RECORD_HEADER_P (lheader));
2245 /* Only lcrecords should be here. */
2246 assert (!implementation->basic_p);
2247 /* Only free lcrecords should be here. */
2248 assert (free_header->lcheader.free);
2249 /* The type of the lcrecord must be right. */
2250 assert (implementation == list->implementation);
2251 /* So must the size. */
2252 assert (implementation->static_size == 0
2253 || implementation->static_size == list->size);
2254 #endif /* ERROR_CHECK_GC */
2256 MARK_RECORD_HEADER (lheader);
2257 chain = free_header->chain;
2263 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2264 mark_lcrecord_list, internal_object_printer,
2265 0, 0, 0, 0, struct lcrecord_list);
2267 make_lcrecord_list (size_t size,
2268 CONST struct lrecord_implementation *implementation)
2270 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2271 &lrecord_lcrecord_list);
2274 p->implementation = implementation;
2277 XSETLCRECORD_LIST (val, p);
2282 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2284 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2285 if (!NILP (list->free))
2287 Lisp_Object val = list->free;
2288 struct free_lcrecord_header *free_header =
2289 (struct free_lcrecord_header *) XPNTR (val);
2291 #ifdef ERROR_CHECK_GC
2292 struct lrecord_header *lheader =
2293 (struct lrecord_header *) free_header;
2294 CONST struct lrecord_implementation *implementation
2295 = LHEADER_IMPLEMENTATION (lheader);
2297 /* There should be no other pointers to the free list. */
2298 assert (!MARKED_RECORD_HEADER_P (lheader));
2299 /* Only lcrecords should be here. */
2300 assert (!implementation->basic_p);
2301 /* Only free lcrecords should be here. */
2302 assert (free_header->lcheader.free);
2303 /* The type of the lcrecord must be right. */
2304 assert (implementation == list->implementation);
2305 /* So must the size. */
2306 assert (implementation->static_size == 0
2307 || implementation->static_size == list->size);
2308 #endif /* ERROR_CHECK_GC */
2309 list->free = free_header->chain;
2310 free_header->lcheader.free = 0;
2317 XSETOBJ (val, Lisp_Type_Record,
2318 alloc_lcrecord (list->size, list->implementation));
2324 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2326 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2327 struct free_lcrecord_header *free_header =
2328 (struct free_lcrecord_header *) XPNTR (lcrecord);
2329 struct lrecord_header *lheader =
2330 (struct lrecord_header *) free_header;
2331 CONST struct lrecord_implementation *implementation
2332 = LHEADER_IMPLEMENTATION (lheader);
2334 #ifdef ERROR_CHECK_GC
2335 /* Make sure the size is correct. This will catch, for example,
2336 putting a window configuration on the wrong free list. */
2337 if (implementation->size_in_bytes_method)
2338 assert (implementation->size_in_bytes_method (lheader) == list->size);
2340 assert (implementation->static_size == list->size);
2341 #endif /* ERROR_CHECK_GC */
2343 if (implementation->finalizer)
2344 implementation->finalizer (lheader, 0);
2345 free_header->chain = list->free;
2346 free_header->lcheader.free = 1;
2347 list->free = lcrecord;
2353 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2354 Kept for compatibility, returns its argument.
2356 Make a copy of OBJECT in pure storage.
2357 Recursively copies contents of vectors and cons cells.
2358 Does not copy symbols.
2367 /************************************************************************/
2368 /* Garbage Collection */
2369 /************************************************************************/
2371 /* This will be used more extensively In The Future */
2372 static int last_lrecord_type_index_assigned;
2374 CONST struct lrecord_implementation *lrecord_implementations_table[128];
2375 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
2377 struct gcpro *gcprolist;
2379 /* 415 used Mly 29-Jun-93 */
2380 /* 1327 used slb 28-Feb-98 */
2382 #define NSTATICS 4000
2384 #define NSTATICS 2000
2386 /* Not "static" because of linker lossage on some systems */
2387 Lisp_Object *staticvec[NSTATICS]
2388 /* Force it into data space! */
2390 static int staticidx;
2392 /* Put an entry in staticvec, pointing at the variable whose address is given
2395 staticpro (Lisp_Object *varaddress)
2397 if (staticidx >= countof (staticvec))
2398 /* #### This is now a dubious abort() since this routine may be called */
2399 /* by Lisp attempting to load a DLL. */
2401 staticvec[staticidx++] = varaddress;
2405 /* Mark reference to a Lisp_Object. If the object referred to has not been
2406 seen yet, recursively mark all the references contained in it. */
2409 mark_object (Lisp_Object obj)
2413 #ifdef ERROR_CHECK_GC
2414 assert (! (GC_EQ (obj, Qnull_pointer)));
2416 /* Checks we used to perform */
2417 /* if (EQ (obj, Qnull_pointer)) return; */
2418 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2419 /* if (PURIFIED (XPNTR (obj))) return; */
2421 if (XGCTYPE (obj) == Lisp_Type_Record)
2423 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2424 #if defined (ERROR_CHECK_GC)
2425 assert (lheader->type <= last_lrecord_type_index_assigned);
2427 if (C_READONLY_RECORD_HEADER_P (lheader))
2430 if (! MARKED_RECORD_HEADER_P (lheader) &&
2431 ! UNMARKABLE_RECORD_HEADER_P (lheader))
2433 CONST struct lrecord_implementation *implementation =
2434 LHEADER_IMPLEMENTATION (lheader);
2435 MARK_RECORD_HEADER (lheader);
2436 #ifdef ERROR_CHECK_GC
2437 if (!implementation->basic_p)
2438 assert (! ((struct lcrecord_header *) lheader)->free);
2440 if (implementation->marker)
2442 obj = implementation->marker (obj, mark_object);
2443 if (!GC_NILP (obj)) goto tail_recurse;
2449 /* mark all of the conses in a list and mark the final cdr; but
2450 DO NOT mark the cars.
2452 Use only for internal lists! There should never be other pointers
2453 to the cons cells, because if so, the cars will remain unmarked
2454 even when they maybe should be marked. */
2456 mark_conses_in_list (Lisp_Object obj)
2460 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2462 if (CONS_MARKED_P (XCONS (rest)))
2464 MARK_CONS (XCONS (rest));
2471 /* Find all structures not marked, and free them. */
2473 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2474 static int gc_count_bit_vector_storage;
2475 static int gc_count_num_short_string_in_use;
2476 static int gc_count_string_total_size;
2477 static int gc_count_short_string_total_size;
2479 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2483 lrecord_type_index (CONST struct lrecord_implementation *implementation)
2485 int type_index = *(implementation->lrecord_type_index);
2486 /* Have to do this circuitous validation test because of problems
2487 dumping out initialized variables (ie can't set xxx_type_index to -1
2488 because that would make xxx_type_index read-only in a dumped emacs. */
2489 if (type_index < 0 || type_index > max_lrecord_type
2490 || lrecord_implementations_table[type_index] != implementation)
2492 assert (last_lrecord_type_index_assigned < max_lrecord_type);
2493 type_index = ++last_lrecord_type_index_assigned;
2494 lrecord_implementations_table[type_index] = implementation;
2495 *(implementation->lrecord_type_index) = type_index;
2500 /* stats on lcrecords in use - kinda kludgy */
2504 int instances_in_use;
2506 int instances_freed;
2508 int instances_on_free_list;
2509 } lcrecord_stats [countof (lrecord_implementations_table)];
2512 tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p)
2514 CONST struct lrecord_implementation *implementation =
2515 LHEADER_IMPLEMENTATION (h);
2516 int type_index = lrecord_type_index (implementation);
2518 if (((struct lcrecord_header *) h)->free)
2521 lcrecord_stats[type_index].instances_on_free_list++;
2525 size_t sz = (implementation->size_in_bytes_method
2526 ? implementation->size_in_bytes_method (h)
2527 : implementation->static_size);
2531 lcrecord_stats[type_index].instances_freed++;
2532 lcrecord_stats[type_index].bytes_freed += sz;
2536 lcrecord_stats[type_index].instances_in_use++;
2537 lcrecord_stats[type_index].bytes_in_use += sz;
2543 /* Free all unmarked records */
2545 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2547 struct lcrecord_header *header;
2549 /* int total_size = 0; */
2551 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2553 /* First go through and call all the finalize methods.
2554 Then go through and free the objects. There used to
2555 be only one loop here, with the call to the finalizer
2556 occurring directly before the xfree() below. That
2557 is marginally faster but much less safe -- if the
2558 finalize method for an object needs to reference any
2559 other objects contained within it (and many do),
2560 we could easily be screwed by having already freed that
2563 for (header = *prev; header; header = header->next)
2565 struct lrecord_header *h = &(header->lheader);
2566 if (!C_READONLY_RECORD_HEADER_P(h)
2567 && !MARKED_RECORD_HEADER_P (h)
2568 && ! (header->free))
2570 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2571 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2575 for (header = *prev; header; )
2577 struct lrecord_header *h = &(header->lheader);
2578 if (C_READONLY_RECORD_HEADER_P(h) || MARKED_RECORD_HEADER_P (h))
2580 if (MARKED_RECORD_HEADER_P (h))
2581 UNMARK_RECORD_HEADER (h);
2583 /* total_size += n->implementation->size_in_bytes (h);*/
2584 /* ### May modify header->next on a C_READONLY lcrecord */
2585 prev = &(header->next);
2587 tick_lcrecord_stats (h, 0);
2591 struct lcrecord_header *next = header->next;
2593 tick_lcrecord_stats (h, 1);
2594 /* used to call finalizer right here. */
2600 /* *total = total_size; */
2605 sweep_bit_vectors_1 (Lisp_Object *prev,
2606 int *used, int *total, int *storage)
2608 Lisp_Object bit_vector;
2611 int total_storage = 0;
2613 /* BIT_VECTORP fails because the objects are marked, which changes
2614 their implementation */
2615 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2617 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2619 if (C_READONLY_RECORD_HEADER_P(&(v->lheader)) || MARKED_RECORD_P (bit_vector))
2621 if (MARKED_RECORD_P (bit_vector))
2622 UNMARK_RECORD_HEADER (&(v->lheader));
2626 STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2627 BIT_VECTOR_LONG_STORAGE (len));
2629 /* ### May modify next on a C_READONLY bitvector */
2630 prev = &(bit_vector_next (v));
2635 Lisp_Object next = bit_vector_next (v);
2642 *total = total_size;
2643 *storage = total_storage;
2646 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2647 to make macros prettier. */
2649 #ifdef ERROR_CHECK_GC
2651 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2653 struct typename##_block *SFTB_current; \
2654 struct typename##_block **SFTB_prev; \
2656 int num_free = 0, num_used = 0; \
2658 for (SFTB_prev = ¤t_##typename##_block, \
2659 SFTB_current = current_##typename##_block, \
2660 SFTB_limit = current_##typename##_block_index; \
2666 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2668 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2670 if (FREE_STRUCT_P (SFTB_victim)) \
2674 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2678 else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2681 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2686 UNMARK_##typename (SFTB_victim); \
2689 SFTB_prev = &(SFTB_current->prev); \
2690 SFTB_current = SFTB_current->prev; \
2691 SFTB_limit = countof (current_##typename##_block->block); \
2694 gc_count_num_##typename##_in_use = num_used; \
2695 gc_count_num_##typename##_freelist = num_free; \
2698 #else /* !ERROR_CHECK_GC */
2700 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2702 struct typename##_block *SFTB_current; \
2703 struct typename##_block **SFTB_prev; \
2705 int num_free = 0, num_used = 0; \
2707 typename##_free_list = 0; \
2709 for (SFTB_prev = ¤t_##typename##_block, \
2710 SFTB_current = current_##typename##_block, \
2711 SFTB_limit = current_##typename##_block_index; \
2716 int SFTB_empty = 1; \
2717 obj_type *SFTB_old_free_list = typename##_free_list; \
2719 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2721 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2723 if (FREE_STRUCT_P (SFTB_victim)) \
2726 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2728 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2733 else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2736 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2742 UNMARK_##typename (SFTB_victim); \
2747 SFTB_prev = &(SFTB_current->prev); \
2748 SFTB_current = SFTB_current->prev; \
2750 else if (SFTB_current == current_##typename##_block \
2751 && !SFTB_current->prev) \
2753 /* No real point in freeing sole allocation block */ \
2758 struct typename##_block *SFTB_victim_block = SFTB_current; \
2759 if (SFTB_victim_block == current_##typename##_block) \
2760 current_##typename##_block_index \
2761 = countof (current_##typename##_block->block); \
2762 SFTB_current = SFTB_current->prev; \
2764 *SFTB_prev = SFTB_current; \
2765 xfree (SFTB_victim_block); \
2766 /* Restore free list to what it was before victim was swept */ \
2767 typename##_free_list = SFTB_old_free_list; \
2768 num_free -= SFTB_limit; \
2771 SFTB_limit = countof (current_##typename##_block->block); \
2774 gc_count_num_##typename##_in_use = num_used; \
2775 gc_count_num_##typename##_freelist = num_free; \
2778 #endif /* !ERROR_CHECK_GC */
2786 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2787 #define ADDITIONAL_FREE_cons(ptr)
2789 SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons);
2792 /* Explicitly free a cons cell. */
2794 free_cons (struct Lisp_Cons *ptr)
2796 #ifdef ERROR_CHECK_GC
2797 /* If the CAR is not an int, then it will be a pointer, which will
2798 always be four-byte aligned. If this cons cell has already been
2799 placed on the free list, however, its car will probably contain
2800 a chain pointer to the next cons on the list, which has cleverly
2801 had all its 0's and 1's inverted. This allows for a quick
2802 check to make sure we're not freeing something already freed. */
2803 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2804 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2805 #endif /* ERROR_CHECK_GC */
2807 #ifndef ALLOC_NO_POOLS
2808 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, struct Lisp_Cons, ptr);
2809 #endif /* ALLOC_NO_POOLS */
2812 /* explicitly free a list. You **must make sure** that you have
2813 created all the cons cells that make up this list and that there
2814 are no pointers to any of these cons cells anywhere else. If there
2815 are, you will lose. */
2818 free_list (Lisp_Object list)
2820 Lisp_Object rest, next;
2822 for (rest = list; !NILP (rest); rest = next)
2825 free_cons (XCONS (rest));
2829 /* explicitly free an alist. You **must make sure** that you have
2830 created all the cons cells that make up this alist and that there
2831 are no pointers to any of these cons cells anywhere else. If there
2832 are, you will lose. */
2835 free_alist (Lisp_Object alist)
2837 Lisp_Object rest, next;
2839 for (rest = alist; !NILP (rest); rest = next)
2842 free_cons (XCONS (XCAR (rest)));
2843 free_cons (XCONS (rest));
2848 sweep_compiled_functions (void)
2850 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2851 #define ADDITIONAL_FREE_compiled_function(ptr)
2853 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2857 #ifdef LISP_FLOAT_TYPE
2861 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2862 #define ADDITIONAL_FREE_float(ptr)
2864 SWEEP_FIXED_TYPE_BLOCK (float, struct Lisp_Float);
2866 #endif /* LISP_FLOAT_TYPE */
2869 sweep_symbols (void)
2871 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2872 #define ADDITIONAL_FREE_symbol(ptr)
2874 SWEEP_FIXED_TYPE_BLOCK (symbol, struct Lisp_Symbol);
2878 sweep_extents (void)
2880 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2881 #define ADDITIONAL_FREE_extent(ptr)
2883 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2889 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2890 #define ADDITIONAL_FREE_event(ptr)
2892 SWEEP_FIXED_TYPE_BLOCK (event, struct Lisp_Event);
2896 sweep_markers (void)
2898 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2899 #define ADDITIONAL_FREE_marker(ptr) \
2900 do { Lisp_Object tem; \
2901 XSETMARKER (tem, ptr); \
2902 unchain_marker (tem); \
2905 SWEEP_FIXED_TYPE_BLOCK (marker, struct Lisp_Marker);
2908 /* Explicitly free a marker. */
2910 free_marker (struct Lisp_Marker *ptr)
2912 #ifdef ERROR_CHECK_GC
2913 /* Perhaps this will catch freeing an already-freed marker. */
2915 XSETMARKER (temmy, ptr);
2916 assert (GC_MARKERP (temmy));
2917 #endif /* ERROR_CHECK_GC */
2919 #ifndef ALLOC_NO_POOLS
2920 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr);
2921 #endif /* ALLOC_NO_POOLS */
2925 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2928 verify_string_chars_integrity (void)
2930 struct string_chars_block *sb;
2932 /* Scan each existing string block sequentially, string by string. */
2933 for (sb = first_string_chars_block; sb; sb = sb->next)
2936 /* POS is the index of the next string in the block. */
2937 while (pos < sb->pos)
2939 struct string_chars *s_chars =
2940 (struct string_chars *) &(sb->string_chars[pos]);
2941 struct Lisp_String *string;
2945 /* If the string_chars struct is marked as free (i.e. the STRING
2946 pointer is 0xFFFFFFFF) then this is an unused chunk of string
2947 storage. (See below.) */
2949 if (FREE_STRUCT_P (s_chars))
2951 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
2956 string = s_chars->string;
2957 /* Must be 32-bit aligned. */
2958 assert ((((int) string) & 3) == 0);
2960 size = string_length (string);
2961 fullsize = STRING_FULLSIZE (size);
2963 assert (!BIG_STRING_FULLSIZE_P (fullsize));
2964 assert (string_data (string) == s_chars->chars);
2967 assert (pos == sb->pos);
2971 #endif /* MULE && ERROR_CHECK_GC */
2973 /* Compactify string chars, relocating the reference to each --
2974 free any empty string_chars_block we see. */
2976 compact_string_chars (void)
2978 struct string_chars_block *to_sb = first_string_chars_block;
2980 struct string_chars_block *from_sb;
2982 /* Scan each existing string block sequentially, string by string. */
2983 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
2986 /* FROM_POS is the index of the next string in the block. */
2987 while (from_pos < from_sb->pos)
2989 struct string_chars *from_s_chars =
2990 (struct string_chars *) &(from_sb->string_chars[from_pos]);
2991 struct string_chars *to_s_chars;
2992 struct Lisp_String *string;
2996 /* If the string_chars struct is marked as free (i.e. the STRING
2997 pointer is 0xFFFFFFFF) then this is an unused chunk of string
2998 storage. This happens under Mule when a string's size changes
2999 in such a way that its fullsize changes. (Strings can change
3000 size because a different-length character can be substituted
3001 for another character.) In this case, after the bogus string
3002 pointer is the "fullsize" of this entry, i.e. how many bytes
3005 if (FREE_STRUCT_P (from_s_chars))
3007 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3008 from_pos += fullsize;
3012 string = from_s_chars->string;
3013 assert (!(FREE_STRUCT_P (string)));
3015 size = string_length (string);
3016 fullsize = STRING_FULLSIZE (size);
3018 if (BIG_STRING_FULLSIZE_P (fullsize))
3021 /* Just skip it if it isn't marked. */
3022 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3024 from_pos += fullsize;
3028 /* If it won't fit in what's left of TO_SB, close TO_SB out
3029 and go on to the next string_chars_block. We know that TO_SB
3030 cannot advance past FROM_SB here since FROM_SB is large enough
3031 to currently contain this string. */
3032 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3034 to_sb->pos = to_pos;
3035 to_sb = to_sb->next;
3039 /* Compute new address of this string
3040 and update TO_POS for the space being used. */
3041 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3043 /* Copy the string_chars to the new place. */
3044 if (from_s_chars != to_s_chars)
3045 memmove (to_s_chars, from_s_chars, fullsize);
3047 /* Relocate FROM_S_CHARS's reference */
3048 set_string_data (string, &(to_s_chars->chars[0]));
3050 from_pos += fullsize;
3055 /* Set current to the last string chars block still used and
3056 free any that follow. */
3058 struct string_chars_block *victim;
3060 for (victim = to_sb->next; victim; )
3062 struct string_chars_block *next = victim->next;
3067 current_string_chars_block = to_sb;
3068 current_string_chars_block->pos = to_pos;
3069 current_string_chars_block->next = 0;
3073 #if 1 /* Hack to debug missing purecopy's */
3074 static int debug_string_purity;
3077 debug_string_purity_print (struct Lisp_String *p)
3080 Charcount s = string_char_length (p);
3081 putc ('\"', stderr);
3082 for (i = 0; i < s; i++)
3084 Emchar ch = string_char (p, i);
3085 if (ch < 32 || ch >= 126)
3086 stderr_out ("\\%03o", ch);
3087 else if (ch == '\\' || ch == '\"')
3088 stderr_out ("\\%c", ch);
3090 stderr_out ("%c", ch);
3092 stderr_out ("\"\n");
3098 sweep_strings (void)
3100 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3101 int debug = debug_string_purity;
3103 #define UNMARK_string(ptr) \
3104 do { struct Lisp_String *p = (ptr); \
3105 int size = string_length (p); \
3106 UNMARK_RECORD_HEADER (&(p->lheader)); \
3107 num_bytes += size; \
3108 if (!BIG_STRING_SIZE_P (size)) \
3109 { num_small_bytes += size; \
3112 if (debug) debug_string_purity_print (p); \
3114 #define ADDITIONAL_FREE_string(p) \
3115 do { int size = string_length (p); \
3116 if (BIG_STRING_SIZE_P (size)) \
3117 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
3120 SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String);
3122 gc_count_num_short_string_in_use = num_small_used;
3123 gc_count_string_total_size = num_bytes;
3124 gc_count_short_string_total_size = num_small_bytes;
3128 /* I hate duplicating all this crap! */
3130 marked_p (Lisp_Object obj)
3132 #ifdef ERROR_CHECK_GC
3133 assert (! (GC_EQ (obj, Qnull_pointer)));
3135 /* Checks we used to perform. */
3136 /* if (EQ (obj, Qnull_pointer)) return 1; */
3137 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3138 /* if (PURIFIED (XPNTR (obj))) return 1; */
3140 if (XGCTYPE (obj) == Lisp_Type_Record)
3142 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3143 #if defined (ERROR_CHECK_GC)
3144 assert (lheader->type <= last_lrecord_type_index_assigned);
3146 return C_READONLY_RECORD_HEADER_P (lheader) || MARKED_RECORD_HEADER_P (lheader);
3154 /* Free all unmarked records. Do this at the very beginning,
3155 before anything else, so that the finalize methods can safely
3156 examine items in the objects. sweep_lcrecords_1() makes
3157 sure to call all the finalize methods *before* freeing anything,
3158 to complete the safety. */
3161 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3164 compact_string_chars ();
3166 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3167 macros) must be *extremely* careful to make sure they're not
3168 referencing freed objects. The only two existing finalize
3169 methods (for strings and markers) pass muster -- the string
3170 finalizer doesn't look at anything but its own specially-
3171 created block, and the marker finalizer only looks at live
3172 buffers (which will never be freed) and at the markers before
3173 and after it in the chain (which, by induction, will never be
3174 freed because if so, they would have already removed themselves
3177 /* Put all unmarked strings on free list, free'ing the string chars
3178 of large unmarked strings */
3181 /* Put all unmarked conses on free list */
3184 /* Free all unmarked bit vectors */
3185 sweep_bit_vectors_1 (&all_bit_vectors,
3186 &gc_count_num_bit_vector_used,
3187 &gc_count_bit_vector_total_size,
3188 &gc_count_bit_vector_storage);
3190 /* Free all unmarked compiled-function objects */
3191 sweep_compiled_functions ();
3193 #ifdef LISP_FLOAT_TYPE
3194 /* Put all unmarked floats on free list */
3198 /* Put all unmarked symbols on free list */
3201 /* Put all unmarked extents on free list */
3204 /* Put all unmarked markers on free list.
3205 Dechain each one first from the buffer into which it points. */
3212 /* Clearing for disksave. */
3215 disksave_object_finalization (void)
3217 /* It's important that certain information from the environment not get
3218 dumped with the executable (pathnames, environment variables, etc.).
3219 To make it easier to tell when this has happened with strings(1) we
3220 clear some known-to-be-garbage blocks of memory, so that leftover
3221 results of old evaluation don't look like potential problems.
3222 But first we set some notable variables to nil and do one more GC,
3223 to turn those strings into garbage.
3226 /* Yeah, this list is pretty ad-hoc... */
3227 Vprocess_environment = Qnil;
3228 Vexec_directory = Qnil;
3229 Vdata_directory = Qnil;
3230 Vsite_directory = Qnil;
3231 Vdoc_directory = Qnil;
3232 Vconfigure_info_directory = Qnil;
3235 /* Vdump_load_path = Qnil; */
3236 /* Release hash tables for locate_file */
3237 Flocate_file_clear_hashing (Qt);
3238 uncache_home_directory();
3240 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3241 defined(LOADHIST_BUILTIN))
3242 Vload_history = Qnil;
3244 Vshell_file_name = Qnil;
3246 garbage_collect_1 ();
3248 /* Run the disksave finalization methods of all live objects. */
3249 disksave_object_finalization_1 ();
3251 /* Zero out the uninitialized (really, unused) part of the containers
3252 for the live strings. */
3254 struct string_chars_block *scb;
3255 for (scb = first_string_chars_block; scb; scb = scb->next)
3257 int count = sizeof (scb->string_chars) - scb->pos;
3259 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3261 /* from the block's fill ptr to the end */
3262 memset ((scb->string_chars + scb->pos), 0, count);
3267 /* There, that ought to be enough... */
3273 restore_gc_inhibit (Lisp_Object val)
3275 gc_currently_forbidden = XINT (val);
3279 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3280 static int gc_hooks_inhibited;
3284 garbage_collect_1 (void)
3286 #if MAX_SAVE_STACK > 0
3287 char stack_top_variable;
3288 extern char *stack_bottom;
3293 Lisp_Object pre_gc_cursor;
3294 struct gcpro gcpro1;
3297 || gc_currently_forbidden
3299 || preparing_for_armageddon)
3302 /* We used to call selected_frame() here.
3304 The following functions cannot be called inside GC
3305 so we move to after the above tests. */
3308 Lisp_Object device = Fselected_device (Qnil);
3309 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3311 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3313 signal_simple_error ("No frames exist on device", device);
3317 pre_gc_cursor = Qnil;
3320 GCPRO1 (pre_gc_cursor);
3322 /* Very important to prevent GC during any of the following
3323 stuff that might run Lisp code; otherwise, we'll likely
3324 have infinite GC recursion. */
3325 speccount = specpdl_depth ();
3326 record_unwind_protect (restore_gc_inhibit,
3327 make_int (gc_currently_forbidden));
3328 gc_currently_forbidden = 1;
3330 if (!gc_hooks_inhibited)
3331 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3333 /* Now show the GC cursor/message. */
3334 if (!noninteractive)
3336 if (FRAME_WIN_P (f))
3338 Lisp_Object frame = make_frame (f);
3339 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3340 FRAME_SELECTED_WINDOW (f),
3342 pre_gc_cursor = f->pointer;
3343 if (POINTER_IMAGE_INSTANCEP (cursor)
3344 /* don't change if we don't know how to change back. */
3345 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3348 Fset_frame_pointer (frame, cursor);
3352 /* Don't print messages to the stream device. */
3353 if (!cursor_changed && !FRAME_STREAM_P (f))
3355 char *msg = (STRINGP (Vgc_message)
3356 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3358 Lisp_Object args[2], whole_msg;
3359 args[0] = build_string (msg ? msg :
3360 GETTEXT ((CONST char *) gc_default_message));
3361 args[1] = build_string ("...");
3362 whole_msg = Fconcat (2, args);
3363 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3364 Qgarbage_collecting);
3368 /***** Now we actually start the garbage collection. */
3372 gc_generation_number[0]++;
3374 #if MAX_SAVE_STACK > 0
3376 /* Save a copy of the contents of the stack, for debugging. */
3379 /* Static buffer in which we save a copy of the C stack at each GC. */
3380 static char *stack_copy;
3381 static size_t stack_copy_size;
3383 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3384 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3385 if (stack_size < MAX_SAVE_STACK)
3387 if (stack_copy_size < stack_size)
3389 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3390 stack_copy_size = stack_size;
3394 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3398 #endif /* MAX_SAVE_STACK > 0 */
3400 /* Do some totally ad-hoc resource clearing. */
3401 /* #### generalize this? */
3402 clear_event_resource ();
3403 cleanup_specifiers ();
3405 /* Mark all the special slots that serve as the roots of accessibility. */
3409 for (i = 0; i < staticidx; i++)
3410 mark_object (*(staticvec[i]));
3416 for (tail = gcprolist; tail; tail = tail->next)
3417 for (i = 0; i < tail->nvars; i++)
3418 mark_object (tail->var[i]);
3422 struct specbinding *bind;
3423 for (bind = specpdl; bind != specpdl_ptr; bind++)
3425 mark_object (bind->symbol);
3426 mark_object (bind->old_value);
3431 struct catchtag *catch;
3432 for (catch = catchlist; catch; catch = catch->next)
3434 mark_object (catch->tag);
3435 mark_object (catch->val);
3440 struct backtrace *backlist;
3441 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3443 int nargs = backlist->nargs;
3446 mark_object (*backlist->function);
3447 if (nargs == UNEVALLED || nargs == MANY)
3448 mark_object (backlist->args[0]);
3450 for (i = 0; i < nargs; i++)
3451 mark_object (backlist->args[i]);
3455 mark_redisplay (mark_object);
3456 mark_profiling_info (mark_object);
3458 /* OK, now do the after-mark stuff. This is for things that
3459 are only marked when something else is marked (e.g. weak hash tables).
3460 There may be complex dependencies between such objects -- e.g.
3461 a weak hash table might be unmarked, but after processing a later
3462 weak hash table, the former one might get marked. So we have to
3463 iterate until nothing more gets marked. */
3465 while (finish_marking_weak_hash_tables (marked_p, mark_object) > 0 ||
3466 finish_marking_weak_lists (marked_p, mark_object) > 0)
3469 /* And prune (this needs to be called after everything else has been
3470 marked and before we do any sweeping). */
3471 /* #### this is somewhat ad-hoc and should probably be an object
3473 prune_weak_hash_tables (marked_p);
3474 prune_weak_lists (marked_p);
3475 prune_specifiers (marked_p);
3476 prune_syntax_tables (marked_p);
3480 consing_since_gc = 0;
3481 #ifndef DEBUG_XEMACS
3482 /* Allow you to set it really fucking low if you really want ... */
3483 if (gc_cons_threshold < 10000)
3484 gc_cons_threshold = 10000;
3489 /******* End of garbage collection ********/
3491 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3493 /* Now remove the GC cursor/message */
3494 if (!noninteractive)
3497 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3498 else if (!FRAME_STREAM_P (f))
3500 char *msg = (STRINGP (Vgc_message)
3501 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3504 /* Show "...done" only if the echo area would otherwise be empty. */
3505 if (NILP (clear_echo_area (selected_frame (),
3506 Qgarbage_collecting, 0)))
3508 Lisp_Object args[2], whole_msg;
3509 args[0] = build_string (msg ? msg :
3510 GETTEXT ((CONST char *)
3511 gc_default_message));
3512 args[1] = build_string ("... done");
3513 whole_msg = Fconcat (2, args);
3514 echo_area_message (selected_frame (), (Bufbyte *) 0,
3516 Qgarbage_collecting);
3521 /* now stop inhibiting GC */
3522 unbind_to (speccount, Qnil);
3524 if (!breathing_space)
3526 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3533 /* Debugging aids. */
3536 gc_plist_hack (CONST char *name, int value, Lisp_Object tail)
3538 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3539 or portable numeric datatypes, or bit-vectors, or characters, or
3540 arrays, or exceptions, or ...) */
3541 return cons3 (intern (name), make_int (value), tail);
3544 #define HACK_O_MATIC(type, name, pl) do { \
3546 struct type##_block *x = current_##type##_block; \
3547 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3548 (pl) = gc_plist_hack ((name), s, (pl)); \
3551 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3552 Reclaim storage for Lisp objects no longer needed.
3553 Return info on amount of space in use:
3554 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3555 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3557 where `PLIST' is a list of alternating keyword/value pairs providing
3558 more detailed information.
3559 Garbage collection happens automatically if you cons more than
3560 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3564 Lisp_Object pl = Qnil;
3566 int gc_count_vector_total_size = 0;
3568 garbage_collect_1 ();
3570 for (i = 0; i < last_lrecord_type_index_assigned; i++)
3572 if (lcrecord_stats[i].bytes_in_use != 0
3573 || lcrecord_stats[i].bytes_freed != 0
3574 || lcrecord_stats[i].instances_on_free_list != 0)
3577 CONST char *name = lrecord_implementations_table[i]->name;
3578 int len = strlen (name);
3579 /* save this for the FSFmacs-compatible part of the summary */
3580 if (i == *lrecord_vector.lrecord_type_index)
3581 gc_count_vector_total_size =
3582 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3584 sprintf (buf, "%s-storage", name);
3585 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3586 /* Okay, simple pluralization check for `symbol-value-varalias' */
3587 if (name[len-1] == 's')
3588 sprintf (buf, "%ses-freed", name);
3590 sprintf (buf, "%ss-freed", name);
3591 if (lcrecord_stats[i].instances_freed != 0)
3592 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3593 if (name[len-1] == 's')
3594 sprintf (buf, "%ses-on-free-list", name);
3596 sprintf (buf, "%ss-on-free-list", name);
3597 if (lcrecord_stats[i].instances_on_free_list != 0)
3598 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3600 if (name[len-1] == 's')
3601 sprintf (buf, "%ses-used", name);
3603 sprintf (buf, "%ss-used", name);
3604 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3608 HACK_O_MATIC (extent, "extent-storage", pl);
3609 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3610 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3611 HACK_O_MATIC (event, "event-storage", pl);
3612 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3613 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3614 HACK_O_MATIC (marker, "marker-storage", pl);
3615 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3616 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3617 #ifdef LISP_FLOAT_TYPE
3618 HACK_O_MATIC (float, "float-storage", pl);
3619 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3620 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3621 #endif /* LISP_FLOAT_TYPE */
3622 HACK_O_MATIC (string, "string-header-storage", pl);
3623 pl = gc_plist_hack ("long-strings-total-length",
3624 gc_count_string_total_size
3625 - gc_count_short_string_total_size, pl);
3626 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3627 pl = gc_plist_hack ("short-strings-total-length",
3628 gc_count_short_string_total_size, pl);
3629 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3630 pl = gc_plist_hack ("long-strings-used",
3631 gc_count_num_string_in_use
3632 - gc_count_num_short_string_in_use, pl);
3633 pl = gc_plist_hack ("short-strings-used",
3634 gc_count_num_short_string_in_use, pl);
3636 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3637 pl = gc_plist_hack ("compiled-functions-free",
3638 gc_count_num_compiled_function_freelist, pl);
3639 pl = gc_plist_hack ("compiled-functions-used",
3640 gc_count_num_compiled_function_in_use, pl);
3642 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3643 pl = gc_plist_hack ("bit-vectors-total-length",
3644 gc_count_bit_vector_total_size, pl);
3645 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3647 HACK_O_MATIC (symbol, "symbol-storage", pl);
3648 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3649 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3651 HACK_O_MATIC (cons, "cons-storage", pl);
3652 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3653 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3655 /* The things we do for backwards-compatibility */
3657 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3658 make_int (gc_count_num_cons_freelist)),
3659 Fcons (make_int (gc_count_num_symbol_in_use),
3660 make_int (gc_count_num_symbol_freelist)),
3661 Fcons (make_int (gc_count_num_marker_in_use),
3662 make_int (gc_count_num_marker_freelist)),
3663 make_int (gc_count_string_total_size),
3664 make_int (gc_count_vector_total_size),
3669 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3670 Return the number of bytes consed since the last garbage collection.
3671 \"Consed\" is a misnomer in that this actually counts allocation
3672 of all different kinds of objects, not just conses.
3674 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3678 return make_int (consing_since_gc);
3681 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
3682 Return the address of the last byte Emacs has allocated, divided by 1024.
3683 This may be helpful in debugging Emacs's memory usage.
3684 The value is divided by 1024 to make sure it will fit in a lisp integer.
3688 return make_int ((EMACS_INT) sbrk (0) / 1024);
3694 object_dead_p (Lisp_Object obj)
3696 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3697 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3698 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3699 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3700 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3701 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3702 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3705 #ifdef MEMORY_USAGE_STATS
3707 /* Attempt to determine the actual amount of space that is used for
3708 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3710 It seems that the following holds:
3712 1. When using the old allocator (malloc.c):
3714 -- blocks are always allocated in chunks of powers of two. For
3715 each block, there is an overhead of 8 bytes if rcheck is not
3716 defined, 20 bytes if it is defined. In other words, a
3717 one-byte allocation needs 8 bytes of overhead for a total of
3718 9 bytes, and needs to have 16 bytes of memory chunked out for
3721 2. When using the new allocator (gmalloc.c):
3723 -- blocks are always allocated in chunks of powers of two up
3724 to 4096 bytes. Larger blocks are allocated in chunks of
3725 an integral multiple of 4096 bytes. The minimum block
3726 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3727 is defined. There is no per-block overhead, but there
3728 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3731 3. When using the system malloc, anything goes, but they are
3732 generally slower and more space-efficient than the GNU
3733 allocators. One possibly reasonable assumption to make
3734 for want of better data is that sizeof (void *), or maybe
3735 2 * sizeof (void *), is required as overhead and that
3736 blocks are allocated in the minimum required size except
3737 that some minimum block size is imposed (e.g. 16 bytes). */
3740 malloced_storage_size (void *ptr, size_t claimed_size,
3741 struct overhead_stats *stats)
3743 size_t orig_claimed_size = claimed_size;
3747 if (claimed_size < 2 * sizeof (void *))
3748 claimed_size = 2 * sizeof (void *);
3749 # ifdef SUNOS_LOCALTIME_BUG
3750 if (claimed_size < 16)
3753 if (claimed_size < 4096)
3757 /* compute the log base two, more or less, then use it to compute
3758 the block size needed. */
3760 /* It's big, it's heavy, it's wood! */
3761 while ((claimed_size /= 2) != 0)
3764 /* It's better than bad, it's good! */
3770 /* We have to come up with some average about the amount of
3772 if ((size_t) (rand () & 4095) < claimed_size)
3773 claimed_size += 3 * sizeof (void *);
3777 claimed_size += 4095;
3778 claimed_size &= ~4095;
3779 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3782 #elif defined (SYSTEM_MALLOC)
3784 if (claimed_size < 16)
3786 claimed_size += 2 * sizeof (void *);
3788 #else /* old GNU allocator */
3790 # ifdef rcheck /* #### may not be defined here */
3798 /* compute the log base two, more or less, then use it to compute
3799 the block size needed. */
3801 /* It's big, it's heavy, it's wood! */
3802 while ((claimed_size /= 2) != 0)
3805 /* It's better than bad, it's good! */
3813 #endif /* old GNU allocator */
3817 stats->was_requested += orig_claimed_size;
3818 stats->malloc_overhead += claimed_size - orig_claimed_size;
3820 return claimed_size;
3824 fixed_type_block_overhead (size_t size)
3826 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3827 size_t overhead = 0;
3828 size_t storage_size = malloced_storage_size (0, per_block, 0);
3829 while (size >= per_block)
3832 overhead += sizeof (void *) + per_block - storage_size;
3834 if (rand () % per_block < size)
3835 overhead += sizeof (void *) + per_block - storage_size;
3839 #endif /* MEMORY_USAGE_STATS */
3842 /* Initialization */
3844 init_alloc_once_early (void)
3848 last_lrecord_type_index_assigned = -1;
3849 for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
3851 lrecord_implementations_table[iii] = 0;
3856 * defined subr lrecords were initialized with lheader->type == 0.
3857 * See subr_lheader_initializer in lisp.h. Force type index 0 to be
3858 * assigned to lrecord_subr so that those predefined indexes match
3861 lrecord_type_index (&lrecord_subr);
3862 assert (*(lrecord_subr.lrecord_type_index) == 0);
3864 * The same is true for symbol_value_forward objects, except the
3867 lrecord_type_index (&lrecord_symbol_value_forward);
3868 assert (*(lrecord_symbol_value_forward.lrecord_type_index) == 1);
3870 gc_generation_number[0] = 0;
3871 /* purify_flag 1 is correct even if CANNOT_DUMP.
3872 * loadup.el will set to nil at end. */
3874 breathing_space = 0;
3875 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3876 XSETINT (Vgc_message, 0);
3878 ignore_malloc_warnings = 1;
3879 #ifdef DOUG_LEA_MALLOC
3880 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3881 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3882 #if 0 /* Moved to emacs.c */
3883 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3886 init_string_alloc ();
3887 init_string_chars_alloc ();
3889 init_symbol_alloc ();
3890 init_compiled_function_alloc ();
3891 #ifdef LISP_FLOAT_TYPE
3892 init_float_alloc ();
3893 #endif /* LISP_FLOAT_TYPE */
3894 init_marker_alloc ();
3895 init_extent_alloc ();
3896 init_event_alloc ();
3898 ignore_malloc_warnings = 0;
3900 consing_since_gc = 0;
3902 gc_cons_threshold = 500000; /* XEmacs change */
3904 gc_cons_threshold = 15000; /* debugging */
3906 #ifdef VIRT_ADDR_VARIES
3907 malloc_sbrk_unused = 1<<22; /* A large number */
3908 malloc_sbrk_used = 100000; /* as reasonable as any number */
3909 #endif /* VIRT_ADDR_VARIES */
3910 lrecord_uid_counter = 259;
3911 debug_string_purity = 0;
3914 gc_currently_forbidden = 0;
3915 gc_hooks_inhibited = 0;
3917 #ifdef ERROR_CHECK_TYPECHECK
3918 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3921 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3923 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3925 #endif /* ERROR_CHECK_TYPECHECK */
3928 int pure_bytes_used = 0;
3937 syms_of_alloc (void)
3939 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
3940 defsymbol (&Qpost_gc_hook, "post-gc-hook");
3941 defsymbol (&Qgarbage_collecting, "garbage-collecting");
3946 DEFSUBR (Fbit_vector);
3947 DEFSUBR (Fmake_byte_code);
3948 DEFSUBR (Fmake_list);
3949 DEFSUBR (Fmake_vector);
3950 DEFSUBR (Fmake_bit_vector);
3951 DEFSUBR (Fmake_string);
3953 DEFSUBR (Fmake_symbol);
3954 DEFSUBR (Fmake_marker);
3955 DEFSUBR (Fpurecopy);
3956 DEFSUBR (Fgarbage_collect);
3957 DEFSUBR (Fmemory_limit);
3958 DEFSUBR (Fconsing_since_gc);
3962 vars_of_alloc (void)
3964 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
3965 *Number of bytes of consing between garbage collections.
3966 \"Consing\" is a misnomer in that this actually counts allocation
3967 of all different kinds of objects, not just conses.
3968 Garbage collection can happen automatically once this many bytes have been
3969 allocated since the last garbage collection. All data types count.
3971 Garbage collection happens automatically when `eval' or `funcall' are
3972 called. (Note that `funcall' is called implicitly as part of evaluation.)
3973 By binding this temporarily to a large number, you can effectively
3974 prevent garbage collection during a part of the program.
3976 See also `consing-since-gc'.
3979 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
3980 Number of bytes of sharable Lisp data allocated so far.
3984 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
3985 Number of bytes of unshared memory allocated in this session.
3988 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
3989 Number of bytes of unshared memory remaining available in this session.
3994 DEFVAR_INT ("debug-allocation", &debug_allocation /*
3995 If non-zero, print out information to stderr about all objects allocated.
3996 See also `debug-allocation-backtrace-length'.
3998 debug_allocation = 0;
4000 DEFVAR_INT ("debug-allocation-backtrace-length",
4001 &debug_allocation_backtrace_length /*
4002 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4004 debug_allocation_backtrace_length = 2;
4007 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4008 Non-nil means loading Lisp code in order to dump an executable.
4009 This means that certain objects should be allocated in readonly space.
4012 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4013 Function or functions to be run just before each garbage collection.
4014 Interrupts, garbage collection, and errors are inhibited while this hook
4015 runs, so be extremely careful in what you add here. In particular, avoid
4016 consing, and do not interact with the user.
4018 Vpre_gc_hook = Qnil;
4020 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4021 Function or functions to be run just after each garbage collection.
4022 Interrupts, garbage collection, and errors are inhibited while this hook
4023 runs, so be extremely careful in what you add here. In particular, avoid
4024 consing, and do not interact with the user.
4026 Vpost_gc_hook = Qnil;
4028 DEFVAR_LISP ("gc-message", &Vgc_message /*
4029 String to print to indicate that a garbage collection is in progress.
4030 This is printed in the echo area. If the selected frame is on a
4031 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4032 image instance) in the domain of the selected frame, the mouse pointer
4033 will change instead of this message being printed.
4035 Vgc_message = make_string_nocopy ((CONST Bufbyte *) gc_default_message,
4036 countof (gc_default_message) - 1);
4038 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4039 Pointer glyph used to indicate that a garbage collection is in progress.
4040 If the selected window is on a window system and this glyph specifies a
4041 value (i.e. a pointer image instance) in the domain of the selected
4042 window, the pointer will be changed as specified during garbage collection.
4043 Otherwise, a message will be printed in the echo area, as controlled
4049 complex_vars_of_alloc (void)
4051 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);