1 /* Storage allocation and gc for XEmacs Lisp interpreter.
2 Copyright (C) 1985-1998 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
4 Copyright (C) 1995, 1996 Ben Wing.
6 This file is part of XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from
28 FSF: Original version; a long time ago.
29 Mly: Significantly rewritten to use new 3-bit tags and
30 nicely abstracted object definitions, for 19.8.
31 JWZ: Improved code to keep track of purespace usage and
32 issue nice purespace and GC stats.
33 Ben Wing: Cleaned up frob-block lrecord code, added error-checking
34 and various changes for Mule, for 19.12.
35 Added bit vectors for 19.13.
36 Added lcrecord lists for 19.14.
37 slb: Lots of work on the purification and dump time code.
38 Synched Doug Lea malloc support from Emacs 20.2.
39 og: Killed the purespace. Portable dumper (moved to dumper.c)
46 #include "backtrace.h"
57 #include "redisplay.h"
58 #include "specifier.h"
62 #include "console-stream.h"
64 #ifdef DOUG_LEA_MALLOC
72 EXFUN (Fgarbage_collect, 0);
74 #if 0 /* this is _way_ too slow to be part of the standard debug options */
75 #if defined(DEBUG_XEMACS) && defined(MULE)
76 #define VERIFY_STRING_CHARS_INTEGRITY
80 /* Define this to use malloc/free with no freelist for all datatypes,
81 the hope being that some debugging tools may help detect
82 freed memory references */
83 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
85 #define ALLOC_NO_POOLS
89 static int debug_allocation;
90 static int debug_allocation_backtrace_length;
93 /* Number of bytes of consing done since the last gc */
94 EMACS_INT consing_since_gc;
95 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
97 #define debug_allocation_backtrace() \
99 if (debug_allocation_backtrace_length > 0) \
100 debug_short_backtrace (debug_allocation_backtrace_length); \
104 #define INCREMENT_CONS_COUNTER(foosize, type) \
106 if (debug_allocation) \
108 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
109 debug_allocation_backtrace (); \
111 INCREMENT_CONS_COUNTER_1 (foosize); \
113 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
115 if (debug_allocation > 1) \
117 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
118 debug_allocation_backtrace (); \
120 INCREMENT_CONS_COUNTER_1 (foosize); \
123 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
124 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
125 INCREMENT_CONS_COUNTER_1 (size)
128 #define DECREMENT_CONS_COUNTER(size) do { \
129 consing_since_gc -= (size); \
130 if (consing_since_gc < 0) \
131 consing_since_gc = 0; \
134 /* Number of bytes of consing since gc before another gc should be done. */
135 EMACS_INT gc_cons_threshold;
137 /* Nonzero during gc */
140 /* Number of times GC has happened at this level or below.
141 * Level 0 is most volatile, contrary to usual convention.
142 * (Of course, there's only one level at present) */
143 EMACS_INT gc_generation_number[1];
145 /* This is just for use by the printer, to allow things to print uniquely */
146 static int lrecord_uid_counter;
148 /* Nonzero when calling certain hooks or doing other things where
150 int gc_currently_forbidden;
153 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
154 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
156 /* "Garbage collecting" */
157 Lisp_Object Vgc_message;
158 Lisp_Object Vgc_pointer_glyph;
159 static const char gc_default_message[] = "Garbage collecting";
160 Lisp_Object Qgarbage_collecting;
162 #ifndef VIRT_ADDR_VARIES
164 #endif /* VIRT_ADDR_VARIES */
165 EMACS_INT malloc_sbrk_used;
167 #ifndef VIRT_ADDR_VARIES
169 #endif /* VIRT_ADDR_VARIES */
170 EMACS_INT malloc_sbrk_unused;
172 /* Non-zero means we're in the process of doing the dump */
175 #ifdef ERROR_CHECK_TYPECHECK
177 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
182 c_readonly (Lisp_Object obj)
184 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
188 lisp_readonly (Lisp_Object obj)
190 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
194 /* Maximum amount of C stack to save when a GC happens. */
196 #ifndef MAX_SAVE_STACK
197 #define MAX_SAVE_STACK 0 /* 16000 */
200 /* Non-zero means ignore malloc warnings. Set during initialization. */
201 int ignore_malloc_warnings;
204 static void *breathing_space;
207 release_breathing_space (void)
211 void *tmp = breathing_space;
217 /* malloc calls this if it finds we are near exhausting storage */
219 malloc_warning (const char *str)
221 if (ignore_malloc_warnings)
227 "Killing some buffers may delay running out of memory.\n"
228 "However, certainly by the time you receive the 95%% warning,\n"
229 "you should clean up, kill this Emacs, and start a new one.",
233 /* Called if malloc returns zero */
237 /* Force a GC next time eval is called.
238 It's better to loop garbage-collecting (we might reclaim enough
239 to win) than to loop beeping and barfing "Memory exhausted"
241 consing_since_gc = gc_cons_threshold + 1;
242 release_breathing_space ();
244 /* Flush some histories which might conceivably contain garbalogical
246 if (!NILP (Fboundp (Qvalues)))
247 Fset (Qvalues, Qnil);
248 Vcommand_history = Qnil;
250 error ("Memory exhausted");
253 /* like malloc and realloc but check for no memory left, and block input. */
257 xmalloc (size_t size)
259 void *val = malloc (size);
261 if (!val && (size != 0)) memory_full ();
267 xcalloc (size_t nelem, size_t elsize)
269 void *val = calloc (nelem, elsize);
271 if (!val && (nelem != 0)) memory_full ();
276 xmalloc_and_zero (size_t size)
278 return xcalloc (size, sizeof (char));
283 xrealloc (void *block, size_t size)
285 /* We must call malloc explicitly when BLOCK is 0, since some
286 reallocs don't do this. */
287 void *val = block ? realloc (block, size) : malloc (size);
289 if (!val && (size != 0)) memory_full ();
294 #ifdef ERROR_CHECK_MALLOC
295 xfree_1 (void *block)
300 #ifdef ERROR_CHECK_MALLOC
301 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
302 error until much later on for many system mallocs, such as
303 the one that comes with Solaris 2.3. FMH!! */
304 assert (block != (void *) 0xDEADBEEF);
306 #endif /* ERROR_CHECK_MALLOC */
310 #ifdef ERROR_CHECK_GC
313 typedef unsigned int four_byte_t;
314 #elif SIZEOF_LONG == 4
315 typedef unsigned long four_byte_t;
316 #elif SIZEOF_SHORT == 4
317 typedef unsigned short four_byte_t;
319 What kind of strange-ass system are we running on?
323 deadbeef_memory (void *ptr, size_t size)
325 four_byte_t *ptr4 = (four_byte_t *) ptr;
326 size_t beefs = size >> 2;
328 /* In practice, size will always be a multiple of four. */
330 (*ptr4++) = 0xDEADBEEF;
333 #else /* !ERROR_CHECK_GC */
336 #define deadbeef_memory(ptr, size)
338 #endif /* !ERROR_CHECK_GC */
342 xstrdup (const char *str)
344 int len = strlen (str) + 1; /* for stupid terminating 0 */
346 void *val = xmalloc (len);
347 if (val == 0) return 0;
348 return (char *) memcpy (val, str, len);
353 strdup (const char *s)
357 #endif /* NEED_STRDUP */
361 allocate_lisp_storage (size_t size)
363 return xmalloc (size);
367 /* lcrecords are chained together through their "next" field.
368 After doing the mark phase, GC will walk this linked list
369 and free any lcrecord which hasn't been marked. */
370 static struct lcrecord_header *all_lcrecords;
372 static struct lcrecord_header *all_older_lcrecords;
376 alloc_lcrecord (size_t size, const struct lrecord_implementation *implementation)
378 struct lcrecord_header *lcheader;
381 ((implementation->static_size == 0 ?
382 implementation->size_in_bytes_method != NULL :
383 implementation->static_size == size)
385 (! implementation->basic_p)
387 (! (implementation->hash == NULL && implementation->equal != NULL)));
389 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
390 set_lheader_implementation (&lcheader->lheader, implementation);
391 lcheader->next = all_lcrecords;
392 #if 1 /* mly prefers to see small ID numbers */
393 lcheader->uid = lrecord_uid_counter++;
394 #else /* jwz prefers to see real addrs */
395 lcheader->uid = (int) &lcheader;
398 all_lcrecords = lcheader;
399 INCREMENT_CONS_COUNTER (size, implementation->name);
403 #if 0 /* Presently unused */
404 /* Very, very poor man's EGC?
405 * This may be slow and thrash pages all over the place.
406 * Only call it if you really feel you must (and if the
407 * lrecord was fairly recently allocated).
408 * Otherwise, just let the GC do its job -- that's what it's there for
411 free_lcrecord (struct lcrecord_header *lcrecord)
413 if (all_lcrecords == lcrecord)
415 all_lcrecords = lcrecord->next;
419 struct lrecord_header *header = all_lcrecords;
422 struct lrecord_header *next = header->next;
423 if (next == lcrecord)
425 header->next = lrecord->next;
434 if (lrecord->implementation->finalizer)
435 lrecord->implementation->finalizer (lrecord, 0);
443 disksave_object_finalization_1 (void)
445 struct lcrecord_header *header;
447 for (header = all_lcrecords; header; header = header->next)
449 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
451 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
454 for (header = all_older_lcrecords; header; header = header->next)
456 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
458 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
464 /************************************************************************/
465 /* Debugger support */
466 /************************************************************************/
467 /* Give gdb/dbx enough information to decode Lisp Objects. We make
468 sure certain symbols are always defined, so gdb doesn't complain
469 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
470 to see how this is used. */
472 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
473 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
475 #ifdef USE_UNION_TYPE
476 unsigned char dbg_USE_UNION_TYPE = 1;
478 unsigned char dbg_USE_UNION_TYPE = 0;
481 unsigned char dbg_valbits = VALBITS;
482 unsigned char dbg_gctypebits = GCTYPEBITS;
484 /* Macros turned into functions for ease of debugging.
485 Debuggers don't know about macros! */
486 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
488 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
490 return EQ (obj1, obj2);
494 /************************************************************************/
495 /* Fixed-size type macros */
496 /************************************************************************/
498 /* For fixed-size types that are commonly used, we malloc() large blocks
499 of memory at a time and subdivide them into chunks of the correct
500 size for an object of that type. This is more efficient than
501 malloc()ing each object separately because we save on malloc() time
502 and overhead due to the fewer number of malloc()ed blocks, and
503 also because we don't need any extra pointers within each object
504 to keep them threaded together for GC purposes. For less common
505 (and frequently large-size) types, we use lcrecords, which are
506 malloc()ed individually and chained together through a pointer
507 in the lcrecord header. lcrecords do not need to be fixed-size
508 (i.e. two objects of the same type need not have the same size;
509 however, the size of a particular object cannot vary dynamically).
510 It is also much easier to create a new lcrecord type because no
511 additional code needs to be added to alloc.c. Finally, lcrecords
512 may be more efficient when there are only a small number of them.
514 The types that are stored in these large blocks (or "frob blocks")
515 are cons, float, compiled-function, symbol, marker, extent, event,
518 Note that strings are special in that they are actually stored in
519 two parts: a structure containing information about the string, and
520 the actual data associated with the string. The former structure
521 (a struct Lisp_String) is a fixed-size structure and is managed the
522 same way as all the other such types. This structure contains a
523 pointer to the actual string data, which is stored in structures of
524 type struct string_chars_block. Each string_chars_block consists
525 of a pointer to a struct Lisp_String, followed by the data for that
526 string, followed by another pointer to a Lisp_String, followed by
527 the data for that string, etc. At GC time, the data in these
528 blocks is compacted by searching sequentially through all the
529 blocks and compressing out any holes created by unmarked strings.
530 Strings that are more than a certain size (bigger than the size of
531 a string_chars_block, although something like half as big might
532 make more sense) are malloc()ed separately and not stored in
533 string_chars_blocks. Furthermore, no one string stretches across
534 two string_chars_blocks.
536 Vectors are each malloc()ed separately, similar to lcrecords.
538 In the following discussion, we use conses, but it applies equally
539 well to the other fixed-size types.
541 We store cons cells inside of cons_blocks, allocating a new
542 cons_block with malloc() whenever necessary. Cons cells reclaimed
543 by GC are put on a free list to be reallocated before allocating
544 any new cons cells from the latest cons_block. Each cons_block is
545 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
546 the versions in malloc.c and gmalloc.c) really allocates in units
547 of powers of two and uses 4 bytes for its own overhead.
549 What GC actually does is to search through all the cons_blocks,
550 from the most recently allocated to the oldest, and put all
551 cons cells that are not marked (whether or not they're already
552 free) on a cons_free_list. The cons_free_list is a stack, and
553 so the cons cells in the oldest-allocated cons_block end up
554 at the head of the stack and are the first to be reallocated.
555 If any cons_block is entirely free, it is freed with free()
556 and its cons cells removed from the cons_free_list. Because
557 the cons_free_list ends up basically in memory order, we have
558 a high locality of reference (assuming a reasonable turnover
559 of allocating and freeing) and have a reasonable probability
560 of entirely freeing up cons_blocks that have been more recently
561 allocated. This stage is called the "sweep stage" of GC, and
562 is executed after the "mark stage", which involves starting
563 from all places that are known to point to in-use Lisp objects
564 (e.g. the obarray, where are all symbols are stored; the
565 current catches and condition-cases; the backtrace list of
566 currently executing functions; the gcpro list; etc.) and
567 recursively marking all objects that are accessible.
569 At the beginning of the sweep stage, the conses in the cons
570 blocks are in one of three states: in use and marked, in use
571 but not marked, and not in use (already freed). Any conses
572 that are marked have been marked in the mark stage just
573 executed, because as part of the sweep stage we unmark any
574 marked objects. The way we tell whether or not a cons cell
575 is in use is through the FREE_STRUCT_P macro. This basically
576 looks at the first 4 bytes (or however many bytes a pointer
577 fits in) to see if all the bits in those bytes are 1. The
578 resulting value (0xFFFFFFFF) is not a valid pointer and is
579 not a valid Lisp_Object. All current fixed-size types have
580 a pointer or Lisp_Object as their first element with the
581 exception of strings; they have a size value, which can
582 never be less than zero, and so 0xFFFFFFFF is invalid for
583 strings as well. Now assuming that a cons cell is in use,
584 the way we tell whether or not it is marked is to look at
585 the mark bit of its car (each Lisp_Object has one bit
586 reserved as a mark bit, in case it's needed). Note that
587 different types of objects use different fields to indicate
588 whether the object is marked, but the principle is the same.
590 Conses on the free_cons_list are threaded through a pointer
591 stored in the bytes directly after the bytes that are set
592 to 0xFFFFFFFF (we cannot overwrite these because the cons
593 is still in a cons_block and needs to remain marked as
594 not in use for the next time that GC happens). This
595 implies that all fixed-size types must be at least big
596 enough to store two pointers, which is indeed the case
597 for all current fixed-size types.
599 Some types of objects need additional "finalization" done
600 when an object is converted from in use to not in use;
601 this is the purpose of the ADDITIONAL_FREE_type macro.
602 For example, markers need to be removed from the chain
603 of markers that is kept in each buffer. This is because
604 markers in a buffer automatically disappear if the marker
605 is no longer referenced anywhere (the same does not
606 apply to extents, however).
608 WARNING: Things are in an extremely bizarre state when
609 the ADDITIONAL_FREE_type macros are called, so beware!
611 When ERROR_CHECK_GC is defined, we do things differently
612 so as to maximize our chances of catching places where
613 there is insufficient GCPROing. The thing we want to
614 avoid is having an object that we're using but didn't
615 GCPRO get freed by GC and then reallocated while we're
616 in the process of using it -- this will result in something
617 seemingly unrelated getting trashed, and is extremely
618 difficult to track down. If the object gets freed but
619 not reallocated, we can usually catch this because we
620 set all bytes of a freed object to 0xDEADBEEF. (The
621 first four bytes, however, are 0xFFFFFFFF, and the next
622 four are a pointer used to chain freed objects together;
623 we play some tricks with this pointer to make it more
624 bogus, so crashes are more likely to occur right away.)
626 We want freed objects to stay free as long as possible,
627 so instead of doing what we do above, we maintain the
628 free objects in a first-in first-out queue. We also
629 don't recompute the free list each GC, unlike above;
630 this ensures that the queue ordering is preserved.
631 [This means that we are likely to have worse locality
632 of reference, and that we can never free a frob block
633 once it's allocated. (Even if we know that all cells
634 in it are free, there's no easy way to remove all those
635 cells from the free list because the objects on the
636 free list are unlikely to be in memory order.)]
637 Furthermore, we never take objects off the free list
638 unless there's a large number (usually 1000, but
639 varies depending on type) of them already on the list.
640 This way, we ensure that an object that gets freed will
641 remain free for the next 1000 (or whatever) times that
642 an object of that type is allocated. */
644 #ifndef MALLOC_OVERHEAD
646 #define MALLOC_OVERHEAD 0
647 #elif defined (rcheck)
648 #define MALLOC_OVERHEAD 20
650 #define MALLOC_OVERHEAD 8
652 #endif /* MALLOC_OVERHEAD */
654 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
655 /* If we released our reserve (due to running out of memory),
656 and we have a fair amount free once again,
657 try to set aside another reserve in case we run out once more.
659 This is called when a relocatable block is freed in ralloc.c. */
660 void refill_memory_reserve (void);
662 refill_memory_reserve (void)
664 if (breathing_space == 0)
665 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
669 #ifdef ALLOC_NO_POOLS
670 # define TYPE_ALLOC_SIZE(type, structtype) 1
672 # define TYPE_ALLOC_SIZE(type, structtype) \
673 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
674 / sizeof (structtype))
675 #endif /* ALLOC_NO_POOLS */
677 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
679 struct type##_block \
681 struct type##_block *prev; \
682 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
685 static struct type##_block *current_##type##_block; \
686 static int current_##type##_block_index; \
688 static structtype *type##_free_list; \
689 static structtype *type##_free_list_tail; \
692 init_##type##_alloc (void) \
694 current_##type##_block = 0; \
695 current_##type##_block_index = \
696 countof (current_##type##_block->block); \
697 type##_free_list = 0; \
698 type##_free_list_tail = 0; \
701 static int gc_count_num_##type##_in_use; \
702 static int gc_count_num_##type##_freelist
704 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
705 if (current_##type##_block_index \
706 == countof (current_##type##_block->block)) \
708 struct type##_block *AFTFB_new = (struct type##_block *) \
709 allocate_lisp_storage (sizeof (struct type##_block)); \
710 AFTFB_new->prev = current_##type##_block; \
711 current_##type##_block = AFTFB_new; \
712 current_##type##_block_index = 0; \
715 &(current_##type##_block->block[current_##type##_block_index++]); \
718 /* Allocate an instance of a type that is stored in blocks.
719 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
722 #ifdef ERROR_CHECK_GC
724 /* Note: if you get crashes in this function, suspect incorrect calls
725 to free_cons() and friends. This happened once because the cons
726 cell was not GC-protected and was getting collected before
727 free_cons() was called. */
729 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
732 if (gc_count_num_##type##_freelist > \
733 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
735 result = type##_free_list; \
736 /* Before actually using the chain pointer, we complement all its \
737 bits; see FREE_FIXED_TYPE(). */ \
739 (structtype *) ~(unsigned long) \
740 (* (structtype **) ((char *) result + sizeof (void *))); \
741 gc_count_num_##type##_freelist--; \
744 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
745 MARK_STRUCT_AS_NOT_FREE (result); \
748 #else /* !ERROR_CHECK_GC */
750 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
753 if (type##_free_list) \
755 result = type##_free_list; \
757 * (structtype **) ((char *) result + sizeof (void *)); \
760 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
761 MARK_STRUCT_AS_NOT_FREE (result); \
764 #endif /* !ERROR_CHECK_GC */
766 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
769 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
770 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
773 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
776 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
777 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
780 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
781 to a Lisp object and invalid as an actual Lisp_Object value. We have
782 to make sure that this value cannot be an integer in Lisp_Object form.
783 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
784 On a 32-bit system, the type bits will be non-zero, making the value
785 be a pointer, and the pointer will be misaligned.
787 Even if Emacs is run on some weirdo system that allows and allocates
788 byte-aligned pointers, this pointer is at the very top of the address
789 space and so it's almost inconceivable that it could ever be valid. */
792 # define INVALID_POINTER_VALUE 0xFFFFFFFF
794 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
796 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
798 You have some weird system and need to supply a reasonable value here.
801 /* The construct (* (void **) (ptr)) would cause aliasing problems
802 with modern optimizing compilers like `gcc -O3 -fstrict-aliasing'.
803 But `char *' can legally alias any pointer. Hence this union trick. */
804 typedef union { char c; void *p; } *aliasing_voidpp;
805 #define ALIASING_VOIDPP_DEREFERENCE(ptr) \
806 (((aliasing_voidpp) (ptr))->p)
807 #define FREE_STRUCT_P(ptr) \
808 (ALIASING_VOIDPP_DEREFERENCE (ptr) == (void *) INVALID_POINTER_VALUE)
809 #define MARK_STRUCT_AS_FREE(ptr) \
810 (ALIASING_VOIDPP_DEREFERENCE (ptr) = (void *) INVALID_POINTER_VALUE)
811 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
812 (ALIASING_VOIDPP_DEREFERENCE (ptr) = 0)
814 #ifdef ERROR_CHECK_GC
816 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
817 do { if (type##_free_list_tail) \
819 /* When we store the chain pointer, we complement all \
820 its bits; this should significantly increase its \
821 bogosity in case someone tries to use the value, and \
822 should make us dump faster if someone stores something \
823 over the pointer because when it gets un-complemented in \
824 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
825 extremely bogus. */ \
827 ((char *) type##_free_list_tail + sizeof (void *)) = \
828 (structtype *) ~(unsigned long) ptr; \
831 type##_free_list = ptr; \
832 type##_free_list_tail = ptr; \
835 #else /* !ERROR_CHECK_GC */
837 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
838 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
840 type##_free_list = (ptr); \
843 #endif /* !ERROR_CHECK_GC */
845 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
847 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
848 structtype *FFT_ptr = (ptr); \
849 ADDITIONAL_FREE_##type (FFT_ptr); \
850 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
851 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
852 MARK_STRUCT_AS_FREE (FFT_ptr); \
855 /* Like FREE_FIXED_TYPE() but used when we are explicitly
856 freeing a structure through free_cons(), free_marker(), etc.
857 rather than through the normal process of sweeping.
858 We attempt to undo the changes made to the allocation counters
859 as a result of this structure being allocated. This is not
860 completely necessary but helps keep things saner: e.g. this way,
861 repeatedly allocating and freeing a cons will not result in
862 the consing-since-gc counter advancing, which would cause a GC
863 and somewhat defeat the purpose of explicitly freeing. */
865 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
866 do { FREE_FIXED_TYPE (type, structtype, ptr); \
867 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
868 gc_count_num_##type##_freelist++; \
873 /************************************************************************/
874 /* Cons allocation */
875 /************************************************************************/
877 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
878 /* conses are used and freed so often that we set this really high */
879 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
880 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
883 mark_cons (Lisp_Object obj)
885 if (NILP (XCDR (obj)))
888 mark_object (XCAR (obj));
893 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
896 while (internal_equal (XCAR (ob1), XCAR (ob2), depth))
900 if (! CONSP (ob1) || ! CONSP (ob2))
901 return internal_equal (ob1, ob2, depth);
906 static const struct lrecord_description cons_description[] = {
907 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
908 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
912 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
913 mark_cons, print_cons, 0,
916 * No `hash' method needed.
917 * internal_hash knows how to
924 DEFUN ("cons", Fcons, 2, 2, 0, /*
925 Create a new cons, give it CAR and CDR as components, and return it.
929 /* This cannot GC. */
933 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
934 set_lheader_implementation (&c->lheader, &lrecord_cons);
941 /* This is identical to Fcons() but it used for conses that we're
942 going to free later, and is useful when trying to track down
945 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
950 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
951 set_lheader_implementation (&c->lheader, &lrecord_cons);
958 DEFUN ("list", Flist, 0, MANY, 0, /*
959 Return a newly created list with specified arguments as elements.
960 Any number of arguments, even zero arguments, are allowed.
962 (int nargs, Lisp_Object *args))
964 Lisp_Object val = Qnil;
965 Lisp_Object *argp = args + nargs;
968 val = Fcons (*--argp, val);
973 list1 (Lisp_Object obj0)
975 /* This cannot GC. */
976 return Fcons (obj0, Qnil);
980 list2 (Lisp_Object obj0, Lisp_Object obj1)
982 /* This cannot GC. */
983 return Fcons (obj0, Fcons (obj1, Qnil));
987 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
989 /* This cannot GC. */
990 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
994 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
996 /* This cannot GC. */
997 return Fcons (obj0, Fcons (obj1, obj2));
1001 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1003 return Fcons (Fcons (key, value), alist);
1007 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1009 /* This cannot GC. */
1010 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1014 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1017 /* This cannot GC. */
1018 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1022 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1023 Lisp_Object obj4, Lisp_Object obj5)
1025 /* This cannot GC. */
1026 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1029 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1030 Return a new list of length LENGTH, with each element being INIT.
1034 CHECK_NATNUM (length);
1037 Lisp_Object val = Qnil;
1038 size_t size = XINT (length);
1041 val = Fcons (init, val);
1047 /************************************************************************/
1048 /* Float allocation */
1049 /************************************************************************/
1051 #ifdef LISP_FLOAT_TYPE
1053 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
1054 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1057 make_float (double float_value)
1062 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
1064 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1065 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1068 set_lheader_implementation (&f->lheader, &lrecord_float);
1069 float_data (f) = float_value;
1074 #endif /* LISP_FLOAT_TYPE */
1077 /************************************************************************/
1078 /* Vector allocation */
1079 /************************************************************************/
1082 mark_vector (Lisp_Object obj)
1084 Lisp_Vector *ptr = XVECTOR (obj);
1085 int len = vector_length (ptr);
1088 for (i = 0; i < len - 1; i++)
1089 mark_object (ptr->contents[i]);
1090 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1094 size_vector (const void *lheader)
1096 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, contents,
1097 ((Lisp_Vector *) lheader)->size);
1101 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1103 int len = XVECTOR_LENGTH (obj1);
1104 if (len != XVECTOR_LENGTH (obj2))
1108 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1109 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1111 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1118 vector_hash (Lisp_Object obj, int depth)
1120 return HASH2 (XVECTOR_LENGTH (obj),
1121 internal_array_hash (XVECTOR_DATA (obj),
1122 XVECTOR_LENGTH (obj),
1126 static const struct lrecord_description vector_description[] = {
1127 { XD_LONG, offsetof (Lisp_Vector, size) },
1128 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1132 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1133 mark_vector, print_vector, 0,
1137 size_vector, Lisp_Vector);
1139 /* #### should allocate `small' vectors from a frob-block */
1140 static Lisp_Vector *
1141 make_vector_internal (size_t sizei)
1143 /* no vector_next */
1144 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1145 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1152 make_vector (size_t length, Lisp_Object init)
1154 Lisp_Vector *vecp = make_vector_internal (length);
1155 Lisp_Object *p = vector_data (vecp);
1162 XSETVECTOR (vector, vecp);
1169 make_older_vector (size_t length, Lisp_Object init)
1171 struct lcrecord_header* orig_all_lcrecords = all_lcrecords;
1174 all_lcrecords = all_older_lcrecords;
1175 obj = make_vector (length, init);
1176 all_older_lcrecords = all_lcrecords;
1177 all_lcrecords = orig_all_lcrecords;
1182 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1183 Return a new vector of length LENGTH, with each element being INIT.
1184 See also the function `vector'.
1188 CONCHECK_NATNUM (length);
1189 return make_vector (XINT (length), init);
1192 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1193 Return a newly created vector with specified arguments as elements.
1194 Any number of arguments, even zero arguments, are allowed.
1196 (int nargs, Lisp_Object *args))
1198 Lisp_Vector *vecp = make_vector_internal (nargs);
1199 Lisp_Object *p = vector_data (vecp);
1206 XSETVECTOR (vector, vecp);
1212 vector1 (Lisp_Object obj0)
1214 return Fvector (1, &obj0);
1218 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1220 Lisp_Object args[2];
1223 return Fvector (2, args);
1227 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1229 Lisp_Object args[3];
1233 return Fvector (3, args);
1236 #if 0 /* currently unused */
1239 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1242 Lisp_Object args[4];
1247 return Fvector (4, args);
1251 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1252 Lisp_Object obj3, Lisp_Object obj4)
1254 Lisp_Object args[5];
1260 return Fvector (5, args);
1264 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1265 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1267 Lisp_Object args[6];
1274 return Fvector (6, args);
1278 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1279 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1282 Lisp_Object args[7];
1290 return Fvector (7, args);
1294 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1295 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1296 Lisp_Object obj6, Lisp_Object obj7)
1298 Lisp_Object args[8];
1307 return Fvector (8, args);
1311 /************************************************************************/
1312 /* Bit Vector allocation */
1313 /************************************************************************/
1315 static Lisp_Object all_bit_vectors;
1317 /* #### should allocate `small' bit vectors from a frob-block */
1318 static Lisp_Bit_Vector *
1319 make_bit_vector_internal (size_t sizei)
1321 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1322 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1323 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1324 set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
1326 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1328 bit_vector_length (p) = sizei;
1329 bit_vector_next (p) = all_bit_vectors;
1330 /* make sure the extra bits in the last long are 0; the calling
1331 functions might not set them. */
1332 p->bits[num_longs - 1] = 0;
1333 XSETBIT_VECTOR (all_bit_vectors, p);
1338 make_bit_vector (size_t length, Lisp_Object init)
1340 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1341 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1346 memset (p->bits, 0, num_longs * sizeof (long));
1349 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1350 memset (p->bits, ~0, num_longs * sizeof (long));
1351 /* But we have to make sure that the unused bits in the
1352 last long are 0, so that equal/hash is easy. */
1354 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1358 Lisp_Object bit_vector;
1359 XSETBIT_VECTOR (bit_vector, p);
1365 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1368 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1370 for (i = 0; i < length; i++)
1371 set_bit_vector_bit (p, i, bytevec[i]);
1374 Lisp_Object bit_vector;
1375 XSETBIT_VECTOR (bit_vector, p);
1380 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1381 Return a new bit vector of length LENGTH. with each bit being INIT.
1382 Each element is set to INIT. See also the function `bit-vector'.
1386 CONCHECK_NATNUM (length);
1388 return make_bit_vector (XINT (length), init);
1391 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1392 Return a newly created bit vector with specified arguments as elements.
1393 Any number of arguments, even zero arguments, are allowed.
1395 (int nargs, Lisp_Object *args))
1398 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1400 for (i = 0; i < nargs; i++)
1402 CHECK_BIT (args[i]);
1403 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1407 Lisp_Object bit_vector;
1408 XSETBIT_VECTOR (bit_vector, p);
1414 /************************************************************************/
1415 /* Compiled-function allocation */
1416 /************************************************************************/
1418 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1419 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1422 make_compiled_function (void)
1424 Lisp_Compiled_Function *f;
1427 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1428 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
1431 f->specpdl_depth = 0;
1432 f->flags.documentationp = 0;
1433 f->flags.interactivep = 0;
1434 f->flags.domainp = 0; /* I18N3 */
1435 f->instructions = Qzero;
1436 f->constants = Qzero;
1438 f->doc_and_interactive = Qnil;
1439 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1440 f->annotated = Qnil;
1442 XSETCOMPILED_FUNCTION (fun, f);
1446 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1447 Return a new compiled-function object.
1448 Usage: (arglist instructions constants stack-depth
1449 &optional doc-string interactive)
1450 Note that, unlike all other emacs-lisp functions, calling this with five
1451 arguments is NOT the same as calling it with six arguments, the last of
1452 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1453 that this function was defined with `(interactive)'. If the arg is not
1454 specified, then that means the function is not interactive.
1455 This is terrible behavior which is retained for compatibility with old
1456 `.elc' files which expect these semantics.
1458 (int nargs, Lisp_Object *args))
1460 /* In a non-insane world this function would have this arglist...
1461 (arglist instructions constants stack_depth &optional doc_string interactive)
1463 Lisp_Object fun = make_compiled_function ();
1464 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1466 Lisp_Object arglist = args[0];
1467 Lisp_Object instructions = args[1];
1468 Lisp_Object constants = args[2];
1469 Lisp_Object stack_depth = args[3];
1470 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1471 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1473 if (nargs < 4 || nargs > 6)
1474 return Fsignal (Qwrong_number_of_arguments,
1475 list2 (intern ("make-byte-code"), make_int (nargs)));
1477 /* Check for valid formal parameter list now, to allow us to use
1478 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1480 Lisp_Object symbol, tail;
1481 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1483 CHECK_SYMBOL (symbol);
1484 if (EQ (symbol, Qt) ||
1485 EQ (symbol, Qnil) ||
1486 SYMBOL_IS_KEYWORD (symbol))
1487 signal_simple_error_2
1488 ("Invalid constant symbol in formal parameter list",
1492 f->arglist = arglist;
1494 /* `instructions' is a string or a cons (string . int) for a
1495 lazy-loaded function. */
1496 if (CONSP (instructions))
1498 CHECK_STRING (XCAR (instructions));
1499 CHECK_INT (XCDR (instructions));
1503 CHECK_STRING (instructions);
1505 f->instructions = instructions;
1507 if (!NILP (constants))
1508 CHECK_VECTOR (constants);
1509 f->constants = constants;
1511 CHECK_NATNUM (stack_depth);
1512 f->stack_depth = (unsigned short) XINT (stack_depth);
1514 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1515 if (!NILP (Vcurrent_compiled_function_annotation))
1516 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1517 else if (!NILP (Vload_file_name_internal_the_purecopy))
1518 f->annotated = Vload_file_name_internal_the_purecopy;
1519 else if (!NILP (Vload_file_name_internal))
1521 struct gcpro gcpro1;
1522 GCPRO1 (fun); /* don't let fun get reaped */
1523 Vload_file_name_internal_the_purecopy =
1524 Ffile_name_nondirectory (Vload_file_name_internal);
1525 f->annotated = Vload_file_name_internal_the_purecopy;
1528 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1530 /* doc_string may be nil, string, int, or a cons (string . int).
1531 interactive may be list or string (or unbound). */
1532 f->doc_and_interactive = Qunbound;
1534 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1535 f->doc_and_interactive = Vfile_domain;
1537 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1539 f->doc_and_interactive
1540 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1541 Fcons (interactive, f->doc_and_interactive));
1543 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1545 f->doc_and_interactive
1546 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1547 Fcons (doc_string, f->doc_and_interactive));
1549 if (UNBOUNDP (f->doc_and_interactive))
1550 f->doc_and_interactive = Qnil;
1556 /************************************************************************/
1557 /* Symbol allocation */
1558 /************************************************************************/
1560 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1561 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1563 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1564 Return a newly allocated uninterned symbol whose name is NAME.
1565 Its value and function definition are void, and its property list is nil.
1572 CHECK_STRING (name);
1574 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1575 set_lheader_implementation (&p->lheader, &lrecord_symbol);
1576 p->name = XSTRING (name);
1578 p->value = Qunbound;
1579 p->function = Qunbound;
1580 symbol_next (p) = 0;
1581 XSETSYMBOL (val, p);
1586 /************************************************************************/
1587 /* Extent allocation */
1588 /************************************************************************/
1590 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1591 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1594 allocate_extent (void)
1598 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1599 set_lheader_implementation (&e->lheader, &lrecord_extent);
1600 extent_object (e) = Qnil;
1601 set_extent_start (e, -1);
1602 set_extent_end (e, -1);
1607 extent_face (e) = Qnil;
1608 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1609 e->flags.detachable = 1;
1615 /************************************************************************/
1616 /* Event allocation */
1617 /************************************************************************/
1619 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1620 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1623 allocate_event (void)
1628 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1629 set_lheader_implementation (&e->lheader, &lrecord_event);
1636 /************************************************************************/
1637 /* Marker allocation */
1638 /************************************************************************/
1640 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1641 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1643 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1644 Return a new marker which does not point at any place.
1651 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1652 set_lheader_implementation (&p->lheader, &lrecord_marker);
1655 marker_next (p) = 0;
1656 marker_prev (p) = 0;
1657 p->insertion_type = 0;
1658 XSETMARKER (val, p);
1663 noseeum_make_marker (void)
1668 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1669 set_lheader_implementation (&p->lheader, &lrecord_marker);
1672 marker_next (p) = 0;
1673 marker_prev (p) = 0;
1674 p->insertion_type = 0;
1675 XSETMARKER (val, p);
1680 /************************************************************************/
1681 /* String allocation */
1682 /************************************************************************/
1684 /* The data for "short" strings generally resides inside of structs of type
1685 string_chars_block. The Lisp_String structure is allocated just like any
1686 other Lisp object (except for vectors), and these are freelisted when
1687 they get garbage collected. The data for short strings get compacted,
1688 but the data for large strings do not.
1690 Previously Lisp_String structures were relocated, but this caused a lot
1691 of bus-errors because the C code didn't include enough GCPRO's for
1692 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1693 that the reference would get relocated).
1695 This new method makes things somewhat bigger, but it is MUCH safer. */
1697 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1698 /* strings are used and freed quite often */
1699 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1700 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1703 mark_string (Lisp_Object obj)
1705 Lisp_String *ptr = XSTRING (obj);
1707 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1708 flush_cached_extent_info (XCAR (ptr->plist));
1713 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1716 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1717 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1720 static const struct lrecord_description string_description[] = {
1721 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1722 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1723 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1727 /* We store the string's extent info as the first element of the string's
1728 property list; and the string's MODIFF as the first or second element
1729 of the string's property list (depending on whether the extent info
1730 is present), but only if the string has been modified. This is ugly
1731 but it reduces the memory allocated for the string in the vast
1732 majority of cases, where the string is never modified and has no
1735 #### This means you can't use an int as a key in a string's plist. */
1737 static Lisp_Object *
1738 string_plist_ptr (Lisp_Object string)
1740 Lisp_Object *ptr = &XSTRING (string)->plist;
1742 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
1744 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
1750 string_getprop (Lisp_Object string, Lisp_Object property)
1752 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
1756 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
1758 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
1763 string_remprop (Lisp_Object string, Lisp_Object property)
1765 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
1769 string_plist (Lisp_Object string)
1771 return *string_plist_ptr (string);
1774 /* No `finalize', or `hash' methods.
1775 internal_hash() already knows how to hash strings and finalization
1776 is done with the ADDITIONAL_FREE_string macro, which is the
1777 standard way to do finalization when using
1778 SWEEP_FIXED_TYPE_BLOCK(). */
1779 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
1780 mark_string, print_string,
1789 /* String blocks contain this many useful bytes. */
1790 #define STRING_CHARS_BLOCK_SIZE \
1791 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1792 ((2 * sizeof (struct string_chars_block *)) \
1793 + sizeof (EMACS_INT))))
1794 /* Block header for small strings. */
1795 struct string_chars_block
1798 struct string_chars_block *next;
1799 struct string_chars_block *prev;
1800 /* Contents of string_chars_block->string_chars are interleaved
1801 string_chars structures (see below) and the actual string data */
1802 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1805 static struct string_chars_block *first_string_chars_block;
1806 static struct string_chars_block *current_string_chars_block;
1808 /* If SIZE is the length of a string, this returns how many bytes
1809 * the string occupies in string_chars_block->string_chars
1810 * (including alignment padding).
1812 #define STRING_FULLSIZE(size) \
1813 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1814 ALIGNOF (Lisp_String *))
1816 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1817 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1821 Lisp_String *string;
1822 unsigned char chars[1];
1825 struct unused_string_chars
1827 Lisp_String *string;
1832 init_string_chars_alloc (void)
1834 first_string_chars_block = xnew (struct string_chars_block);
1835 first_string_chars_block->prev = 0;
1836 first_string_chars_block->next = 0;
1837 first_string_chars_block->pos = 0;
1838 current_string_chars_block = first_string_chars_block;
1841 static struct string_chars *
1842 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1845 struct string_chars *s_chars;
1848 (countof (current_string_chars_block->string_chars)
1849 - current_string_chars_block->pos))
1851 /* This string can fit in the current string chars block */
1852 s_chars = (struct string_chars *)
1853 (current_string_chars_block->string_chars
1854 + current_string_chars_block->pos);
1855 current_string_chars_block->pos += fullsize;
1859 /* Make a new current string chars block */
1860 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1862 current_string_chars_block->next = new_scb;
1863 new_scb->prev = current_string_chars_block;
1865 current_string_chars_block = new_scb;
1866 new_scb->pos = fullsize;
1867 s_chars = (struct string_chars *)
1868 current_string_chars_block->string_chars;
1871 s_chars->string = string_it_goes_with;
1873 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1879 make_uninit_string (Bytecount length)
1882 EMACS_INT fullsize = STRING_FULLSIZE (length);
1885 assert (length >= 0 && fullsize > 0);
1887 /* Allocate the string header */
1888 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1889 set_lheader_implementation (&s->lheader, &lrecord_string);
1891 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1892 ? xnew_array (Bufbyte, length + 1)
1893 : allocate_string_chars_struct (s, fullsize)->chars);
1895 set_string_length (s, length);
1898 set_string_byte (s, length, 0);
1900 XSETSTRING (val, s);
1904 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1905 static void verify_string_chars_integrity (void);
1908 /* Resize the string S so that DELTA bytes can be inserted starting
1909 at POS. If DELTA < 0, it means deletion starting at POS. If
1910 POS < 0, resize the string but don't copy any characters. Use
1911 this if you're planning on completely overwriting the string.
1915 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
1917 Bytecount oldfullsize, newfullsize;
1918 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1919 verify_string_chars_integrity ();
1922 #ifdef ERROR_CHECK_BUFPOS
1925 assert (pos <= string_length (s));
1927 assert (pos + (-delta) <= string_length (s));
1932 assert ((-delta) <= string_length (s));
1934 #endif /* ERROR_CHECK_BUFPOS */
1937 /* simplest case: no size change. */
1940 if (pos >= 0 && delta < 0)
1941 /* If DELTA < 0, the functions below will delete the characters
1942 before POS. We want to delete characters *after* POS, however,
1943 so convert this to the appropriate form. */
1946 oldfullsize = STRING_FULLSIZE (string_length (s));
1947 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1949 if (BIG_STRING_FULLSIZE_P (oldfullsize))
1951 if (BIG_STRING_FULLSIZE_P (newfullsize))
1953 /* Both strings are big. We can just realloc().
1954 But careful! If the string is shrinking, we have to
1955 memmove() _before_ realloc(), and if growing, we have to
1956 memmove() _after_ realloc() - otherwise the access is
1957 illegal, and we might crash. */
1958 Bytecount len = string_length (s) + 1 - pos;
1960 if (delta < 0 && pos >= 0)
1961 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1962 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1963 string_length (s) + delta + 1));
1964 if (delta > 0 && pos >= 0)
1965 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1967 else /* String has been demoted from BIG_STRING. */
1970 allocate_string_chars_struct (s, newfullsize)->chars;
1971 Bufbyte *old_data = string_data (s);
1975 memcpy (new_data, old_data, pos);
1976 memcpy (new_data + pos + delta, old_data + pos,
1977 string_length (s) + 1 - pos);
1979 set_string_data (s, new_data);
1983 else /* old string is small */
1985 if (oldfullsize == newfullsize)
1987 /* special case; size change but the necessary
1988 allocation size won't change (up or down; code
1989 somewhere depends on there not being any unused
1990 allocation space, modulo any alignment
1994 Bufbyte *addroff = pos + string_data (s);
1996 memmove (addroff + delta, addroff,
1997 /* +1 due to zero-termination. */
1998 string_length (s) + 1 - pos);
2003 Bufbyte *old_data = string_data (s);
2005 BIG_STRING_FULLSIZE_P (newfullsize)
2006 ? xnew_array (Bufbyte, string_length (s) + delta + 1)
2007 : allocate_string_chars_struct (s, newfullsize)->chars;
2011 memcpy (new_data, old_data, pos);
2012 memcpy (new_data + pos + delta, old_data + pos,
2013 string_length (s) + 1 - pos);
2015 set_string_data (s, new_data);
2018 /* We need to mark this chunk of the string_chars_block
2019 as unused so that compact_string_chars() doesn't
2021 struct string_chars *old_s_chars = (struct string_chars *)
2022 ((char *) old_data - offsetof (struct string_chars, chars));
2023 /* Sanity check to make sure we aren't hosed by strange
2024 alignment/padding. */
2025 assert (old_s_chars->string == s);
2026 MARK_STRUCT_AS_FREE (old_s_chars);
2027 ((struct unused_string_chars *) old_s_chars)->fullsize =
2033 set_string_length (s, string_length (s) + delta);
2034 /* If pos < 0, the string won't be zero-terminated.
2035 Terminate now just to make sure. */
2036 string_data (s)[string_length (s)] = '\0';
2042 XSETSTRING (string, s);
2043 /* We also have to adjust all of the extent indices after the
2044 place we did the change. We say "pos - 1" because
2045 adjust_extents() is exclusive of the starting position
2047 adjust_extents (string, pos - 1, string_length (s),
2051 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2052 verify_string_chars_integrity ();
2059 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2061 Bufbyte newstr[MAX_EMCHAR_LEN];
2062 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2063 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2064 Bytecount newlen = set_charptr_emchar (newstr, c);
2066 if (oldlen != newlen)
2067 resize_string (s, bytoff, newlen - oldlen);
2068 /* Remember, string_data (s) might have changed so we can't cache it. */
2069 memcpy (string_data (s) + bytoff, newstr, newlen);
2074 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2075 Return a new string of length LENGTH, with each character being INIT.
2076 LENGTH must be an integer and INIT must be a character.
2080 CHECK_NATNUM (length);
2081 CHECK_CHAR_COERCE_INT (init);
2083 Bufbyte init_str[MAX_EMCHAR_LEN];
2084 int len = set_charptr_emchar (init_str, XCHAR (init));
2085 Lisp_Object val = make_uninit_string (len * XINT (length));
2088 /* Optimize the single-byte case */
2089 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2093 Bufbyte *ptr = XSTRING_DATA (val);
2095 for (i = XINT (length); i; i--)
2097 Bufbyte *init_ptr = init_str;
2101 case 6: *ptr++ = *init_ptr++;
2102 case 5: *ptr++ = *init_ptr++;
2104 case 4: *ptr++ = *init_ptr++;
2105 case 3: *ptr++ = *init_ptr++;
2106 case 2: *ptr++ = *init_ptr++;
2107 case 1: *ptr++ = *init_ptr++;
2115 DEFUN ("string", Fstring, 0, MANY, 0, /*
2116 Concatenate all the argument characters and make the result a string.
2118 (int nargs, Lisp_Object *args))
2120 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2121 Bufbyte *p = storage;
2123 for (; nargs; nargs--, args++)
2125 Lisp_Object lisp_char = *args;
2126 CHECK_CHAR_COERCE_INT (lisp_char);
2127 p += set_charptr_emchar (p, XCHAR (lisp_char));
2129 return make_string (storage, p - storage);
2133 /* Take some raw memory, which MUST already be in internal format,
2134 and package it up into a Lisp string. */
2136 make_string (const Bufbyte *contents, Bytecount length)
2140 /* Make sure we find out about bad make_string's when they happen */
2141 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2142 bytecount_to_charcount (contents, length); /* Just for the assertions */
2145 val = make_uninit_string (length);
2146 memcpy (XSTRING_DATA (val), contents, length);
2150 /* Take some raw memory, encoded in some external data format,
2151 and convert it into a Lisp string. */
2153 make_ext_string (const Extbyte *contents, EMACS_INT length,
2154 Lisp_Object coding_system)
2157 TO_INTERNAL_FORMAT (DATA, (contents, length),
2158 LISP_STRING, string,
2164 build_string (const char *str)
2166 /* Some strlen's crash and burn if passed null. */
2167 return make_string ((const Bufbyte *) str, (str ? strlen(str) : 0));
2171 build_ext_string (const char *str, Lisp_Object coding_system)
2173 /* Some strlen's crash and burn if passed null. */
2174 return make_ext_string ((const Extbyte *) str, (str ? strlen(str) : 0),
2179 build_translated_string (const char *str)
2181 return build_string (GETTEXT (str));
2185 make_string_nocopy (const Bufbyte *contents, Bytecount length)
2190 /* Make sure we find out about bad make_string_nocopy's when they happen */
2191 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2192 bytecount_to_charcount (contents, length); /* Just for the assertions */
2195 /* Allocate the string header */
2196 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2197 set_lheader_implementation (&s->lheader, &lrecord_string);
2198 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2200 set_string_data (s, (Bufbyte *)contents);
2201 set_string_length (s, length);
2203 XSETSTRING (val, s);
2208 /************************************************************************/
2209 /* lcrecord lists */
2210 /************************************************************************/
2212 /* Lcrecord lists are used to manage the allocation of particular
2213 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2214 malloc() and garbage-collection junk) as much as possible.
2215 It is similar to the Blocktype class.
2219 1) Create an lcrecord-list object using make_lcrecord_list().
2220 This is often done at initialization. Remember to staticpro_nodump
2221 this object! The arguments to make_lcrecord_list() are the
2222 same as would be passed to alloc_lcrecord().
2223 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2224 and pass the lcrecord-list earlier created.
2225 3) When done with the lcrecord, call free_managed_lcrecord().
2226 The standard freeing caveats apply: ** make sure there are no
2227 pointers to the object anywhere! **
2228 4) Calling free_managed_lcrecord() is just like kissing the
2229 lcrecord goodbye as if it were garbage-collected. This means:
2230 -- the contents of the freed lcrecord are undefined, and the
2231 contents of something produced by allocate_managed_lcrecord()
2232 are undefined, just like for alloc_lcrecord().
2233 -- the mark method for the lcrecord's type will *NEVER* be called
2235 -- the finalize method for the lcrecord's type will be called
2236 at the time that free_managed_lcrecord() is called.
2241 mark_lcrecord_list (Lisp_Object obj)
2243 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2244 Lisp_Object chain = list->free;
2246 while (!NILP (chain))
2248 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2249 struct free_lcrecord_header *free_header =
2250 (struct free_lcrecord_header *) lheader;
2253 (/* There should be no other pointers to the free list. */
2254 ! MARKED_RECORD_HEADER_P (lheader)
2256 /* Only lcrecords should be here. */
2257 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
2259 /* Only free lcrecords should be here. */
2260 free_header->lcheader.free
2262 /* The type of the lcrecord must be right. */
2263 LHEADER_IMPLEMENTATION (lheader) == list->implementation
2265 /* So must the size. */
2266 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2267 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
2270 MARK_RECORD_HEADER (lheader);
2271 chain = free_header->chain;
2277 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2278 mark_lcrecord_list, internal_object_printer,
2279 0, 0, 0, 0, struct lcrecord_list);
2281 make_lcrecord_list (size_t size,
2282 const struct lrecord_implementation *implementation)
2284 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2285 &lrecord_lcrecord_list);
2288 p->implementation = implementation;
2291 XSETLCRECORD_LIST (val, p);
2296 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2298 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2299 if (!NILP (list->free))
2301 Lisp_Object val = list->free;
2302 struct free_lcrecord_header *free_header =
2303 (struct free_lcrecord_header *) XPNTR (val);
2305 #ifdef ERROR_CHECK_GC
2306 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2308 /* There should be no other pointers to the free list. */
2309 assert (! MARKED_RECORD_HEADER_P (lheader));
2310 /* Only lcrecords should be here. */
2311 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
2312 /* Only free lcrecords should be here. */
2313 assert (free_header->lcheader.free);
2314 /* The type of the lcrecord must be right. */
2315 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
2316 /* So must the size. */
2317 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2318 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
2319 #endif /* ERROR_CHECK_GC */
2321 list->free = free_header->chain;
2322 free_header->lcheader.free = 0;
2329 XSETOBJ (val, Lisp_Type_Record,
2330 alloc_lcrecord (list->size, list->implementation));
2336 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2338 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2339 struct free_lcrecord_header *free_header =
2340 (struct free_lcrecord_header *) XPNTR (lcrecord);
2341 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2342 const struct lrecord_implementation *implementation
2343 = LHEADER_IMPLEMENTATION (lheader);
2345 /* Make sure the size is correct. This will catch, for example,
2346 putting a window configuration on the wrong free list. */
2347 gc_checking_assert ((implementation->size_in_bytes_method ?
2348 implementation->size_in_bytes_method (lheader) :
2349 implementation->static_size)
2352 if (implementation->finalizer)
2353 implementation->finalizer (lheader, 0);
2354 free_header->chain = list->free;
2355 free_header->lcheader.free = 1;
2356 list->free = lcrecord;
2362 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2363 Kept for compatibility, returns its argument.
2365 Make a copy of OBJECT in pure storage.
2366 Recursively copies contents of vectors and cons cells.
2367 Does not copy symbols.
2375 /************************************************************************/
2376 /* Garbage Collection */
2377 /************************************************************************/
2379 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
2380 Additional ones may be defined by a module (none yet). We leave some
2381 room in `lrecord_implementations_table' for such new lisp object types. */
2382 #define MODULE_DEFINABLE_TYPE_COUNT 32
2383 const struct lrecord_implementation *lrecord_implementations_table[lrecord_type_count + MODULE_DEFINABLE_TYPE_COUNT];
2385 /* Object marker functions are in the lrecord_implementation structure.
2386 But copying them to a parallel array is much more cache-friendly.
2387 This hack speeds up (garbage-collect) by about 5%. */
2388 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
2390 struct gcpro *gcprolist;
2392 /* 415 used Mly 29-Jun-93 */
2393 /* 1327 used slb 28-Feb-98 */
2394 /* 1328 used og 03-Oct-99 (moving slowly, heh?) */
2396 #define NSTATICS 4000
2398 #define NSTATICS 2000
2401 /* Not "static" because used by dumper.c */
2402 Lisp_Object *staticvec[NSTATICS];
2405 /* Put an entry in staticvec, pointing at the variable whose address is given
2408 staticpro (Lisp_Object *varaddress)
2410 /* #### This is now a dubious assert() since this routine may be called */
2411 /* by Lisp attempting to load a DLL. */
2412 assert (staticidx < countof (staticvec));
2413 staticvec[staticidx++] = varaddress;
2417 Lisp_Object *staticvec_nodump[200];
2418 int staticidx_nodump;
2420 /* Put an entry in staticvec_nodump, pointing at the variable whose address is given
2423 staticpro_nodump (Lisp_Object *varaddress)
2425 /* #### This is now a dubious assert() since this routine may be called */
2426 /* by Lisp attempting to load a DLL. */
2427 assert (staticidx_nodump < countof (staticvec_nodump));
2428 staticvec_nodump[staticidx_nodump++] = varaddress;
2432 struct pdump_dumpstructinfo dumpstructvec[200];
2435 /* Put an entry in dumpstructvec, pointing at the variable whose address is given
2438 dumpstruct (void *varaddress, const struct struct_description *desc)
2440 assert (dumpstructidx < countof (dumpstructvec));
2441 dumpstructvec[dumpstructidx].data = varaddress;
2442 dumpstructvec[dumpstructidx].desc = desc;
2446 struct pdump_dumpopaqueinfo dumpopaquevec[250];
2449 /* Put an entry in dumpopaquevec, pointing at the variable whose address is given
2452 dumpopaque (void *varaddress, size_t size)
2454 assert (dumpopaqueidx < countof (dumpopaquevec));
2456 dumpopaquevec[dumpopaqueidx].data = varaddress;
2457 dumpopaquevec[dumpopaqueidx].size = size;
2461 Lisp_Object *pdump_wirevec[50];
2464 /* Put an entry in pdump_wirevec, pointing at the variable whose address is given
2467 pdump_wire (Lisp_Object *varaddress)
2469 assert (pdump_wireidx < countof (pdump_wirevec));
2470 pdump_wirevec[pdump_wireidx++] = varaddress;
2474 Lisp_Object *pdump_wirevec_list[50];
2475 int pdump_wireidx_list;
2477 /* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given
2480 pdump_wire_list (Lisp_Object *varaddress)
2482 assert (pdump_wireidx_list < countof (pdump_wirevec_list));
2483 pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
2486 #ifdef ERROR_CHECK_GC
2487 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
2488 struct lrecord_header * GCLI_lh = (lheader); \
2489 assert (GCLI_lh != 0); \
2490 assert (GCLI_lh->type < lrecord_type_count); \
2491 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
2492 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
2493 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
2496 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
2500 /* Mark reference to a Lisp_Object. If the object referred to has not been
2501 seen yet, recursively mark all the references contained in it. */
2504 mark_object (Lisp_Object obj)
2508 /* Checks we used to perform */
2509 /* if (EQ (obj, Qnull_pointer)) return; */
2510 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2511 /* if (PURIFIED (XPNTR (obj))) return; */
2513 if (XTYPE (obj) == Lisp_Type_Record)
2515 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2517 GC_CHECK_LHEADER_INVARIANTS (lheader);
2519 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
2520 ! ((struct lcrecord_header *) lheader)->free);
2522 /* All c_readonly objects have their mark bit set,
2523 so that we only need to check the mark bit here. */
2524 if (! MARKED_RECORD_HEADER_P (lheader))
2526 MARK_RECORD_HEADER (lheader);
2528 if (RECORD_MARKER (lheader))
2530 obj = RECORD_MARKER (lheader) (obj);
2531 if (!NILP (obj)) goto tail_recurse;
2537 /* mark all of the conses in a list and mark the final cdr; but
2538 DO NOT mark the cars.
2540 Use only for internal lists! There should never be other pointers
2541 to the cons cells, because if so, the cars will remain unmarked
2542 even when they maybe should be marked. */
2544 mark_conses_in_list (Lisp_Object obj)
2548 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2550 if (CONS_MARKED_P (XCONS (rest)))
2552 MARK_CONS (XCONS (rest));
2559 /* Find all structures not marked, and free them. */
2561 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2562 static int gc_count_bit_vector_storage;
2563 static int gc_count_num_short_string_in_use;
2564 static int gc_count_string_total_size;
2565 static int gc_count_short_string_total_size;
2567 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2570 /* stats on lcrecords in use - kinda kludgy */
2574 int instances_in_use;
2576 int instances_freed;
2578 int instances_on_free_list;
2579 } lcrecord_stats [countof (lrecord_implementations_table)];
2582 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
2584 unsigned int type_index = h->type;
2586 if (((struct lcrecord_header *) h)->free)
2588 gc_checking_assert (!free_p);
2589 lcrecord_stats[type_index].instances_on_free_list++;
2593 const struct lrecord_implementation *implementation =
2594 LHEADER_IMPLEMENTATION (h);
2596 size_t sz = (implementation->size_in_bytes_method ?
2597 implementation->size_in_bytes_method (h) :
2598 implementation->static_size);
2601 lcrecord_stats[type_index].instances_freed++;
2602 lcrecord_stats[type_index].bytes_freed += sz;
2606 lcrecord_stats[type_index].instances_in_use++;
2607 lcrecord_stats[type_index].bytes_in_use += sz;
2613 /* Free all unmarked records */
2615 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2617 struct lcrecord_header *header;
2619 /* int total_size = 0; */
2621 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2623 /* First go through and call all the finalize methods.
2624 Then go through and free the objects. There used to
2625 be only one loop here, with the call to the finalizer
2626 occurring directly before the xfree() below. That
2627 is marginally faster but much less safe -- if the
2628 finalize method for an object needs to reference any
2629 other objects contained within it (and many do),
2630 we could easily be screwed by having already freed that
2633 for (header = *prev; header; header = header->next)
2635 struct lrecord_header *h = &(header->lheader);
2637 GC_CHECK_LHEADER_INVARIANTS (h);
2639 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
2641 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2642 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2646 for (header = *prev; header; )
2648 struct lrecord_header *h = &(header->lheader);
2649 if (MARKED_RECORD_HEADER_P (h))
2651 if (! C_READONLY_RECORD_HEADER_P (h))
2652 UNMARK_RECORD_HEADER (h);
2654 /* total_size += n->implementation->size_in_bytes (h);*/
2655 /* #### May modify header->next on a C_READONLY lcrecord */
2656 prev = &(header->next);
2658 tick_lcrecord_stats (h, 0);
2662 struct lcrecord_header *next = header->next;
2664 tick_lcrecord_stats (h, 1);
2665 /* used to call finalizer right here. */
2671 /* *total = total_size; */
2676 sweep_bit_vectors_1 (Lisp_Object *prev,
2677 int *used, int *total, int *storage)
2679 Lisp_Object bit_vector;
2682 int total_storage = 0;
2684 /* BIT_VECTORP fails because the objects are marked, which changes
2685 their implementation */
2686 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2688 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2690 if (MARKED_RECORD_P (bit_vector))
2692 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
2693 UNMARK_RECORD_HEADER (&(v->lheader));
2697 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2698 BIT_VECTOR_LONG_STORAGE (len));
2700 /* #### May modify next on a C_READONLY bitvector */
2701 prev = &(bit_vector_next (v));
2706 Lisp_Object next = bit_vector_next (v);
2713 *total = total_size;
2714 *storage = total_storage;
2717 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2718 to make macros prettier. */
2720 #ifdef ERROR_CHECK_GC
2722 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2724 struct typename##_block *SFTB_current; \
2725 struct typename##_block **SFTB_prev; \
2727 int num_free = 0, num_used = 0; \
2729 for (SFTB_prev = ¤t_##typename##_block, \
2730 SFTB_current = current_##typename##_block, \
2731 SFTB_limit = current_##typename##_block_index; \
2737 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2739 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2741 if (FREE_STRUCT_P (SFTB_victim)) \
2745 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2749 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2752 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2757 UNMARK_##typename (SFTB_victim); \
2760 SFTB_prev = &(SFTB_current->prev); \
2761 SFTB_current = SFTB_current->prev; \
2762 SFTB_limit = countof (current_##typename##_block->block); \
2765 gc_count_num_##typename##_in_use = num_used; \
2766 gc_count_num_##typename##_freelist = num_free; \
2769 #else /* !ERROR_CHECK_GC */
2771 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2773 struct typename##_block *SFTB_current; \
2774 struct typename##_block **SFTB_prev; \
2776 int num_free = 0, num_used = 0; \
2778 typename##_free_list = 0; \
2780 for (SFTB_prev = ¤t_##typename##_block, \
2781 SFTB_current = current_##typename##_block, \
2782 SFTB_limit = current_##typename##_block_index; \
2787 int SFTB_empty = 1; \
2788 obj_type *SFTB_old_free_list = typename##_free_list; \
2790 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2792 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2794 if (FREE_STRUCT_P (SFTB_victim)) \
2797 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2799 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2804 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2807 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2813 UNMARK_##typename (SFTB_victim); \
2818 SFTB_prev = &(SFTB_current->prev); \
2819 SFTB_current = SFTB_current->prev; \
2821 else if (SFTB_current == current_##typename##_block \
2822 && !SFTB_current->prev) \
2824 /* No real point in freeing sole allocation block */ \
2829 struct typename##_block *SFTB_victim_block = SFTB_current; \
2830 if (SFTB_victim_block == current_##typename##_block) \
2831 current_##typename##_block_index \
2832 = countof (current_##typename##_block->block); \
2833 SFTB_current = SFTB_current->prev; \
2835 *SFTB_prev = SFTB_current; \
2836 xfree (SFTB_victim_block); \
2837 /* Restore free list to what it was before victim was swept */ \
2838 typename##_free_list = SFTB_old_free_list; \
2839 num_free -= SFTB_limit; \
2842 SFTB_limit = countof (current_##typename##_block->block); \
2845 gc_count_num_##typename##_in_use = num_used; \
2846 gc_count_num_##typename##_freelist = num_free; \
2849 #endif /* !ERROR_CHECK_GC */
2857 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2858 #define ADDITIONAL_FREE_cons(ptr)
2860 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2863 /* Explicitly free a cons cell. */
2865 free_cons (Lisp_Cons *ptr)
2867 #ifdef ERROR_CHECK_GC
2868 /* If the CAR is not an int, then it will be a pointer, which will
2869 always be four-byte aligned. If this cons cell has already been
2870 placed on the free list, however, its car will probably contain
2871 a chain pointer to the next cons on the list, which has cleverly
2872 had all its 0's and 1's inverted. This allows for a quick
2873 check to make sure we're not freeing something already freed. */
2874 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2875 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2876 #endif /* ERROR_CHECK_GC */
2878 #ifndef ALLOC_NO_POOLS
2879 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2880 #endif /* ALLOC_NO_POOLS */
2883 /* explicitly free a list. You **must make sure** that you have
2884 created all the cons cells that make up this list and that there
2885 are no pointers to any of these cons cells anywhere else. If there
2886 are, you will lose. */
2889 free_list (Lisp_Object list)
2891 Lisp_Object rest, next;
2893 for (rest = list; !NILP (rest); rest = next)
2896 free_cons (XCONS (rest));
2900 /* explicitly free an alist. You **must make sure** that you have
2901 created all the cons cells that make up this alist and that there
2902 are no pointers to any of these cons cells anywhere else. If there
2903 are, you will lose. */
2906 free_alist (Lisp_Object alist)
2908 Lisp_Object rest, next;
2910 for (rest = alist; !NILP (rest); rest = next)
2913 free_cons (XCONS (XCAR (rest)));
2914 free_cons (XCONS (rest));
2919 sweep_compiled_functions (void)
2921 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2922 #define ADDITIONAL_FREE_compiled_function(ptr)
2924 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2928 #ifdef LISP_FLOAT_TYPE
2932 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2933 #define ADDITIONAL_FREE_float(ptr)
2935 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
2937 #endif /* LISP_FLOAT_TYPE */
2940 sweep_symbols (void)
2942 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2943 #define ADDITIONAL_FREE_symbol(ptr)
2945 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
2949 sweep_extents (void)
2951 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2952 #define ADDITIONAL_FREE_extent(ptr)
2954 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2960 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2961 #define ADDITIONAL_FREE_event(ptr)
2963 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
2967 sweep_markers (void)
2969 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2970 #define ADDITIONAL_FREE_marker(ptr) \
2971 do { Lisp_Object tem; \
2972 XSETMARKER (tem, ptr); \
2973 unchain_marker (tem); \
2976 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
2979 /* Explicitly free a marker. */
2981 free_marker (Lisp_Marker *ptr)
2983 /* Perhaps this will catch freeing an already-freed marker. */
2984 gc_checking_assert (ptr->lheader.type = lrecord_type_marker);
2986 #ifndef ALLOC_NO_POOLS
2987 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
2988 #endif /* ALLOC_NO_POOLS */
2992 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2995 verify_string_chars_integrity (void)
2997 struct string_chars_block *sb;
2999 /* Scan each existing string block sequentially, string by string. */
3000 for (sb = first_string_chars_block; sb; sb = sb->next)
3003 /* POS is the index of the next string in the block. */
3004 while (pos < sb->pos)
3006 struct string_chars *s_chars =
3007 (struct string_chars *) &(sb->string_chars[pos]);
3008 Lisp_String *string;
3012 /* If the string_chars struct is marked as free (i.e. the STRING
3013 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3014 storage. (See below.) */
3016 if (FREE_STRUCT_P (s_chars))
3018 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3023 string = s_chars->string;
3024 /* Must be 32-bit aligned. */
3025 assert ((((int) string) & 3) == 0);
3027 size = string_length (string);
3028 fullsize = STRING_FULLSIZE (size);
3030 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3031 assert (string_data (string) == s_chars->chars);
3034 assert (pos == sb->pos);
3038 #endif /* MULE && ERROR_CHECK_GC */
3040 /* Compactify string chars, relocating the reference to each --
3041 free any empty string_chars_block we see. */
3043 compact_string_chars (void)
3045 struct string_chars_block *to_sb = first_string_chars_block;
3047 struct string_chars_block *from_sb;
3049 /* Scan each existing string block sequentially, string by string. */
3050 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3053 /* FROM_POS is the index of the next string in the block. */
3054 while (from_pos < from_sb->pos)
3056 struct string_chars *from_s_chars =
3057 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3058 struct string_chars *to_s_chars;
3059 Lisp_String *string;
3063 /* If the string_chars struct is marked as free (i.e. the STRING
3064 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3065 storage. This happens under Mule when a string's size changes
3066 in such a way that its fullsize changes. (Strings can change
3067 size because a different-length character can be substituted
3068 for another character.) In this case, after the bogus string
3069 pointer is the "fullsize" of this entry, i.e. how many bytes
3072 if (FREE_STRUCT_P (from_s_chars))
3074 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3075 from_pos += fullsize;
3079 string = from_s_chars->string;
3080 assert (!(FREE_STRUCT_P (string)));
3082 size = string_length (string);
3083 fullsize = STRING_FULLSIZE (size);
3085 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
3087 /* Just skip it if it isn't marked. */
3088 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3090 from_pos += fullsize;
3094 /* If it won't fit in what's left of TO_SB, close TO_SB out
3095 and go on to the next string_chars_block. We know that TO_SB
3096 cannot advance past FROM_SB here since FROM_SB is large enough
3097 to currently contain this string. */
3098 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3100 to_sb->pos = to_pos;
3101 to_sb = to_sb->next;
3105 /* Compute new address of this string
3106 and update TO_POS for the space being used. */
3107 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3109 /* Copy the string_chars to the new place. */
3110 if (from_s_chars != to_s_chars)
3111 memmove (to_s_chars, from_s_chars, fullsize);
3113 /* Relocate FROM_S_CHARS's reference */
3114 set_string_data (string, &(to_s_chars->chars[0]));
3116 from_pos += fullsize;
3121 /* Set current to the last string chars block still used and
3122 free any that follow. */
3124 struct string_chars_block *victim;
3126 for (victim = to_sb->next; victim; )
3128 struct string_chars_block *next = victim->next;
3133 current_string_chars_block = to_sb;
3134 current_string_chars_block->pos = to_pos;
3135 current_string_chars_block->next = 0;
3139 #if 1 /* Hack to debug missing purecopy's */
3140 static int debug_string_purity;
3143 debug_string_purity_print (Lisp_String *p)
3146 Charcount s = string_char_length (p);
3148 for (i = 0; i < s; i++)
3150 Emchar ch = string_char (p, i);
3151 if (ch < 32 || ch >= 126)
3152 stderr_out ("\\%03o", ch);
3153 else if (ch == '\\' || ch == '\"')
3154 stderr_out ("\\%c", ch);
3156 stderr_out ("%c", ch);
3158 stderr_out ("\"\n");
3164 sweep_strings (void)
3166 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3167 int debug = debug_string_purity;
3169 #define UNMARK_string(ptr) do { \
3170 Lisp_String *p = (ptr); \
3171 size_t size = string_length (p); \
3172 UNMARK_RECORD_HEADER (&(p->lheader)); \
3173 num_bytes += size; \
3174 if (!BIG_STRING_SIZE_P (size)) \
3176 num_small_bytes += size; \
3180 debug_string_purity_print (p); \
3182 #define ADDITIONAL_FREE_string(ptr) do { \
3183 size_t size = string_length (ptr); \
3184 if (BIG_STRING_SIZE_P (size)) \
3185 xfree (ptr->data); \
3188 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3190 gc_count_num_short_string_in_use = num_small_used;
3191 gc_count_string_total_size = num_bytes;
3192 gc_count_short_string_total_size = num_small_bytes;
3196 /* I hate duplicating all this crap! */
3198 marked_p (Lisp_Object obj)
3200 /* Checks we used to perform. */
3201 /* if (EQ (obj, Qnull_pointer)) return 1; */
3202 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3203 /* if (PURIFIED (XPNTR (obj))) return 1; */
3205 if (XTYPE (obj) == Lisp_Type_Record)
3207 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3209 GC_CHECK_LHEADER_INVARIANTS (lheader);
3211 return MARKED_RECORD_HEADER_P (lheader);
3219 /* Free all unmarked records. Do this at the very beginning,
3220 before anything else, so that the finalize methods can safely
3221 examine items in the objects. sweep_lcrecords_1() makes
3222 sure to call all the finalize methods *before* freeing anything,
3223 to complete the safety. */
3226 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3229 compact_string_chars ();
3231 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3232 macros) must be *extremely* careful to make sure they're not
3233 referencing freed objects. The only two existing finalize
3234 methods (for strings and markers) pass muster -- the string
3235 finalizer doesn't look at anything but its own specially-
3236 created block, and the marker finalizer only looks at live
3237 buffers (which will never be freed) and at the markers before
3238 and after it in the chain (which, by induction, will never be
3239 freed because if so, they would have already removed themselves
3242 /* Put all unmarked strings on free list, free'ing the string chars
3243 of large unmarked strings */
3246 /* Put all unmarked conses on free list */
3249 /* Free all unmarked bit vectors */
3250 sweep_bit_vectors_1 (&all_bit_vectors,
3251 &gc_count_num_bit_vector_used,
3252 &gc_count_bit_vector_total_size,
3253 &gc_count_bit_vector_storage);
3255 /* Free all unmarked compiled-function objects */
3256 sweep_compiled_functions ();
3258 #ifdef LISP_FLOAT_TYPE
3259 /* Put all unmarked floats on free list */
3263 /* Put all unmarked symbols on free list */
3266 /* Put all unmarked extents on free list */
3269 /* Put all unmarked markers on free list.
3270 Dechain each one first from the buffer into which it points. */
3276 pdump_objects_unmark ();
3280 /* Clearing for disksave. */
3283 disksave_object_finalization (void)
3285 /* It's important that certain information from the environment not get
3286 dumped with the executable (pathnames, environment variables, etc.).
3287 To make it easier to tell when this has happened with strings(1) we
3288 clear some known-to-be-garbage blocks of memory, so that leftover
3289 results of old evaluation don't look like potential problems.
3290 But first we set some notable variables to nil and do one more GC,
3291 to turn those strings into garbage.
3294 /* Yeah, this list is pretty ad-hoc... */
3295 Vprocess_environment = Qnil;
3296 Vexec_directory = Qnil;
3297 Vdata_directory = Qnil;
3298 Vsite_directory = Qnil;
3299 Vdoc_directory = Qnil;
3300 Vconfigure_info_directory = Qnil;
3303 /* Vdump_load_path = Qnil; */
3304 /* Release hash tables for locate_file */
3305 Flocate_file_clear_hashing (Qt);
3306 uncache_home_directory();
3308 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3309 defined(LOADHIST_BUILTIN))
3310 Vload_history = Qnil;
3312 Vshell_file_name = Qnil;
3314 garbage_collect_1 ();
3316 /* Run the disksave finalization methods of all live objects. */
3317 disksave_object_finalization_1 ();
3319 /* Zero out the uninitialized (really, unused) part of the containers
3320 for the live strings. */
3322 struct string_chars_block *scb;
3323 for (scb = first_string_chars_block; scb; scb = scb->next)
3325 int count = sizeof (scb->string_chars) - scb->pos;
3327 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3330 /* from the block's fill ptr to the end */
3331 memset ((scb->string_chars + scb->pos), 0, count);
3336 /* There, that ought to be enough... */
3342 restore_gc_inhibit (Lisp_Object val)
3344 gc_currently_forbidden = XINT (val);
3348 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3349 static int gc_hooks_inhibited;
3353 garbage_collect_1 (void)
3355 #if MAX_SAVE_STACK > 0
3356 char stack_top_variable;
3357 extern char *stack_bottom;
3362 Lisp_Object pre_gc_cursor;
3363 struct gcpro gcpro1;
3366 || gc_currently_forbidden
3368 || preparing_for_armageddon)
3371 /* We used to call selected_frame() here.
3373 The following functions cannot be called inside GC
3374 so we move to after the above tests. */
3377 Lisp_Object device = Fselected_device (Qnil);
3378 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3380 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3382 signal_simple_error ("No frames exist on device", device);
3386 pre_gc_cursor = Qnil;
3389 GCPRO1 (pre_gc_cursor);
3391 /* Very important to prevent GC during any of the following
3392 stuff that might run Lisp code; otherwise, we'll likely
3393 have infinite GC recursion. */
3394 speccount = specpdl_depth ();
3395 record_unwind_protect (restore_gc_inhibit,
3396 make_int (gc_currently_forbidden));
3397 gc_currently_forbidden = 1;
3399 if (!gc_hooks_inhibited)
3400 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3402 /* Now show the GC cursor/message. */
3403 if (!noninteractive)
3405 if (FRAME_WIN_P (f))
3407 Lisp_Object frame = make_frame (f);
3408 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3409 FRAME_SELECTED_WINDOW (f),
3411 pre_gc_cursor = f->pointer;
3412 if (POINTER_IMAGE_INSTANCEP (cursor)
3413 /* don't change if we don't know how to change back. */
3414 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3417 Fset_frame_pointer (frame, cursor);
3421 /* Don't print messages to the stream device. */
3422 if (!cursor_changed && !FRAME_STREAM_P (f))
3424 char *msg = (STRINGP (Vgc_message)
3425 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3427 Lisp_Object args[2], whole_msg;
3428 args[0] = build_string (msg ? msg :
3429 GETTEXT ((const char *) gc_default_message));
3430 args[1] = build_string ("...");
3431 whole_msg = Fconcat (2, args);
3432 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3433 Qgarbage_collecting);
3437 /***** Now we actually start the garbage collection. */
3441 gc_generation_number[0]++;
3443 #if MAX_SAVE_STACK > 0
3445 /* Save a copy of the contents of the stack, for debugging. */
3448 /* Static buffer in which we save a copy of the C stack at each GC. */
3449 static char *stack_copy;
3450 static size_t stack_copy_size;
3452 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3453 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3454 if (stack_size < MAX_SAVE_STACK)
3456 if (stack_copy_size < stack_size)
3458 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3459 stack_copy_size = stack_size;
3463 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3467 #endif /* MAX_SAVE_STACK > 0 */
3469 /* Do some totally ad-hoc resource clearing. */
3470 /* #### generalize this? */
3471 clear_event_resource ();
3472 cleanup_specifiers ();
3474 /* Mark all the special slots that serve as the roots of accessibility. */
3478 for (i = 0; i < staticidx; i++)
3479 mark_object (*(staticvec[i]));
3480 for (i = 0; i < staticidx_nodump; i++)
3481 mark_object (*(staticvec_nodump[i]));
3487 for (tail = gcprolist; tail; tail = tail->next)
3488 for (i = 0; i < tail->nvars; i++)
3489 mark_object (tail->var[i]);
3493 struct specbinding *bind;
3494 for (bind = specpdl; bind != specpdl_ptr; bind++)
3496 mark_object (bind->symbol);
3497 mark_object (bind->old_value);
3502 struct catchtag *catch;
3503 for (catch = catchlist; catch; catch = catch->next)
3505 mark_object (catch->tag);
3506 mark_object (catch->val);
3511 struct backtrace *backlist;
3512 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3514 int nargs = backlist->nargs;
3517 mark_object (*backlist->function);
3518 if (nargs == UNEVALLED || nargs == MANY)
3519 mark_object (backlist->args[0]);
3521 for (i = 0; i < nargs; i++)
3522 mark_object (backlist->args[i]);
3527 mark_profiling_info ();
3529 /* OK, now do the after-mark stuff. This is for things that
3530 are only marked when something else is marked (e.g. weak hash tables).
3531 There may be complex dependencies between such objects -- e.g.
3532 a weak hash table might be unmarked, but after processing a later
3533 weak hash table, the former one might get marked. So we have to
3534 iterate until nothing more gets marked. */
3536 while (finish_marking_weak_hash_tables () > 0 ||
3537 finish_marking_weak_lists () > 0)
3540 /* And prune (this needs to be called after everything else has been
3541 marked and before we do any sweeping). */
3542 /* #### this is somewhat ad-hoc and should probably be an object
3544 prune_weak_hash_tables ();
3545 prune_weak_lists ();
3546 prune_specifiers ();
3547 prune_syntax_tables ();
3551 consing_since_gc = 0;
3552 #ifndef DEBUG_XEMACS
3553 /* Allow you to set it really fucking low if you really want ... */
3554 if (gc_cons_threshold < 10000)
3555 gc_cons_threshold = 10000;
3560 /******* End of garbage collection ********/
3562 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3564 /* Now remove the GC cursor/message */
3565 if (!noninteractive)
3568 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3569 else if (!FRAME_STREAM_P (f))
3571 char *msg = (STRINGP (Vgc_message)
3572 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3575 /* Show "...done" only if the echo area would otherwise be empty. */
3576 if (NILP (clear_echo_area (selected_frame (),
3577 Qgarbage_collecting, 0)))
3579 Lisp_Object args[2], whole_msg;
3580 args[0] = build_string (msg ? msg :
3581 GETTEXT ((const char *)
3582 gc_default_message));
3583 args[1] = build_string ("... done");
3584 whole_msg = Fconcat (2, args);
3585 echo_area_message (selected_frame (), (Bufbyte *) 0,
3587 Qgarbage_collecting);
3592 /* now stop inhibiting GC */
3593 unbind_to (speccount, Qnil);
3595 if (!breathing_space)
3597 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3604 /* Debugging aids. */
3607 gc_plist_hack (const char *name, int value, Lisp_Object tail)
3609 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3610 or portable numeric datatypes, or bit-vectors, or characters, or
3611 arrays, or exceptions, or ...) */
3612 return cons3 (intern (name), make_int (value), tail);
3615 #define HACK_O_MATIC(type, name, pl) do { \
3617 struct type##_block *x = current_##type##_block; \
3618 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3619 (pl) = gc_plist_hack ((name), s, (pl)); \
3622 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3623 Reclaim storage for Lisp objects no longer needed.
3624 Return info on amount of space in use:
3625 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3626 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3628 where `PLIST' is a list of alternating keyword/value pairs providing
3629 more detailed information.
3630 Garbage collection happens automatically if you cons more than
3631 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3635 Lisp_Object pl = Qnil;
3637 int gc_count_vector_total_size = 0;
3639 garbage_collect_1 ();
3641 for (i = 0; i < lrecord_type_count; i++)
3643 if (lcrecord_stats[i].bytes_in_use != 0
3644 || lcrecord_stats[i].bytes_freed != 0
3645 || lcrecord_stats[i].instances_on_free_list != 0)
3648 const char *name = lrecord_implementations_table[i]->name;
3649 int len = strlen (name);
3650 /* save this for the FSFmacs-compatible part of the summary */
3651 if (i == lrecord_vector.lrecord_type_index)
3652 gc_count_vector_total_size =
3653 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3655 sprintf (buf, "%s-storage", name);
3656 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3657 /* Okay, simple pluralization check for `symbol-value-varalias' */
3658 if (name[len-1] == 's')
3659 sprintf (buf, "%ses-freed", name);
3661 sprintf (buf, "%ss-freed", name);
3662 if (lcrecord_stats[i].instances_freed != 0)
3663 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3664 if (name[len-1] == 's')
3665 sprintf (buf, "%ses-on-free-list", name);
3667 sprintf (buf, "%ss-on-free-list", name);
3668 if (lcrecord_stats[i].instances_on_free_list != 0)
3669 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3671 if (name[len-1] == 's')
3672 sprintf (buf, "%ses-used", name);
3674 sprintf (buf, "%ss-used", name);
3675 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3679 HACK_O_MATIC (extent, "extent-storage", pl);
3680 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3681 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3682 HACK_O_MATIC (event, "event-storage", pl);
3683 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3684 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3685 HACK_O_MATIC (marker, "marker-storage", pl);
3686 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3687 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3688 #ifdef LISP_FLOAT_TYPE
3689 HACK_O_MATIC (float, "float-storage", pl);
3690 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3691 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3692 #endif /* LISP_FLOAT_TYPE */
3693 HACK_O_MATIC (string, "string-header-storage", pl);
3694 pl = gc_plist_hack ("long-strings-total-length",
3695 gc_count_string_total_size
3696 - gc_count_short_string_total_size, pl);
3697 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3698 pl = gc_plist_hack ("short-strings-total-length",
3699 gc_count_short_string_total_size, pl);
3700 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3701 pl = gc_plist_hack ("long-strings-used",
3702 gc_count_num_string_in_use
3703 - gc_count_num_short_string_in_use, pl);
3704 pl = gc_plist_hack ("short-strings-used",
3705 gc_count_num_short_string_in_use, pl);
3707 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3708 pl = gc_plist_hack ("compiled-functions-free",
3709 gc_count_num_compiled_function_freelist, pl);
3710 pl = gc_plist_hack ("compiled-functions-used",
3711 gc_count_num_compiled_function_in_use, pl);
3713 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3714 pl = gc_plist_hack ("bit-vectors-total-length",
3715 gc_count_bit_vector_total_size, pl);
3716 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3718 HACK_O_MATIC (symbol, "symbol-storage", pl);
3719 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3720 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3722 HACK_O_MATIC (cons, "cons-storage", pl);
3723 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3724 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3726 /* The things we do for backwards-compatibility */
3728 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3729 make_int (gc_count_num_cons_freelist)),
3730 Fcons (make_int (gc_count_num_symbol_in_use),
3731 make_int (gc_count_num_symbol_freelist)),
3732 Fcons (make_int (gc_count_num_marker_in_use),
3733 make_int (gc_count_num_marker_freelist)),
3734 make_int (gc_count_string_total_size),
3735 make_int (gc_count_vector_total_size),
3740 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3741 Return the number of bytes consed since the last garbage collection.
3742 \"Consed\" is a misnomer in that this actually counts allocation
3743 of all different kinds of objects, not just conses.
3745 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3749 return make_int (consing_since_gc);
3753 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
3754 Return the address of the last byte Emacs has allocated, divided by 1024.
3755 This may be helpful in debugging Emacs's memory usage.
3756 The value is divided by 1024 to make sure it will fit in a lisp integer.
3760 return make_int ((EMACS_INT) sbrk (0) / 1024);
3766 object_dead_p (Lisp_Object obj)
3768 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3769 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3770 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3771 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3772 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3773 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3774 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3777 #ifdef MEMORY_USAGE_STATS
3779 /* Attempt to determine the actual amount of space that is used for
3780 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3782 It seems that the following holds:
3784 1. When using the old allocator (malloc.c):
3786 -- blocks are always allocated in chunks of powers of two. For
3787 each block, there is an overhead of 8 bytes if rcheck is not
3788 defined, 20 bytes if it is defined. In other words, a
3789 one-byte allocation needs 8 bytes of overhead for a total of
3790 9 bytes, and needs to have 16 bytes of memory chunked out for
3793 2. When using the new allocator (gmalloc.c):
3795 -- blocks are always allocated in chunks of powers of two up
3796 to 4096 bytes. Larger blocks are allocated in chunks of
3797 an integral multiple of 4096 bytes. The minimum block
3798 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3799 is defined. There is no per-block overhead, but there
3800 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3803 3. When using the system malloc, anything goes, but they are
3804 generally slower and more space-efficient than the GNU
3805 allocators. One possibly reasonable assumption to make
3806 for want of better data is that sizeof (void *), or maybe
3807 2 * sizeof (void *), is required as overhead and that
3808 blocks are allocated in the minimum required size except
3809 that some minimum block size is imposed (e.g. 16 bytes). */
3812 malloced_storage_size (void *ptr, size_t claimed_size,
3813 struct overhead_stats *stats)
3815 size_t orig_claimed_size = claimed_size;
3819 if (claimed_size < 2 * sizeof (void *))
3820 claimed_size = 2 * sizeof (void *);
3821 # ifdef SUNOS_LOCALTIME_BUG
3822 if (claimed_size < 16)
3825 if (claimed_size < 4096)
3829 /* compute the log base two, more or less, then use it to compute
3830 the block size needed. */
3832 /* It's big, it's heavy, it's wood! */
3833 while ((claimed_size /= 2) != 0)
3836 /* It's better than bad, it's good! */
3842 /* We have to come up with some average about the amount of
3844 if ((size_t) (rand () & 4095) < claimed_size)
3845 claimed_size += 3 * sizeof (void *);
3849 claimed_size += 4095;
3850 claimed_size &= ~4095;
3851 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3854 #elif defined (SYSTEM_MALLOC)
3856 if (claimed_size < 16)
3858 claimed_size += 2 * sizeof (void *);
3860 #else /* old GNU allocator */
3862 # ifdef rcheck /* #### may not be defined here */
3870 /* compute the log base two, more or less, then use it to compute
3871 the block size needed. */
3873 /* It's big, it's heavy, it's wood! */
3874 while ((claimed_size /= 2) != 0)
3877 /* It's better than bad, it's good! */
3885 #endif /* old GNU allocator */
3889 stats->was_requested += orig_claimed_size;
3890 stats->malloc_overhead += claimed_size - orig_claimed_size;
3892 return claimed_size;
3896 fixed_type_block_overhead (size_t size)
3898 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3899 size_t overhead = 0;
3900 size_t storage_size = malloced_storage_size (0, per_block, 0);
3901 while (size >= per_block)
3904 overhead += sizeof (void *) + per_block - storage_size;
3906 if (rand () % per_block < size)
3907 overhead += sizeof (void *) + per_block - storage_size;
3911 #endif /* MEMORY_USAGE_STATS */
3914 /* Initialization */
3916 reinit_alloc_once_early (void)
3918 gc_generation_number[0] = 0;
3919 breathing_space = 0;
3920 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3921 XSETINT (Vgc_message, 0);
3924 all_older_lcrecords = 0;
3926 ignore_malloc_warnings = 1;
3927 #ifdef DOUG_LEA_MALLOC
3928 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3929 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3930 #if 0 /* Moved to emacs.c */
3931 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3934 init_string_alloc ();
3935 init_string_chars_alloc ();
3937 init_symbol_alloc ();
3938 init_compiled_function_alloc ();
3939 #ifdef LISP_FLOAT_TYPE
3940 init_float_alloc ();
3941 #endif /* LISP_FLOAT_TYPE */
3942 init_marker_alloc ();
3943 init_extent_alloc ();
3944 init_event_alloc ();
3946 ignore_malloc_warnings = 0;
3948 staticidx_nodump = 0;
3952 consing_since_gc = 0;
3954 gc_cons_threshold = 500000; /* XEmacs change */
3956 gc_cons_threshold = 15000; /* debugging */
3958 #ifdef VIRT_ADDR_VARIES
3959 malloc_sbrk_unused = 1<<22; /* A large number */
3960 malloc_sbrk_used = 100000; /* as reasonable as any number */
3961 #endif /* VIRT_ADDR_VARIES */
3962 lrecord_uid_counter = 259;
3963 debug_string_purity = 0;
3966 gc_currently_forbidden = 0;
3967 gc_hooks_inhibited = 0;
3969 #ifdef ERROR_CHECK_TYPECHECK
3970 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3973 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3975 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3977 #endif /* ERROR_CHECK_TYPECHECK */
3981 init_alloc_once_early (void)
3983 reinit_alloc_once_early ();
3987 for (i = 0; i < countof (lrecord_implementations_table); i++)
3988 lrecord_implementations_table[i] = 0;
3991 INIT_LRECORD_IMPLEMENTATION (cons);
3992 INIT_LRECORD_IMPLEMENTATION (vector);
3993 INIT_LRECORD_IMPLEMENTATION (string);
3994 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
3999 int pure_bytes_used = 0;
4008 syms_of_alloc (void)
4010 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
4011 defsymbol (&Qpost_gc_hook, "post-gc-hook");
4012 defsymbol (&Qgarbage_collecting, "garbage-collecting");
4017 DEFSUBR (Fbit_vector);
4018 DEFSUBR (Fmake_byte_code);
4019 DEFSUBR (Fmake_list);
4020 DEFSUBR (Fmake_vector);
4021 DEFSUBR (Fmake_bit_vector);
4022 DEFSUBR (Fmake_string);
4024 DEFSUBR (Fmake_symbol);
4025 DEFSUBR (Fmake_marker);
4026 DEFSUBR (Fpurecopy);
4027 DEFSUBR (Fgarbage_collect);
4029 DEFSUBR (Fmemory_limit);
4031 DEFSUBR (Fconsing_since_gc);
4035 vars_of_alloc (void)
4037 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
4038 *Number of bytes of consing between garbage collections.
4039 \"Consing\" is a misnomer in that this actually counts allocation
4040 of all different kinds of objects, not just conses.
4041 Garbage collection can happen automatically once this many bytes have been
4042 allocated since the last garbage collection. All data types count.
4044 Garbage collection happens automatically when `eval' or `funcall' are
4045 called. (Note that `funcall' is called implicitly as part of evaluation.)
4046 By binding this temporarily to a large number, you can effectively
4047 prevent garbage collection during a part of the program.
4049 See also `consing-since-gc'.
4052 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
4053 Number of bytes of sharable Lisp data allocated so far.
4057 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
4058 Number of bytes of unshared memory allocated in this session.
4061 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
4062 Number of bytes of unshared memory remaining available in this session.
4067 DEFVAR_INT ("debug-allocation", &debug_allocation /*
4068 If non-zero, print out information to stderr about all objects allocated.
4069 See also `debug-allocation-backtrace-length'.
4071 debug_allocation = 0;
4073 DEFVAR_INT ("debug-allocation-backtrace-length",
4074 &debug_allocation_backtrace_length /*
4075 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4077 debug_allocation_backtrace_length = 2;
4080 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4081 Non-nil means loading Lisp code in order to dump an executable.
4082 This means that certain objects should be allocated in readonly space.
4085 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4086 Function or functions to be run just before each garbage collection.
4087 Interrupts, garbage collection, and errors are inhibited while this hook
4088 runs, so be extremely careful in what you add here. In particular, avoid
4089 consing, and do not interact with the user.
4091 Vpre_gc_hook = Qnil;
4093 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4094 Function or functions to be run just after each garbage collection.
4095 Interrupts, garbage collection, and errors are inhibited while this hook
4096 runs, so be extremely careful in what you add here. In particular, avoid
4097 consing, and do not interact with the user.
4099 Vpost_gc_hook = Qnil;
4101 DEFVAR_LISP ("gc-message", &Vgc_message /*
4102 String to print to indicate that a garbage collection is in progress.
4103 This is printed in the echo area. If the selected frame is on a
4104 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4105 image instance) in the domain of the selected frame, the mouse pointer
4106 will change instead of this message being printed.
4108 Vgc_message = build_string (gc_default_message);
4110 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4111 Pointer glyph used to indicate that a garbage collection is in progress.
4112 If the selected window is on a window system and this glyph specifies a
4113 value (i.e. a pointer image instance) in the domain of the selected
4114 window, the pointer will be changed as specified during garbage collection.
4115 Otherwise, a message will be printed in the echo area, as controlled
4121 complex_vars_of_alloc (void)
4123 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);