1 /* Storage allocation and gc for XEmacs Lisp interpreter.
2 Copyright (C) 1985-1998 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
4 Copyright (C) 1995, 1996 Ben Wing.
6 This file is part of XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from
28 FSF: Original version; a long time ago.
29 Mly: Significantly rewritten to use new 3-bit tags and
30 nicely abstracted object definitions, for 19.8.
31 JWZ: Improved code to keep track of purespace usage and
32 issue nice purespace and GC stats.
33 Ben Wing: Cleaned up frob-block lrecord code, added error-checking
34 and various changes for Mule, for 19.12.
35 Added bit vectors for 19.13.
36 Added lcrecord lists for 19.14.
37 slb: Lots of work on the purification and dump time code.
38 Synched Doug Lea malloc support from Emacs 20.2.
39 og: Killed the purespace. Portable dumper (moved to dumper.c)
45 #include "backtrace.h"
56 #include "redisplay.h"
57 #include "specifier.h"
61 #include "console-stream.h"
63 #ifdef DOUG_LEA_MALLOC
71 EXFUN (Fgarbage_collect, 0);
73 #if 0 /* this is _way_ too slow to be part of the standard debug options */
74 #if defined(DEBUG_XEMACS) && defined(MULE)
75 #define VERIFY_STRING_CHARS_INTEGRITY
79 /* Define this to use malloc/free with no freelist for all datatypes,
80 the hope being that some debugging tools may help detect
81 freed memory references */
82 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
84 #define ALLOC_NO_POOLS
88 static int debug_allocation;
89 static int debug_allocation_backtrace_length;
92 /* Number of bytes of consing done since the last gc */
93 EMACS_INT consing_since_gc;
94 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
96 #define debug_allocation_backtrace() \
98 if (debug_allocation_backtrace_length > 0) \
99 debug_short_backtrace (debug_allocation_backtrace_length); \
103 #define INCREMENT_CONS_COUNTER(foosize, type) \
105 if (debug_allocation) \
107 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
108 debug_allocation_backtrace (); \
110 INCREMENT_CONS_COUNTER_1 (foosize); \
112 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
114 if (debug_allocation > 1) \
116 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
117 debug_allocation_backtrace (); \
119 INCREMENT_CONS_COUNTER_1 (foosize); \
122 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
123 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
124 INCREMENT_CONS_COUNTER_1 (size)
127 #define DECREMENT_CONS_COUNTER(size) do { \
128 consing_since_gc -= (size); \
129 if (consing_since_gc < 0) \
130 consing_since_gc = 0; \
133 /* Number of bytes of consing since gc before another gc should be done. */
134 EMACS_INT gc_cons_threshold;
136 /* Nonzero during gc */
139 /* Number of times GC has happened at this level or below.
140 * Level 0 is most volatile, contrary to usual convention.
141 * (Of course, there's only one level at present) */
142 EMACS_INT gc_generation_number[1];
144 /* This is just for use by the printer, to allow things to print uniquely */
145 static int lrecord_uid_counter;
147 /* Nonzero when calling certain hooks or doing other things where
149 int gc_currently_forbidden;
152 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
153 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
155 /* "Garbage collecting" */
156 Lisp_Object Vgc_message;
157 Lisp_Object Vgc_pointer_glyph;
158 static const char gc_default_message[] = "Garbage collecting";
159 Lisp_Object Qgarbage_collecting;
161 /* Non-zero means we're in the process of doing the dump */
164 #ifdef ERROR_CHECK_TYPECHECK
166 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
171 c_readonly (Lisp_Object obj)
173 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
177 lisp_readonly (Lisp_Object obj)
179 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
183 /* Maximum amount of C stack to save when a GC happens. */
185 #ifndef MAX_SAVE_STACK
186 #define MAX_SAVE_STACK 0 /* 16000 */
189 /* Non-zero means ignore malloc warnings. Set during initialization. */
190 int ignore_malloc_warnings;
193 static void *breathing_space;
196 release_breathing_space (void)
200 void *tmp = breathing_space;
206 /* malloc calls this if it finds we are near exhausting storage */
208 malloc_warning (const char *str)
210 if (ignore_malloc_warnings)
216 "Killing some buffers may delay running out of memory.\n"
217 "However, certainly by the time you receive the 95%% warning,\n"
218 "you should clean up, kill this Emacs, and start a new one.",
222 /* Called if malloc returns zero */
226 /* Force a GC next time eval is called.
227 It's better to loop garbage-collecting (we might reclaim enough
228 to win) than to loop beeping and barfing "Memory exhausted"
230 consing_since_gc = gc_cons_threshold + 1;
231 release_breathing_space ();
233 /* Flush some histories which might conceivably contain garbalogical
235 if (!NILP (Fboundp (Qvalues)))
236 Fset (Qvalues, Qnil);
237 Vcommand_history = Qnil;
239 error ("Memory exhausted");
242 /* like malloc and realloc but check for no memory left, and block input. */
246 xmalloc (size_t size)
248 void *val = malloc (size);
250 if (!val && (size != 0)) memory_full ();
256 xcalloc (size_t nelem, size_t elsize)
258 void *val = calloc (nelem, elsize);
260 if (!val && (nelem != 0)) memory_full ();
265 xmalloc_and_zero (size_t size)
267 return xcalloc (size, sizeof (char));
272 xrealloc (void *block, size_t size)
274 /* We must call malloc explicitly when BLOCK is 0, since some
275 reallocs don't do this. */
276 void *val = block ? realloc (block, size) : malloc (size);
278 if (!val && (size != 0)) memory_full ();
283 #ifdef ERROR_CHECK_MALLOC
284 xfree_1 (void *block)
289 #ifdef ERROR_CHECK_MALLOC
290 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
291 error until much later on for many system mallocs, such as
292 the one that comes with Solaris 2.3. FMH!! */
293 assert (block != (void *) 0xDEADBEEF);
295 #endif /* ERROR_CHECK_MALLOC */
299 #ifdef ERROR_CHECK_GC
302 typedef unsigned int four_byte_t;
303 #elif SIZEOF_LONG == 4
304 typedef unsigned long four_byte_t;
305 #elif SIZEOF_SHORT == 4
306 typedef unsigned short four_byte_t;
308 What kind of strange-ass system are we running on?
312 deadbeef_memory (void *ptr, size_t size)
314 four_byte_t *ptr4 = (four_byte_t *) ptr;
315 size_t beefs = size >> 2;
317 /* In practice, size will always be a multiple of four. */
319 (*ptr4++) = 0xDEADBEEF;
322 #else /* !ERROR_CHECK_GC */
325 #define deadbeef_memory(ptr, size)
327 #endif /* !ERROR_CHECK_GC */
331 xstrdup (const char *str)
333 int len = strlen (str) + 1; /* for stupid terminating 0 */
335 void *val = xmalloc (len);
336 if (val == 0) return 0;
337 return (char *) memcpy (val, str, len);
342 strdup (const char *s)
346 #endif /* NEED_STRDUP */
350 allocate_lisp_storage (size_t size)
352 return xmalloc (size);
356 /* lcrecords are chained together through their "next" field.
357 After doing the mark phase, GC will walk this linked list
358 and free any lcrecord which hasn't been marked. */
359 static struct lcrecord_header *all_lcrecords;
361 static struct lcrecord_header *all_older_lcrecords;
365 alloc_lcrecord (size_t size, const struct lrecord_implementation *implementation)
367 struct lcrecord_header *lcheader;
370 ((implementation->static_size == 0 ?
371 implementation->size_in_bytes_method != NULL :
372 implementation->static_size == size)
374 (! implementation->basic_p)
376 (! (implementation->hash == NULL && implementation->equal != NULL)));
378 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
379 set_lheader_implementation (&lcheader->lheader, implementation);
380 lcheader->next = all_lcrecords;
381 #if 1 /* mly prefers to see small ID numbers */
382 lcheader->uid = lrecord_uid_counter++;
383 #else /* jwz prefers to see real addrs */
384 lcheader->uid = (int) &lcheader;
387 all_lcrecords = lcheader;
388 INCREMENT_CONS_COUNTER (size, implementation->name);
394 alloc_older_lcrecord (size_t size,
395 const struct lrecord_implementation *implementation)
397 struct lcrecord_header *lcheader;
400 ((implementation->static_size == 0 ?
401 implementation->size_in_bytes_method != NULL :
402 implementation->static_size == size)
404 (! implementation->basic_p)
406 (! (implementation->hash == NULL && implementation->equal != NULL)));
408 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
409 set_lheader_older_implementation (&lcheader->lheader, implementation);
410 lcheader->next = all_older_lcrecords;
411 #if 1 /* mly prefers to see small ID numbers */
412 lcheader->uid = lrecord_uid_counter++;
413 #else /* jwz prefers to see real addrs */
414 lcheader->uid = (int) &lcheader;
417 all_older_lcrecords = lcheader;
418 INCREMENT_CONS_COUNTER (size, implementation->name);
423 #if 0 /* Presently unused */
424 /* Very, very poor man's EGC?
425 * This may be slow and thrash pages all over the place.
426 * Only call it if you really feel you must (and if the
427 * lrecord was fairly recently allocated).
428 * Otherwise, just let the GC do its job -- that's what it's there for
431 free_lcrecord (struct lcrecord_header *lcrecord)
433 if (all_lcrecords == lcrecord)
435 all_lcrecords = lcrecord->next;
439 struct lrecord_header *header = all_lcrecords;
442 struct lrecord_header *next = header->next;
443 if (next == lcrecord)
445 header->next = lrecord->next;
454 if (lrecord->implementation->finalizer)
455 lrecord->implementation->finalizer (lrecord, 0);
463 disksave_object_finalization_1 (void)
465 struct lcrecord_header *header;
467 for (header = all_lcrecords; header; header = header->next)
469 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
471 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
474 for (header = all_older_lcrecords; header; header = header->next)
476 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
478 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
484 /************************************************************************/
485 /* Debugger support */
486 /************************************************************************/
487 /* Give gdb/dbx enough information to decode Lisp Objects. We make
488 sure certain symbols are always defined, so gdb doesn't complain
489 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
490 to see how this is used. */
492 const EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
493 const EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
495 #ifdef USE_UNION_TYPE
496 const unsigned char dbg_USE_UNION_TYPE = 1;
498 const unsigned char dbg_USE_UNION_TYPE = 0;
501 const unsigned char dbg_valbits = VALBITS;
502 const unsigned char dbg_gctypebits = GCTYPEBITS;
504 /* Macros turned into functions for ease of debugging.
505 Debuggers don't know about macros! */
506 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
508 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
510 return EQ (obj1, obj2);
514 /************************************************************************/
515 /* Fixed-size type macros */
516 /************************************************************************/
518 /* For fixed-size types that are commonly used, we malloc() large blocks
519 of memory at a time and subdivide them into chunks of the correct
520 size for an object of that type. This is more efficient than
521 malloc()ing each object separately because we save on malloc() time
522 and overhead due to the fewer number of malloc()ed blocks, and
523 also because we don't need any extra pointers within each object
524 to keep them threaded together for GC purposes. For less common
525 (and frequently large-size) types, we use lcrecords, which are
526 malloc()ed individually and chained together through a pointer
527 in the lcrecord header. lcrecords do not need to be fixed-size
528 (i.e. two objects of the same type need not have the same size;
529 however, the size of a particular object cannot vary dynamically).
530 It is also much easier to create a new lcrecord type because no
531 additional code needs to be added to alloc.c. Finally, lcrecords
532 may be more efficient when there are only a small number of them.
534 The types that are stored in these large blocks (or "frob blocks")
535 are cons, float, compiled-function, symbol, marker, extent, event,
538 Note that strings are special in that they are actually stored in
539 two parts: a structure containing information about the string, and
540 the actual data associated with the string. The former structure
541 (a struct Lisp_String) is a fixed-size structure and is managed the
542 same way as all the other such types. This structure contains a
543 pointer to the actual string data, which is stored in structures of
544 type struct string_chars_block. Each string_chars_block consists
545 of a pointer to a struct Lisp_String, followed by the data for that
546 string, followed by another pointer to a Lisp_String, followed by
547 the data for that string, etc. At GC time, the data in these
548 blocks is compacted by searching sequentially through all the
549 blocks and compressing out any holes created by unmarked strings.
550 Strings that are more than a certain size (bigger than the size of
551 a string_chars_block, although something like half as big might
552 make more sense) are malloc()ed separately and not stored in
553 string_chars_blocks. Furthermore, no one string stretches across
554 two string_chars_blocks.
556 Vectors are each malloc()ed separately, similar to lcrecords.
558 In the following discussion, we use conses, but it applies equally
559 well to the other fixed-size types.
561 We store cons cells inside of cons_blocks, allocating a new
562 cons_block with malloc() whenever necessary. Cons cells reclaimed
563 by GC are put on a free list to be reallocated before allocating
564 any new cons cells from the latest cons_block. Each cons_block is
565 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
566 the versions in malloc.c and gmalloc.c) really allocates in units
567 of powers of two and uses 4 bytes for its own overhead.
569 What GC actually does is to search through all the cons_blocks,
570 from the most recently allocated to the oldest, and put all
571 cons cells that are not marked (whether or not they're already
572 free) on a cons_free_list. The cons_free_list is a stack, and
573 so the cons cells in the oldest-allocated cons_block end up
574 at the head of the stack and are the first to be reallocated.
575 If any cons_block is entirely free, it is freed with free()
576 and its cons cells removed from the cons_free_list. Because
577 the cons_free_list ends up basically in memory order, we have
578 a high locality of reference (assuming a reasonable turnover
579 of allocating and freeing) and have a reasonable probability
580 of entirely freeing up cons_blocks that have been more recently
581 allocated. This stage is called the "sweep stage" of GC, and
582 is executed after the "mark stage", which involves starting
583 from all places that are known to point to in-use Lisp objects
584 (e.g. the obarray, where are all symbols are stored; the
585 current catches and condition-cases; the backtrace list of
586 currently executing functions; the gcpro list; etc.) and
587 recursively marking all objects that are accessible.
589 At the beginning of the sweep stage, the conses in the cons
590 blocks are in one of three states: in use and marked, in use
591 but not marked, and not in use (already freed). Any conses
592 that are marked have been marked in the mark stage just
593 executed, because as part of the sweep stage we unmark any
594 marked objects. The way we tell whether or not a cons cell
595 is in use is through the FREE_STRUCT_P macro. This basically
596 looks at the first 4 bytes (or however many bytes a pointer
597 fits in) to see if all the bits in those bytes are 1. The
598 resulting value (0xFFFFFFFF) is not a valid pointer and is
599 not a valid Lisp_Object. All current fixed-size types have
600 a pointer or Lisp_Object as their first element with the
601 exception of strings; they have a size value, which can
602 never be less than zero, and so 0xFFFFFFFF is invalid for
603 strings as well. Now assuming that a cons cell is in use,
604 the way we tell whether or not it is marked is to look at
605 the mark bit of its car (each Lisp_Object has one bit
606 reserved as a mark bit, in case it's needed). Note that
607 different types of objects use different fields to indicate
608 whether the object is marked, but the principle is the same.
610 Conses on the free_cons_list are threaded through a pointer
611 stored in the bytes directly after the bytes that are set
612 to 0xFFFFFFFF (we cannot overwrite these because the cons
613 is still in a cons_block and needs to remain marked as
614 not in use for the next time that GC happens). This
615 implies that all fixed-size types must be at least big
616 enough to store two pointers, which is indeed the case
617 for all current fixed-size types.
619 Some types of objects need additional "finalization" done
620 when an object is converted from in use to not in use;
621 this is the purpose of the ADDITIONAL_FREE_type macro.
622 For example, markers need to be removed from the chain
623 of markers that is kept in each buffer. This is because
624 markers in a buffer automatically disappear if the marker
625 is no longer referenced anywhere (the same does not
626 apply to extents, however).
628 WARNING: Things are in an extremely bizarre state when
629 the ADDITIONAL_FREE_type macros are called, so beware!
631 When ERROR_CHECK_GC is defined, we do things differently
632 so as to maximize our chances of catching places where
633 there is insufficient GCPROing. The thing we want to
634 avoid is having an object that we're using but didn't
635 GCPRO get freed by GC and then reallocated while we're
636 in the process of using it -- this will result in something
637 seemingly unrelated getting trashed, and is extremely
638 difficult to track down. If the object gets freed but
639 not reallocated, we can usually catch this because we
640 set all bytes of a freed object to 0xDEADBEEF. (The
641 first four bytes, however, are 0xFFFFFFFF, and the next
642 four are a pointer used to chain freed objects together;
643 we play some tricks with this pointer to make it more
644 bogus, so crashes are more likely to occur right away.)
646 We want freed objects to stay free as long as possible,
647 so instead of doing what we do above, we maintain the
648 free objects in a first-in first-out queue. We also
649 don't recompute the free list each GC, unlike above;
650 this ensures that the queue ordering is preserved.
651 [This means that we are likely to have worse locality
652 of reference, and that we can never free a frob block
653 once it's allocated. (Even if we know that all cells
654 in it are free, there's no easy way to remove all those
655 cells from the free list because the objects on the
656 free list are unlikely to be in memory order.)]
657 Furthermore, we never take objects off the free list
658 unless there's a large number (usually 1000, but
659 varies depending on type) of them already on the list.
660 This way, we ensure that an object that gets freed will
661 remain free for the next 1000 (or whatever) times that
662 an object of that type is allocated. */
664 #ifndef MALLOC_OVERHEAD
666 #define MALLOC_OVERHEAD 0
667 #elif defined (rcheck)
668 #define MALLOC_OVERHEAD 20
670 #define MALLOC_OVERHEAD 8
672 #endif /* MALLOC_OVERHEAD */
674 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
675 /* If we released our reserve (due to running out of memory),
676 and we have a fair amount free once again,
677 try to set aside another reserve in case we run out once more.
679 This is called when a relocatable block is freed in ralloc.c. */
680 void refill_memory_reserve (void);
682 refill_memory_reserve (void)
684 if (breathing_space == 0)
685 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
689 #ifdef ALLOC_NO_POOLS
690 # define TYPE_ALLOC_SIZE(type, structtype) 1
692 # define TYPE_ALLOC_SIZE(type, structtype) \
693 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
694 / sizeof (structtype))
695 #endif /* ALLOC_NO_POOLS */
697 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
699 struct type##_block \
701 struct type##_block *prev; \
702 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
705 static struct type##_block *current_##type##_block; \
706 static int current_##type##_block_index; \
708 static structtype *type##_free_list; \
709 static structtype *type##_free_list_tail; \
712 init_##type##_alloc (void) \
714 current_##type##_block = 0; \
715 current_##type##_block_index = \
716 countof (current_##type##_block->block); \
717 type##_free_list = 0; \
718 type##_free_list_tail = 0; \
721 static int gc_count_num_##type##_in_use; \
722 static int gc_count_num_##type##_freelist
724 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
725 if (current_##type##_block_index \
726 == countof (current_##type##_block->block)) \
728 struct type##_block *AFTFB_new = (struct type##_block *) \
729 allocate_lisp_storage (sizeof (struct type##_block)); \
730 AFTFB_new->prev = current_##type##_block; \
731 current_##type##_block = AFTFB_new; \
732 current_##type##_block_index = 0; \
735 &(current_##type##_block->block[current_##type##_block_index++]); \
738 /* Allocate an instance of a type that is stored in blocks.
739 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
742 #ifdef ERROR_CHECK_GC
744 /* Note: if you get crashes in this function, suspect incorrect calls
745 to free_cons() and friends. This happened once because the cons
746 cell was not GC-protected and was getting collected before
747 free_cons() was called. */
749 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
752 if (gc_count_num_##type##_freelist > \
753 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
755 result = type##_free_list; \
756 /* Before actually using the chain pointer, we complement all its \
757 bits; see FREE_FIXED_TYPE(). */ \
759 (structtype *) ~(unsigned long) \
760 (* (structtype **) ((char *) result + sizeof (void *))); \
761 gc_count_num_##type##_freelist--; \
764 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
765 MARK_STRUCT_AS_NOT_FREE (result); \
768 #else /* !ERROR_CHECK_GC */
770 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
773 if (type##_free_list) \
775 result = type##_free_list; \
777 * (structtype **) ((char *) result + sizeof (void *)); \
780 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
781 MARK_STRUCT_AS_NOT_FREE (result); \
784 #endif /* !ERROR_CHECK_GC */
786 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
789 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
790 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
793 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
796 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
797 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
800 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
801 to a Lisp object and invalid as an actual Lisp_Object value. We have
802 to make sure that this value cannot be an integer in Lisp_Object form.
803 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
804 On a 32-bit system, the type bits will be non-zero, making the value
805 be a pointer, and the pointer will be misaligned.
807 Even if Emacs is run on some weirdo system that allows and allocates
808 byte-aligned pointers, this pointer is at the very top of the address
809 space and so it's almost inconceivable that it could ever be valid. */
812 # define INVALID_POINTER_VALUE 0xFFFFFFFF
814 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
816 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
818 You have some weird system and need to supply a reasonable value here.
821 /* The construct (* (void **) (ptr)) would cause aliasing problems
822 with modern optimizing compilers like `gcc -O3 -fstrict-aliasing'.
823 But `char *' can legally alias any pointer. Hence this union trick...
825 It turned out that the union trick was not good enough for xlC -O3;
826 and it is questionable whether it really complies with the C standard.
827 so we use memset instead, which should be safe from optimizations. */
828 typedef union { char c; void *p; } *aliasing_voidpp;
829 #define ALIASING_VOIDPP_DEREFERENCE(ptr) \
830 (((aliasing_voidpp) (ptr))->p)
831 #define FREE_STRUCT_P(ptr) \
832 (ALIASING_VOIDPP_DEREFERENCE (ptr) == (void *) INVALID_POINTER_VALUE)
833 #define MARK_STRUCT_AS_FREE(ptr) memset (ptr, 0xff, sizeof (void *))
834 #define MARK_STRUCT_AS_NOT_FREE(ptr) memset (ptr, 0x00, sizeof (void *))
836 #ifdef ERROR_CHECK_GC
838 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
839 do { if (type##_free_list_tail) \
841 /* When we store the chain pointer, we complement all \
842 its bits; this should significantly increase its \
843 bogosity in case someone tries to use the value, and \
844 should make us dump faster if someone stores something \
845 over the pointer because when it gets un-complemented in \
846 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
847 extremely bogus. */ \
849 ((char *) type##_free_list_tail + sizeof (void *)) = \
850 (structtype *) ~(unsigned long) ptr; \
853 type##_free_list = ptr; \
854 type##_free_list_tail = ptr; \
857 #else /* !ERROR_CHECK_GC */
859 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
860 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
862 type##_free_list = (ptr); \
865 #endif /* !ERROR_CHECK_GC */
867 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
869 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
870 structtype *FFT_ptr = (ptr); \
871 ADDITIONAL_FREE_##type (FFT_ptr); \
872 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
873 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
874 MARK_STRUCT_AS_FREE (FFT_ptr); \
877 /* Like FREE_FIXED_TYPE() but used when we are explicitly
878 freeing a structure through free_cons(), free_marker(), etc.
879 rather than through the normal process of sweeping.
880 We attempt to undo the changes made to the allocation counters
881 as a result of this structure being allocated. This is not
882 completely necessary but helps keep things saner: e.g. this way,
883 repeatedly allocating and freeing a cons will not result in
884 the consing-since-gc counter advancing, which would cause a GC
885 and somewhat defeat the purpose of explicitly freeing. */
887 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
888 do { FREE_FIXED_TYPE (type, structtype, ptr); \
889 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
890 gc_count_num_##type##_freelist++; \
895 /************************************************************************/
896 /* Cons allocation */
897 /************************************************************************/
899 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
900 /* conses are used and freed so often that we set this really high */
901 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
902 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
905 mark_cons (Lisp_Object obj)
907 if (NILP (XCDR (obj)))
910 mark_object (XCAR (obj));
915 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
918 while (internal_equal (XCAR (ob1), XCAR (ob2), depth))
922 if (! CONSP (ob1) || ! CONSP (ob2))
923 return internal_equal (ob1, ob2, depth);
928 static const struct lrecord_description cons_description[] = {
929 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
930 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
934 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
935 mark_cons, print_cons, 0,
938 * No `hash' method needed.
939 * internal_hash knows how to
946 DEFUN ("cons", Fcons, 2, 2, 0, /*
947 Create a new cons, give it CAR and CDR as components, and return it.
951 /* This cannot GC. */
955 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
956 set_lheader_implementation (&c->lheader, &lrecord_cons);
963 /* This is identical to Fcons() but it used for conses that we're
964 going to free later, and is useful when trying to track down
967 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
972 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
973 set_lheader_implementation (&c->lheader, &lrecord_cons);
980 DEFUN ("list", Flist, 0, MANY, 0, /*
981 Return a newly created list with specified arguments as elements.
982 Any number of arguments, even zero arguments, are allowed.
984 (int nargs, Lisp_Object *args))
986 Lisp_Object val = Qnil;
987 Lisp_Object *argp = args + nargs;
990 val = Fcons (*--argp, val);
995 list1 (Lisp_Object obj0)
997 /* This cannot GC. */
998 return Fcons (obj0, Qnil);
1002 list2 (Lisp_Object obj0, Lisp_Object obj1)
1004 /* This cannot GC. */
1005 return Fcons (obj0, Fcons (obj1, Qnil));
1009 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1011 /* This cannot GC. */
1012 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1016 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1018 /* This cannot GC. */
1019 return Fcons (obj0, Fcons (obj1, obj2));
1023 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1025 return Fcons (Fcons (key, value), alist);
1029 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1031 /* This cannot GC. */
1032 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1036 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1039 /* This cannot GC. */
1040 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1044 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1045 Lisp_Object obj4, Lisp_Object obj5)
1047 /* This cannot GC. */
1048 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1051 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1052 Return a new list of length LENGTH, with each element being OBJECT.
1056 CHECK_NATNUM (length);
1059 Lisp_Object val = Qnil;
1060 size_t size = XINT (length);
1063 val = Fcons (object, val);
1069 /************************************************************************/
1070 /* Float allocation */
1071 /************************************************************************/
1073 #ifdef LISP_FLOAT_TYPE
1075 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
1076 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1079 make_float (double float_value)
1084 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
1086 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1087 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1090 set_lheader_implementation (&f->lheader, &lrecord_float);
1091 float_data (f) = float_value;
1096 #endif /* LISP_FLOAT_TYPE */
1099 /************************************************************************/
1100 /* Vector allocation */
1101 /************************************************************************/
1104 mark_vector (Lisp_Object obj)
1106 Lisp_Vector *ptr = XVECTOR (obj);
1107 int len = vector_length (ptr);
1110 for (i = 0; i < len - 1; i++)
1111 mark_object (ptr->contents[i]);
1112 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1116 size_vector (const void *lheader)
1118 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, contents,
1119 ((Lisp_Vector *) lheader)->size);
1123 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1125 int len = XVECTOR_LENGTH (obj1);
1126 if (len != XVECTOR_LENGTH (obj2))
1130 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1131 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1133 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1140 vector_hash (Lisp_Object obj, int depth)
1142 return HASH2 (XVECTOR_LENGTH (obj),
1143 internal_array_hash (XVECTOR_DATA (obj),
1144 XVECTOR_LENGTH (obj),
1148 static const struct lrecord_description vector_description[] = {
1149 { XD_LONG, offsetof (Lisp_Vector, size) },
1150 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1154 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1155 mark_vector, print_vector, 0,
1159 size_vector, Lisp_Vector);
1161 /* #### should allocate `small' vectors from a frob-block */
1162 static Lisp_Vector *
1163 make_vector_internal (size_t sizei)
1165 /* no vector_next */
1166 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1167 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1174 make_vector (size_t length, Lisp_Object object)
1176 Lisp_Vector *vecp = make_vector_internal (length);
1177 Lisp_Object *p = vector_data (vecp);
1184 XSETVECTOR (vector, vecp);
1191 make_older_vector (size_t length, Lisp_Object init)
1193 struct lcrecord_header* orig_all_lcrecords = all_lcrecords;
1196 all_lcrecords = all_older_lcrecords;
1197 obj = make_vector (length, init);
1198 all_older_lcrecords = all_lcrecords;
1199 all_lcrecords = orig_all_lcrecords;
1203 void make_vector_newer_1 (Lisp_Object v);
1205 make_vector_newer_1 (Lisp_Object v)
1207 struct lcrecord_header* lcrecords = all_older_lcrecords;
1209 if (lcrecords != NULL)
1211 if (lcrecords == XPNTR (v))
1213 lcrecords->lheader.older = 0;
1214 all_older_lcrecords = all_older_lcrecords->next;
1215 lcrecords->next = all_lcrecords;
1216 all_lcrecords = lcrecords;
1221 struct lcrecord_header* plcrecords = lcrecords;
1223 lcrecords = lcrecords->next;
1224 while (lcrecords != NULL)
1226 if (lcrecords == XPNTR (v))
1228 lcrecords->lheader.older = 0;
1229 plcrecords->next = lcrecords->next;
1230 lcrecords->next = all_lcrecords;
1231 all_lcrecords = lcrecords;
1234 plcrecords = lcrecords;
1235 lcrecords = lcrecords->next;
1242 make_vector_newer (Lisp_Object v)
1246 for (i = 0; i < XVECTOR_LENGTH (v); i++)
1248 Lisp_Object obj = XVECTOR_DATA (v)[i];
1250 if (VECTORP (obj) && !EQ (obj, v))
1251 make_vector_newer (obj);
1253 make_vector_newer_1 (v);
1257 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1258 Return a new vector of length LENGTH, with each element being OBJECT.
1259 See also the function `vector'.
1263 CONCHECK_NATNUM (length);
1264 return make_vector (XINT (length), object);
1267 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1268 Return a newly created vector with specified arguments as elements.
1269 Any number of arguments, even zero arguments, are allowed.
1271 (int nargs, Lisp_Object *args))
1273 Lisp_Vector *vecp = make_vector_internal (nargs);
1274 Lisp_Object *p = vector_data (vecp);
1281 XSETVECTOR (vector, vecp);
1287 vector1 (Lisp_Object obj0)
1289 return Fvector (1, &obj0);
1293 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1295 Lisp_Object args[2];
1298 return Fvector (2, args);
1302 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1304 Lisp_Object args[3];
1308 return Fvector (3, args);
1311 #if 0 /* currently unused */
1314 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1317 Lisp_Object args[4];
1322 return Fvector (4, args);
1326 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1327 Lisp_Object obj3, Lisp_Object obj4)
1329 Lisp_Object args[5];
1335 return Fvector (5, args);
1339 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1340 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1342 Lisp_Object args[6];
1349 return Fvector (6, args);
1353 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1354 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1357 Lisp_Object args[7];
1365 return Fvector (7, args);
1369 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1370 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1371 Lisp_Object obj6, Lisp_Object obj7)
1373 Lisp_Object args[8];
1382 return Fvector (8, args);
1386 /************************************************************************/
1387 /* Bit Vector allocation */
1388 /************************************************************************/
1390 static Lisp_Object all_bit_vectors;
1392 /* #### should allocate `small' bit vectors from a frob-block */
1393 static Lisp_Bit_Vector *
1394 make_bit_vector_internal (size_t sizei)
1396 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1397 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1398 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1399 set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
1401 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1403 bit_vector_length (p) = sizei;
1404 bit_vector_next (p) = all_bit_vectors;
1405 /* make sure the extra bits in the last long are 0; the calling
1406 functions might not set them. */
1407 p->bits[num_longs - 1] = 0;
1408 XSETBIT_VECTOR (all_bit_vectors, p);
1413 make_bit_vector (size_t length, Lisp_Object bit)
1415 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1416 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1421 memset (p->bits, 0, num_longs * sizeof (long));
1424 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1425 memset (p->bits, ~0, num_longs * sizeof (long));
1426 /* But we have to make sure that the unused bits in the
1427 last long are 0, so that equal/hash is easy. */
1429 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1433 Lisp_Object bit_vector;
1434 XSETBIT_VECTOR (bit_vector, p);
1440 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1443 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1445 for (i = 0; i < length; i++)
1446 set_bit_vector_bit (p, i, bytevec[i]);
1449 Lisp_Object bit_vector;
1450 XSETBIT_VECTOR (bit_vector, p);
1455 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1456 Return a new bit vector of length LENGTH. with each bit set to BIT.
1457 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
1461 CONCHECK_NATNUM (length);
1463 return make_bit_vector (XINT (length), bit);
1466 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1467 Return a newly created bit vector with specified arguments as elements.
1468 Any number of arguments, even zero arguments, are allowed.
1469 Each argument must be one of the integers 0 or 1.
1471 (int nargs, Lisp_Object *args))
1474 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1476 for (i = 0; i < nargs; i++)
1478 CHECK_BIT (args[i]);
1479 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1483 Lisp_Object bit_vector;
1484 XSETBIT_VECTOR (bit_vector, p);
1490 /************************************************************************/
1491 /* Compiled-function allocation */
1492 /************************************************************************/
1494 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1495 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1498 make_compiled_function (void)
1500 Lisp_Compiled_Function *f;
1503 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1504 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
1507 f->specpdl_depth = 0;
1508 f->flags.documentationp = 0;
1509 f->flags.interactivep = 0;
1510 f->flags.domainp = 0; /* I18N3 */
1511 f->instructions = Qzero;
1512 f->constants = Qzero;
1514 f->doc_and_interactive = Qnil;
1515 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1516 f->annotated = Qnil;
1518 XSETCOMPILED_FUNCTION (fun, f);
1522 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1523 Return a new compiled-function object.
1524 Usage: (arglist instructions constants stack-depth
1525 &optional doc-string interactive)
1526 Note that, unlike all other emacs-lisp functions, calling this with five
1527 arguments is NOT the same as calling it with six arguments, the last of
1528 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1529 that this function was defined with `(interactive)'. If the arg is not
1530 specified, then that means the function is not interactive.
1531 This is terrible behavior which is retained for compatibility with old
1532 `.elc' files which expect these semantics.
1534 (int nargs, Lisp_Object *args))
1536 /* In a non-insane world this function would have this arglist...
1537 (arglist instructions constants stack_depth &optional doc_string interactive)
1539 Lisp_Object fun = make_compiled_function ();
1540 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1542 Lisp_Object arglist = args[0];
1543 Lisp_Object instructions = args[1];
1544 Lisp_Object constants = args[2];
1545 Lisp_Object stack_depth = args[3];
1546 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1547 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1549 if (nargs < 4 || nargs > 6)
1550 return Fsignal (Qwrong_number_of_arguments,
1551 list2 (intern ("make-byte-code"), make_int (nargs)));
1553 /* Check for valid formal parameter list now, to allow us to use
1554 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1556 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1558 CHECK_SYMBOL (symbol);
1559 if (EQ (symbol, Qt) ||
1560 EQ (symbol, Qnil) ||
1561 SYMBOL_IS_KEYWORD (symbol))
1562 signal_simple_error_2
1563 ("Invalid constant symbol in formal parameter list",
1567 f->arglist = arglist;
1569 /* `instructions' is a string or a cons (string . int) for a
1570 lazy-loaded function. */
1571 if (CONSP (instructions))
1573 CHECK_STRING (XCAR (instructions));
1574 CHECK_INT (XCDR (instructions));
1578 CHECK_STRING (instructions);
1580 f->instructions = instructions;
1582 if (!NILP (constants))
1583 CHECK_VECTOR (constants);
1584 f->constants = constants;
1586 CHECK_NATNUM (stack_depth);
1587 f->stack_depth = (unsigned short) XINT (stack_depth);
1589 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1590 if (!NILP (Vcurrent_compiled_function_annotation))
1591 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1592 else if (!NILP (Vload_file_name_internal_the_purecopy))
1593 f->annotated = Vload_file_name_internal_the_purecopy;
1594 else if (!NILP (Vload_file_name_internal))
1596 struct gcpro gcpro1;
1597 GCPRO1 (fun); /* don't let fun get reaped */
1598 Vload_file_name_internal_the_purecopy =
1599 Ffile_name_nondirectory (Vload_file_name_internal);
1600 f->annotated = Vload_file_name_internal_the_purecopy;
1603 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1605 /* doc_string may be nil, string, int, or a cons (string . int).
1606 interactive may be list or string (or unbound). */
1607 f->doc_and_interactive = Qunbound;
1609 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1610 f->doc_and_interactive = Vfile_domain;
1612 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1614 f->doc_and_interactive
1615 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1616 Fcons (interactive, f->doc_and_interactive));
1618 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1620 f->doc_and_interactive
1621 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1622 Fcons (doc_string, f->doc_and_interactive));
1624 if (UNBOUNDP (f->doc_and_interactive))
1625 f->doc_and_interactive = Qnil;
1631 /************************************************************************/
1632 /* Symbol allocation */
1633 /************************************************************************/
1635 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1636 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1638 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1639 Return a newly allocated uninterned symbol whose name is NAME.
1640 Its value and function definition are void, and its property list is nil.
1647 CHECK_STRING (name);
1649 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1650 set_lheader_implementation (&p->lheader, &lrecord_symbol);
1651 p->name = XSTRING (name);
1653 p->value = Qunbound;
1654 p->function = Qunbound;
1655 symbol_next (p) = 0;
1656 XSETSYMBOL (val, p);
1661 /************************************************************************/
1662 /* Extent allocation */
1663 /************************************************************************/
1665 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1666 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1669 allocate_extent (void)
1673 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1674 set_lheader_implementation (&e->lheader, &lrecord_extent);
1675 extent_object (e) = Qnil;
1676 set_extent_start (e, -1);
1677 set_extent_end (e, -1);
1682 extent_face (e) = Qnil;
1683 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1684 e->flags.detachable = 1;
1690 /************************************************************************/
1691 /* Event allocation */
1692 /************************************************************************/
1694 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1695 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1698 allocate_event (void)
1703 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1704 set_lheader_implementation (&e->lheader, &lrecord_event);
1711 /************************************************************************/
1712 /* Marker allocation */
1713 /************************************************************************/
1715 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1716 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1718 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1719 Return a new marker which does not point at any place.
1726 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1727 set_lheader_implementation (&p->lheader, &lrecord_marker);
1730 marker_next (p) = 0;
1731 marker_prev (p) = 0;
1732 p->insertion_type = 0;
1733 XSETMARKER (val, p);
1738 noseeum_make_marker (void)
1743 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1744 set_lheader_implementation (&p->lheader, &lrecord_marker);
1747 marker_next (p) = 0;
1748 marker_prev (p) = 0;
1749 p->insertion_type = 0;
1750 XSETMARKER (val, p);
1755 /************************************************************************/
1756 /* String allocation */
1757 /************************************************************************/
1759 /* The data for "short" strings generally resides inside of structs of type
1760 string_chars_block. The Lisp_String structure is allocated just like any
1761 other Lisp object (except for vectors), and these are freelisted when
1762 they get garbage collected. The data for short strings get compacted,
1763 but the data for large strings do not.
1765 Previously Lisp_String structures were relocated, but this caused a lot
1766 of bus-errors because the C code didn't include enough GCPRO's for
1767 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1768 that the reference would get relocated).
1770 This new method makes things somewhat bigger, but it is MUCH safer. */
1772 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1773 /* strings are used and freed quite often */
1774 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1775 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1778 mark_string (Lisp_Object obj)
1780 Lisp_String *ptr = XSTRING (obj);
1782 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1783 flush_cached_extent_info (XCAR (ptr->plist));
1788 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1791 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1792 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1795 static const struct lrecord_description string_description[] = {
1796 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1797 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1798 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1802 /* We store the string's extent info as the first element of the string's
1803 property list; and the string's MODIFF as the first or second element
1804 of the string's property list (depending on whether the extent info
1805 is present), but only if the string has been modified. This is ugly
1806 but it reduces the memory allocated for the string in the vast
1807 majority of cases, where the string is never modified and has no
1810 #### This means you can't use an int as a key in a string's plist. */
1812 static Lisp_Object *
1813 string_plist_ptr (Lisp_Object string)
1815 Lisp_Object *ptr = &XSTRING (string)->plist;
1817 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
1819 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
1825 string_getprop (Lisp_Object string, Lisp_Object property)
1827 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
1831 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
1833 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
1838 string_remprop (Lisp_Object string, Lisp_Object property)
1840 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
1844 string_plist (Lisp_Object string)
1846 return *string_plist_ptr (string);
1849 /* No `finalize', or `hash' methods.
1850 internal_hash() already knows how to hash strings and finalization
1851 is done with the ADDITIONAL_FREE_string macro, which is the
1852 standard way to do finalization when using
1853 SWEEP_FIXED_TYPE_BLOCK(). */
1854 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
1855 mark_string, print_string,
1864 /* String blocks contain this many useful bytes. */
1865 #define STRING_CHARS_BLOCK_SIZE \
1866 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1867 ((2 * sizeof (struct string_chars_block *)) \
1868 + sizeof (EMACS_INT))))
1869 /* Block header for small strings. */
1870 struct string_chars_block
1873 struct string_chars_block *next;
1874 struct string_chars_block *prev;
1875 /* Contents of string_chars_block->string_chars are interleaved
1876 string_chars structures (see below) and the actual string data */
1877 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1880 static struct string_chars_block *first_string_chars_block;
1881 static struct string_chars_block *current_string_chars_block;
1883 /* If SIZE is the length of a string, this returns how many bytes
1884 * the string occupies in string_chars_block->string_chars
1885 * (including alignment padding).
1887 #define STRING_FULLSIZE(size) \
1888 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1889 ALIGNOF (Lisp_String *))
1891 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1892 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1896 Lisp_String *string;
1897 unsigned char chars[1];
1900 struct unused_string_chars
1902 Lisp_String *string;
1907 init_string_chars_alloc (void)
1909 first_string_chars_block = xnew (struct string_chars_block);
1910 first_string_chars_block->prev = 0;
1911 first_string_chars_block->next = 0;
1912 first_string_chars_block->pos = 0;
1913 current_string_chars_block = first_string_chars_block;
1916 static struct string_chars *
1917 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1920 struct string_chars *s_chars;
1923 (countof (current_string_chars_block->string_chars)
1924 - current_string_chars_block->pos))
1926 /* This string can fit in the current string chars block */
1927 s_chars = (struct string_chars *)
1928 (current_string_chars_block->string_chars
1929 + current_string_chars_block->pos);
1930 current_string_chars_block->pos += fullsize;
1934 /* Make a new current string chars block */
1935 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1937 current_string_chars_block->next = new_scb;
1938 new_scb->prev = current_string_chars_block;
1940 current_string_chars_block = new_scb;
1941 new_scb->pos = fullsize;
1942 s_chars = (struct string_chars *)
1943 current_string_chars_block->string_chars;
1946 s_chars->string = string_it_goes_with;
1948 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1954 make_uninit_string (Bytecount length)
1957 EMACS_INT fullsize = STRING_FULLSIZE (length);
1960 assert (length >= 0 && fullsize > 0);
1962 /* Allocate the string header */
1963 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1964 set_lheader_implementation (&s->lheader, &lrecord_string);
1966 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1967 ? xnew_array (Bufbyte, length + 1)
1968 : allocate_string_chars_struct (s, fullsize)->chars);
1970 set_string_length (s, length);
1973 set_string_byte (s, length, 0);
1975 XSETSTRING (val, s);
1979 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1980 static void verify_string_chars_integrity (void);
1983 /* Resize the string S so that DELTA bytes can be inserted starting
1984 at POS. If DELTA < 0, it means deletion starting at POS. If
1985 POS < 0, resize the string but don't copy any characters. Use
1986 this if you're planning on completely overwriting the string.
1990 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
1992 Bytecount oldfullsize, newfullsize;
1993 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1994 verify_string_chars_integrity ();
1997 #ifdef ERROR_CHECK_BUFPOS
2000 assert (pos <= string_length (s));
2002 assert (pos + (-delta) <= string_length (s));
2007 assert ((-delta) <= string_length (s));
2009 #endif /* ERROR_CHECK_BUFPOS */
2012 /* simplest case: no size change. */
2015 if (pos >= 0 && delta < 0)
2016 /* If DELTA < 0, the functions below will delete the characters
2017 before POS. We want to delete characters *after* POS, however,
2018 so convert this to the appropriate form. */
2021 oldfullsize = STRING_FULLSIZE (string_length (s));
2022 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
2024 if (BIG_STRING_FULLSIZE_P (oldfullsize))
2026 if (BIG_STRING_FULLSIZE_P (newfullsize))
2028 /* Both strings are big. We can just realloc().
2029 But careful! If the string is shrinking, we have to
2030 memmove() _before_ realloc(), and if growing, we have to
2031 memmove() _after_ realloc() - otherwise the access is
2032 illegal, and we might crash. */
2033 Bytecount len = string_length (s) + 1 - pos;
2035 if (delta < 0 && pos >= 0)
2036 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
2037 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
2038 string_length (s) + delta + 1));
2039 if (delta > 0 && pos >= 0)
2040 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
2042 else /* String has been demoted from BIG_STRING. */
2045 allocate_string_chars_struct (s, newfullsize)->chars;
2046 Bufbyte *old_data = string_data (s);
2050 memcpy (new_data, old_data, pos);
2051 memcpy (new_data + pos + delta, old_data + pos,
2052 string_length (s) + 1 - pos);
2054 set_string_data (s, new_data);
2058 else /* old string is small */
2060 if (oldfullsize == newfullsize)
2062 /* special case; size change but the necessary
2063 allocation size won't change (up or down; code
2064 somewhere depends on there not being any unused
2065 allocation space, modulo any alignment
2069 Bufbyte *addroff = pos + string_data (s);
2071 memmove (addroff + delta, addroff,
2072 /* +1 due to zero-termination. */
2073 string_length (s) + 1 - pos);
2078 Bufbyte *old_data = string_data (s);
2080 BIG_STRING_FULLSIZE_P (newfullsize)
2081 ? xnew_array (Bufbyte, string_length (s) + delta + 1)
2082 : allocate_string_chars_struct (s, newfullsize)->chars;
2086 memcpy (new_data, old_data, pos);
2087 memcpy (new_data + pos + delta, old_data + pos,
2088 string_length (s) + 1 - pos);
2090 set_string_data (s, new_data);
2093 /* We need to mark this chunk of the string_chars_block
2094 as unused so that compact_string_chars() doesn't
2096 struct string_chars *old_s_chars = (struct string_chars *)
2097 ((char *) old_data - offsetof (struct string_chars, chars));
2098 /* Sanity check to make sure we aren't hosed by strange
2099 alignment/padding. */
2100 assert (old_s_chars->string == s);
2101 MARK_STRUCT_AS_FREE (old_s_chars);
2102 ((struct unused_string_chars *) old_s_chars)->fullsize =
2108 set_string_length (s, string_length (s) + delta);
2109 /* If pos < 0, the string won't be zero-terminated.
2110 Terminate now just to make sure. */
2111 string_data (s)[string_length (s)] = '\0';
2117 XSETSTRING (string, s);
2118 /* We also have to adjust all of the extent indices after the
2119 place we did the change. We say "pos - 1" because
2120 adjust_extents() is exclusive of the starting position
2122 adjust_extents (string, pos - 1, string_length (s),
2126 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2127 verify_string_chars_integrity ();
2134 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2136 Bufbyte newstr[MAX_EMCHAR_LEN];
2137 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2138 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2139 Bytecount newlen = set_charptr_emchar (newstr, c);
2141 if (oldlen != newlen)
2142 resize_string (s, bytoff, newlen - oldlen);
2143 /* Remember, string_data (s) might have changed so we can't cache it. */
2144 memcpy (string_data (s) + bytoff, newstr, newlen);
2149 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2150 Return a new string consisting of LENGTH copies of CHARACTER.
2151 LENGTH must be a non-negative integer.
2153 (length, character))
2155 CHECK_NATNUM (length);
2156 CHECK_CHAR_COERCE_INT (character);
2158 Bufbyte init_str[MAX_EMCHAR_LEN];
2159 int len = set_charptr_emchar (init_str, XCHAR (character));
2160 Lisp_Object val = make_uninit_string (len * XINT (length));
2163 /* Optimize the single-byte case */
2164 memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val));
2168 Bufbyte *ptr = XSTRING_DATA (val);
2170 for (i = XINT (length); i; i--)
2172 Bufbyte *init_ptr = init_str;
2176 case 6: *ptr++ = *init_ptr++;
2177 case 5: *ptr++ = *init_ptr++;
2179 case 4: *ptr++ = *init_ptr++;
2180 case 3: *ptr++ = *init_ptr++;
2181 case 2: *ptr++ = *init_ptr++;
2182 case 1: *ptr++ = *init_ptr++;
2190 DEFUN ("string", Fstring, 0, MANY, 0, /*
2191 Concatenate all the argument characters and make the result a string.
2193 (int nargs, Lisp_Object *args))
2195 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2196 Bufbyte *p = storage;
2198 for (; nargs; nargs--, args++)
2200 Lisp_Object lisp_char = *args;
2201 CHECK_CHAR_COERCE_INT (lisp_char);
2202 p += set_charptr_emchar (p, XCHAR (lisp_char));
2204 return make_string (storage, p - storage);
2208 /* Take some raw memory, which MUST already be in internal format,
2209 and package it up into a Lisp string. */
2211 make_string (const Bufbyte *contents, Bytecount length)
2215 /* Make sure we find out about bad make_string's when they happen */
2216 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2217 bytecount_to_charcount (contents, length); /* Just for the assertions */
2220 val = make_uninit_string (length);
2221 memcpy (XSTRING_DATA (val), contents, length);
2225 /* Take some raw memory, encoded in some external data format,
2226 and convert it into a Lisp string. */
2228 make_ext_string (const Extbyte *contents, EMACS_INT length,
2229 Lisp_Object coding_system)
2232 TO_INTERNAL_FORMAT (DATA, (contents, length),
2233 LISP_STRING, string,
2239 build_string (const char *str)
2241 /* Some strlen's crash and burn if passed null. */
2242 return make_string ((const Bufbyte *) str, (str ? strlen(str) : 0));
2246 build_ext_string (const char *str, Lisp_Object coding_system)
2248 /* Some strlen's crash and burn if passed null. */
2249 return make_ext_string ((const Extbyte *) str, (str ? strlen(str) : 0),
2254 build_translated_string (const char *str)
2256 return build_string (GETTEXT (str));
2260 make_string_nocopy (const Bufbyte *contents, Bytecount length)
2265 /* Make sure we find out about bad make_string_nocopy's when they happen */
2266 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2267 bytecount_to_charcount (contents, length); /* Just for the assertions */
2270 /* Allocate the string header */
2271 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2272 set_lheader_implementation (&s->lheader, &lrecord_string);
2273 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2275 set_string_data (s, (Bufbyte *)contents);
2276 set_string_length (s, length);
2278 XSETSTRING (val, s);
2283 /************************************************************************/
2284 /* lcrecord lists */
2285 /************************************************************************/
2287 /* Lcrecord lists are used to manage the allocation of particular
2288 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2289 malloc() and garbage-collection junk) as much as possible.
2290 It is similar to the Blocktype class.
2294 1) Create an lcrecord-list object using make_lcrecord_list().
2295 This is often done at initialization. Remember to staticpro_nodump
2296 this object! The arguments to make_lcrecord_list() are the
2297 same as would be passed to alloc_lcrecord().
2298 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2299 and pass the lcrecord-list earlier created.
2300 3) When done with the lcrecord, call free_managed_lcrecord().
2301 The standard freeing caveats apply: ** make sure there are no
2302 pointers to the object anywhere! **
2303 4) Calling free_managed_lcrecord() is just like kissing the
2304 lcrecord goodbye as if it were garbage-collected. This means:
2305 -- the contents of the freed lcrecord are undefined, and the
2306 contents of something produced by allocate_managed_lcrecord()
2307 are undefined, just like for alloc_lcrecord().
2308 -- the mark method for the lcrecord's type will *NEVER* be called
2310 -- the finalize method for the lcrecord's type will be called
2311 at the time that free_managed_lcrecord() is called.
2316 mark_lcrecord_list (Lisp_Object obj)
2318 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2319 Lisp_Object chain = list->free;
2321 while (!NILP (chain))
2323 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2324 struct free_lcrecord_header *free_header =
2325 (struct free_lcrecord_header *) lheader;
2328 (/* There should be no other pointers to the free list. */
2329 ! MARKED_RECORD_HEADER_P (lheader)
2331 /* Only lcrecords should be here. */
2332 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
2334 /* Only free lcrecords should be here. */
2335 free_header->lcheader.free
2337 /* The type of the lcrecord must be right. */
2338 LHEADER_IMPLEMENTATION (lheader) == list->implementation
2340 /* So must the size. */
2341 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2342 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
2345 MARK_RECORD_HEADER (lheader);
2346 chain = free_header->chain;
2352 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2353 mark_lcrecord_list, internal_object_printer,
2354 0, 0, 0, 0, struct lcrecord_list);
2356 make_lcrecord_list (size_t size,
2357 const struct lrecord_implementation *implementation)
2359 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2360 &lrecord_lcrecord_list);
2363 p->implementation = implementation;
2366 XSETLCRECORD_LIST (val, p);
2371 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2373 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2374 if (!NILP (list->free))
2376 Lisp_Object val = list->free;
2377 struct free_lcrecord_header *free_header =
2378 (struct free_lcrecord_header *) XPNTR (val);
2380 #ifdef ERROR_CHECK_GC
2381 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2383 /* There should be no other pointers to the free list. */
2384 assert (! MARKED_RECORD_HEADER_P (lheader));
2385 /* Only lcrecords should be here. */
2386 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
2387 /* Only free lcrecords should be here. */
2388 assert (free_header->lcheader.free);
2389 /* The type of the lcrecord must be right. */
2390 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
2391 /* So must the size. */
2392 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2393 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
2394 #endif /* ERROR_CHECK_GC */
2396 list->free = free_header->chain;
2397 free_header->lcheader.free = 0;
2404 XSETOBJ (val, alloc_lcrecord (list->size, list->implementation));
2410 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2412 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2413 struct free_lcrecord_header *free_header =
2414 (struct free_lcrecord_header *) XPNTR (lcrecord);
2415 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2416 const struct lrecord_implementation *implementation
2417 = LHEADER_IMPLEMENTATION (lheader);
2419 /* Make sure the size is correct. This will catch, for example,
2420 putting a window configuration on the wrong free list. */
2421 gc_checking_assert ((implementation->size_in_bytes_method ?
2422 implementation->size_in_bytes_method (lheader) :
2423 implementation->static_size)
2426 if (implementation->finalizer)
2427 implementation->finalizer (lheader, 0);
2428 free_header->chain = list->free;
2429 free_header->lcheader.free = 1;
2430 list->free = lcrecord;
2436 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2437 Kept for compatibility, returns its argument.
2439 Make a copy of OBJECT in pure storage.
2440 Recursively copies contents of vectors and cons cells.
2441 Does not copy symbols.
2449 /************************************************************************/
2450 /* Garbage Collection */
2451 /************************************************************************/
2453 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
2454 Additional ones may be defined by a module (none yet). We leave some
2455 room in `lrecord_implementations_table' for such new lisp object types. */
2456 const struct lrecord_implementation *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT];
2457 unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
2458 /* Object marker functions are in the lrecord_implementation structure.
2459 But copying them to a parallel array is much more cache-friendly.
2460 This hack speeds up (garbage-collect) by about 5%. */
2461 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
2463 struct gcpro *gcprolist;
2465 /* We want the staticpros relocated, but not the pointers found therein.
2466 Hence we use a trivial description, as for pointerless objects. */
2467 static const struct lrecord_description staticpro_description_1[] = {
2471 static const struct struct_description staticpro_description = {
2472 sizeof (Lisp_Object *),
2473 staticpro_description_1
2476 static const struct lrecord_description staticpros_description_1[] = {
2477 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description),
2481 static const struct struct_description staticpros_description = {
2482 sizeof (Lisp_Object_ptr_dynarr),
2483 staticpros_description_1
2486 Lisp_Object_ptr_dynarr *staticpros;
2488 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
2489 garbage collection, and for dumping. */
2491 staticpro (Lisp_Object *varaddress)
2493 Dynarr_add (staticpros, varaddress);
2494 dump_add_root_object (varaddress);
2498 Lisp_Object_ptr_dynarr *staticpros_nodump;
2500 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
2501 garbage collection, but not for dumping. */
2503 staticpro_nodump (Lisp_Object *varaddress)
2505 Dynarr_add (staticpros_nodump, varaddress);
2508 #ifdef ERROR_CHECK_GC
2509 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
2510 struct lrecord_header * GCLI_lh = (lheader); \
2511 assert (GCLI_lh != 0); \
2512 assert (GCLI_lh->type < lrecord_type_count); \
2513 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
2514 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
2515 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
2518 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
2522 /* Mark reference to a Lisp_Object. If the object referred to has not been
2523 seen yet, recursively mark all the references contained in it. */
2526 mark_object (Lisp_Object obj)
2530 /* Checks we used to perform */
2531 /* if (EQ (obj, Qnull_pointer)) return; */
2532 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2533 /* if (PURIFIED (XPNTR (obj))) return; */
2535 if (XTYPE (obj) == Lisp_Type_Record)
2537 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2539 GC_CHECK_LHEADER_INVARIANTS (lheader);
2541 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
2542 ! ((struct lcrecord_header *) lheader)->free);
2544 /* All c_readonly objects have their mark bit set,
2545 so that we only need to check the mark bit here. */
2546 if ( (!MARKED_RECORD_HEADER_P (lheader))
2548 && (!OLDER_RECORD_HEADER_P (lheader))
2552 MARK_RECORD_HEADER (lheader);
2554 if (RECORD_MARKER (lheader))
2556 obj = RECORD_MARKER (lheader) (obj);
2557 if (!NILP (obj)) goto tail_recurse;
2563 /* mark all of the conses in a list and mark the final cdr; but
2564 DO NOT mark the cars.
2566 Use only for internal lists! There should never be other pointers
2567 to the cons cells, because if so, the cars will remain unmarked
2568 even when they maybe should be marked. */
2570 mark_conses_in_list (Lisp_Object obj)
2574 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2576 if (CONS_MARKED_P (XCONS (rest)))
2578 MARK_CONS (XCONS (rest));
2585 /* Find all structures not marked, and free them. */
2587 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2588 static int gc_count_bit_vector_storage;
2589 static int gc_count_num_short_string_in_use;
2590 static int gc_count_string_total_size;
2591 static int gc_count_short_string_total_size;
2593 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2596 /* stats on lcrecords in use - kinda kludgy */
2600 int instances_in_use;
2602 int instances_freed;
2604 int instances_on_free_list;
2605 } lcrecord_stats [countof (lrecord_implementations_table)];
2608 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
2610 unsigned int type_index = h->type;
2612 if (((struct lcrecord_header *) h)->free)
2614 gc_checking_assert (!free_p);
2615 lcrecord_stats[type_index].instances_on_free_list++;
2619 const struct lrecord_implementation *implementation =
2620 LHEADER_IMPLEMENTATION (h);
2622 size_t sz = (implementation->size_in_bytes_method ?
2623 implementation->size_in_bytes_method (h) :
2624 implementation->static_size);
2627 lcrecord_stats[type_index].instances_freed++;
2628 lcrecord_stats[type_index].bytes_freed += sz;
2632 lcrecord_stats[type_index].instances_in_use++;
2633 lcrecord_stats[type_index].bytes_in_use += sz;
2639 /* Free all unmarked records */
2641 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2643 struct lcrecord_header *header;
2645 /* int total_size = 0; */
2647 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2649 /* First go through and call all the finalize methods.
2650 Then go through and free the objects. There used to
2651 be only one loop here, with the call to the finalizer
2652 occurring directly before the xfree() below. That
2653 is marginally faster but much less safe -- if the
2654 finalize method for an object needs to reference any
2655 other objects contained within it (and many do),
2656 we could easily be screwed by having already freed that
2659 for (header = *prev; header; header = header->next)
2661 struct lrecord_header *h = &(header->lheader);
2663 GC_CHECK_LHEADER_INVARIANTS (h);
2665 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
2667 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2668 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2672 for (header = *prev; header; )
2674 struct lrecord_header *h = &(header->lheader);
2675 if (MARKED_RECORD_HEADER_P (h))
2677 if (! C_READONLY_RECORD_HEADER_P (h))
2678 UNMARK_RECORD_HEADER (h);
2680 /* total_size += n->implementation->size_in_bytes (h);*/
2681 /* #### May modify header->next on a C_READONLY lcrecord */
2682 prev = &(header->next);
2684 tick_lcrecord_stats (h, 0);
2688 struct lcrecord_header *next = header->next;
2690 tick_lcrecord_stats (h, 1);
2691 /* used to call finalizer right here. */
2697 /* *total = total_size; */
2702 sweep_bit_vectors_1 (Lisp_Object *prev,
2703 int *used, int *total, int *storage)
2705 Lisp_Object bit_vector;
2708 int total_storage = 0;
2710 /* BIT_VECTORP fails because the objects are marked, which changes
2711 their implementation */
2712 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2714 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2716 if (MARKED_RECORD_P (bit_vector))
2718 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
2719 UNMARK_RECORD_HEADER (&(v->lheader));
2723 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2724 BIT_VECTOR_LONG_STORAGE (len));
2726 /* #### May modify next on a C_READONLY bitvector */
2727 prev = &(bit_vector_next (v));
2732 Lisp_Object next = bit_vector_next (v);
2739 *total = total_size;
2740 *storage = total_storage;
2743 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2744 to make macros prettier. */
2746 #ifdef ERROR_CHECK_GC
2748 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2750 struct typename##_block *SFTB_current; \
2752 int num_free = 0, num_used = 0; \
2754 for (SFTB_current = current_##typename##_block, \
2755 SFTB_limit = current_##typename##_block_index; \
2761 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2763 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2765 if (FREE_STRUCT_P (SFTB_victim)) \
2769 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2773 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2776 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2781 UNMARK_##typename (SFTB_victim); \
2784 SFTB_current = SFTB_current->prev; \
2785 SFTB_limit = countof (current_##typename##_block->block); \
2788 gc_count_num_##typename##_in_use = num_used; \
2789 gc_count_num_##typename##_freelist = num_free; \
2792 #else /* !ERROR_CHECK_GC */
2794 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2796 struct typename##_block *SFTB_current; \
2797 struct typename##_block **SFTB_prev; \
2799 int num_free = 0, num_used = 0; \
2801 typename##_free_list = 0; \
2803 for (SFTB_prev = ¤t_##typename##_block, \
2804 SFTB_current = current_##typename##_block, \
2805 SFTB_limit = current_##typename##_block_index; \
2810 int SFTB_empty = 1; \
2811 obj_type *SFTB_old_free_list = typename##_free_list; \
2813 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2815 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2817 if (FREE_STRUCT_P (SFTB_victim)) \
2820 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2822 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2827 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2830 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2836 UNMARK_##typename (SFTB_victim); \
2841 SFTB_prev = &(SFTB_current->prev); \
2842 SFTB_current = SFTB_current->prev; \
2844 else if (SFTB_current == current_##typename##_block \
2845 && !SFTB_current->prev) \
2847 /* No real point in freeing sole allocation block */ \
2852 struct typename##_block *SFTB_victim_block = SFTB_current; \
2853 if (SFTB_victim_block == current_##typename##_block) \
2854 current_##typename##_block_index \
2855 = countof (current_##typename##_block->block); \
2856 SFTB_current = SFTB_current->prev; \
2858 *SFTB_prev = SFTB_current; \
2859 xfree (SFTB_victim_block); \
2860 /* Restore free list to what it was before victim was swept */ \
2861 typename##_free_list = SFTB_old_free_list; \
2862 num_free -= SFTB_limit; \
2865 SFTB_limit = countof (current_##typename##_block->block); \
2868 gc_count_num_##typename##_in_use = num_used; \
2869 gc_count_num_##typename##_freelist = num_free; \
2872 #endif /* !ERROR_CHECK_GC */
2880 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2881 #define ADDITIONAL_FREE_cons(ptr)
2883 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2886 /* Explicitly free a cons cell. */
2888 free_cons (Lisp_Cons *ptr)
2890 #ifdef ERROR_CHECK_GC
2891 /* If the CAR is not an int, then it will be a pointer, which will
2892 always be four-byte aligned. If this cons cell has already been
2893 placed on the free list, however, its car will probably contain
2894 a chain pointer to the next cons on the list, which has cleverly
2895 had all its 0's and 1's inverted. This allows for a quick
2896 check to make sure we're not freeing something already freed. */
2897 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2898 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2899 #endif /* ERROR_CHECK_GC */
2901 #ifndef ALLOC_NO_POOLS
2902 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2903 #endif /* ALLOC_NO_POOLS */
2906 /* explicitly free a list. You **must make sure** that you have
2907 created all the cons cells that make up this list and that there
2908 are no pointers to any of these cons cells anywhere else. If there
2909 are, you will lose. */
2912 free_list (Lisp_Object list)
2914 Lisp_Object rest, next;
2916 for (rest = list; !NILP (rest); rest = next)
2919 free_cons (XCONS (rest));
2923 /* explicitly free an alist. You **must make sure** that you have
2924 created all the cons cells that make up this alist and that there
2925 are no pointers to any of these cons cells anywhere else. If there
2926 are, you will lose. */
2929 free_alist (Lisp_Object alist)
2931 Lisp_Object rest, next;
2933 for (rest = alist; !NILP (rest); rest = next)
2936 free_cons (XCONS (XCAR (rest)));
2937 free_cons (XCONS (rest));
2942 sweep_compiled_functions (void)
2944 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2945 #define ADDITIONAL_FREE_compiled_function(ptr)
2947 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2951 #ifdef LISP_FLOAT_TYPE
2955 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2956 #define ADDITIONAL_FREE_float(ptr)
2958 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
2960 #endif /* LISP_FLOAT_TYPE */
2963 sweep_symbols (void)
2965 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2966 #define ADDITIONAL_FREE_symbol(ptr)
2968 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
2972 sweep_extents (void)
2974 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2975 #define ADDITIONAL_FREE_extent(ptr)
2977 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2983 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2984 #define ADDITIONAL_FREE_event(ptr)
2986 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
2990 sweep_markers (void)
2992 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2993 #define ADDITIONAL_FREE_marker(ptr) \
2994 do { Lisp_Object tem; \
2995 XSETMARKER (tem, ptr); \
2996 unchain_marker (tem); \
2999 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
3002 /* Explicitly free a marker. */
3004 free_marker (Lisp_Marker *ptr)
3006 /* Perhaps this will catch freeing an already-freed marker. */
3007 gc_checking_assert (ptr->lheader.type == lrecord_type_marker);
3009 #ifndef ALLOC_NO_POOLS
3010 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
3011 #endif /* ALLOC_NO_POOLS */
3015 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
3018 verify_string_chars_integrity (void)
3020 struct string_chars_block *sb;
3022 /* Scan each existing string block sequentially, string by string. */
3023 for (sb = first_string_chars_block; sb; sb = sb->next)
3026 /* POS is the index of the next string in the block. */
3027 while (pos < sb->pos)
3029 struct string_chars *s_chars =
3030 (struct string_chars *) &(sb->string_chars[pos]);
3031 Lisp_String *string;
3035 /* If the string_chars struct is marked as free (i.e. the STRING
3036 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3037 storage. (See below.) */
3039 if (FREE_STRUCT_P (s_chars))
3041 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3046 string = s_chars->string;
3047 /* Must be 32-bit aligned. */
3048 assert ((((int) string) & 3) == 0);
3050 size = string_length (string);
3051 fullsize = STRING_FULLSIZE (size);
3053 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3054 assert (string_data (string) == s_chars->chars);
3057 assert (pos == sb->pos);
3061 #endif /* MULE && ERROR_CHECK_GC */
3063 /* Compactify string chars, relocating the reference to each --
3064 free any empty string_chars_block we see. */
3066 compact_string_chars (void)
3068 struct string_chars_block *to_sb = first_string_chars_block;
3070 struct string_chars_block *from_sb;
3072 /* Scan each existing string block sequentially, string by string. */
3073 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3076 /* FROM_POS is the index of the next string in the block. */
3077 while (from_pos < from_sb->pos)
3079 struct string_chars *from_s_chars =
3080 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3081 struct string_chars *to_s_chars;
3082 Lisp_String *string;
3086 /* If the string_chars struct is marked as free (i.e. the STRING
3087 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3088 storage. This happens under Mule when a string's size changes
3089 in such a way that its fullsize changes. (Strings can change
3090 size because a different-length character can be substituted
3091 for another character.) In this case, after the bogus string
3092 pointer is the "fullsize" of this entry, i.e. how many bytes
3095 if (FREE_STRUCT_P (from_s_chars))
3097 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3098 from_pos += fullsize;
3102 string = from_s_chars->string;
3103 assert (!(FREE_STRUCT_P (string)));
3105 size = string_length (string);
3106 fullsize = STRING_FULLSIZE (size);
3108 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
3110 /* Just skip it if it isn't marked. */
3111 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3113 from_pos += fullsize;
3117 /* If it won't fit in what's left of TO_SB, close TO_SB out
3118 and go on to the next string_chars_block. We know that TO_SB
3119 cannot advance past FROM_SB here since FROM_SB is large enough
3120 to currently contain this string. */
3121 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3123 to_sb->pos = to_pos;
3124 to_sb = to_sb->next;
3128 /* Compute new address of this string
3129 and update TO_POS for the space being used. */
3130 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3132 /* Copy the string_chars to the new place. */
3133 if (from_s_chars != to_s_chars)
3134 memmove (to_s_chars, from_s_chars, fullsize);
3136 /* Relocate FROM_S_CHARS's reference */
3137 set_string_data (string, &(to_s_chars->chars[0]));
3139 from_pos += fullsize;
3144 /* Set current to the last string chars block still used and
3145 free any that follow. */
3147 struct string_chars_block *victim;
3149 for (victim = to_sb->next; victim; )
3151 struct string_chars_block *next = victim->next;
3156 current_string_chars_block = to_sb;
3157 current_string_chars_block->pos = to_pos;
3158 current_string_chars_block->next = 0;
3162 #if 1 /* Hack to debug missing purecopy's */
3163 static int debug_string_purity;
3166 debug_string_purity_print (Lisp_String *p)
3169 Charcount s = string_char_length (p);
3171 for (i = 0; i < s; i++)
3173 Emchar ch = string_char (p, i);
3174 if (ch < 32 || ch >= 126)
3175 stderr_out ("\\%03o", ch);
3176 else if (ch == '\\' || ch == '\"')
3177 stderr_out ("\\%c", ch);
3179 stderr_out ("%c", ch);
3181 stderr_out ("\"\n");
3187 sweep_strings (void)
3189 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3190 int debug = debug_string_purity;
3192 #define UNMARK_string(ptr) do { \
3193 Lisp_String *p = (ptr); \
3194 size_t size = string_length (p); \
3195 UNMARK_RECORD_HEADER (&(p->lheader)); \
3196 num_bytes += size; \
3197 if (!BIG_STRING_SIZE_P (size)) \
3199 num_small_bytes += size; \
3203 debug_string_purity_print (p); \
3205 #define ADDITIONAL_FREE_string(ptr) do { \
3206 size_t size = string_length (ptr); \
3207 if (BIG_STRING_SIZE_P (size)) \
3208 xfree (ptr->data); \
3211 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3213 gc_count_num_short_string_in_use = num_small_used;
3214 gc_count_string_total_size = num_bytes;
3215 gc_count_short_string_total_size = num_small_bytes;
3219 /* I hate duplicating all this crap! */
3221 marked_p (Lisp_Object obj)
3223 /* Checks we used to perform. */
3224 /* if (EQ (obj, Qnull_pointer)) return 1; */
3225 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3226 /* if (PURIFIED (XPNTR (obj))) return 1; */
3228 if (XTYPE (obj) == Lisp_Type_Record)
3230 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3232 GC_CHECK_LHEADER_INVARIANTS (lheader);
3234 return MARKED_RECORD_HEADER_P (lheader);
3242 /* Free all unmarked records. Do this at the very beginning,
3243 before anything else, so that the finalize methods can safely
3244 examine items in the objects. sweep_lcrecords_1() makes
3245 sure to call all the finalize methods *before* freeing anything,
3246 to complete the safety. */
3249 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3252 compact_string_chars ();
3254 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3255 macros) must be *extremely* careful to make sure they're not
3256 referencing freed objects. The only two existing finalize
3257 methods (for strings and markers) pass muster -- the string
3258 finalizer doesn't look at anything but its own specially-
3259 created block, and the marker finalizer only looks at live
3260 buffers (which will never be freed) and at the markers before
3261 and after it in the chain (which, by induction, will never be
3262 freed because if so, they would have already removed themselves
3265 /* Put all unmarked strings on free list, free'ing the string chars
3266 of large unmarked strings */
3269 /* Put all unmarked conses on free list */
3272 /* Free all unmarked bit vectors */
3273 sweep_bit_vectors_1 (&all_bit_vectors,
3274 &gc_count_num_bit_vector_used,
3275 &gc_count_bit_vector_total_size,
3276 &gc_count_bit_vector_storage);
3278 /* Free all unmarked compiled-function objects */
3279 sweep_compiled_functions ();
3281 #ifdef LISP_FLOAT_TYPE
3282 /* Put all unmarked floats on free list */
3286 /* Put all unmarked symbols on free list */
3289 /* Put all unmarked extents on free list */
3292 /* Put all unmarked markers on free list.
3293 Dechain each one first from the buffer into which it points. */
3299 pdump_objects_unmark ();
3303 /* Clearing for disksave. */
3306 disksave_object_finalization (void)
3308 /* It's important that certain information from the environment not get
3309 dumped with the executable (pathnames, environment variables, etc.).
3310 To make it easier to tell when this has happened with strings(1) we
3311 clear some known-to-be-garbage blocks of memory, so that leftover
3312 results of old evaluation don't look like potential problems.
3313 But first we set some notable variables to nil and do one more GC,
3314 to turn those strings into garbage.
3317 /* Yeah, this list is pretty ad-hoc... */
3318 Vprocess_environment = Qnil;
3319 Vexec_directory = Qnil;
3320 Vdata_directory = Qnil;
3321 Vsite_directory = Qnil;
3322 Vdoc_directory = Qnil;
3323 Vconfigure_info_directory = Qnil;
3326 /* Vdump_load_path = Qnil; */
3327 /* Release hash tables for locate_file */
3328 Flocate_file_clear_hashing (Qt);
3329 uncache_home_directory();
3331 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3332 defined(LOADHIST_BUILTIN))
3333 Vload_history = Qnil;
3335 Vshell_file_name = Qnil;
3337 garbage_collect_1 ();
3339 /* Run the disksave finalization methods of all live objects. */
3340 disksave_object_finalization_1 ();
3342 /* Zero out the uninitialized (really, unused) part of the containers
3343 for the live strings. */
3345 struct string_chars_block *scb;
3346 for (scb = first_string_chars_block; scb; scb = scb->next)
3348 int count = sizeof (scb->string_chars) - scb->pos;
3350 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3353 /* from the block's fill ptr to the end */
3354 memset ((scb->string_chars + scb->pos), 0, count);
3359 /* There, that ought to be enough... */
3365 restore_gc_inhibit (Lisp_Object val)
3367 gc_currently_forbidden = XINT (val);
3371 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3372 static int gc_hooks_inhibited;
3376 garbage_collect_1 (void)
3378 #if MAX_SAVE_STACK > 0
3379 char stack_top_variable;
3380 extern char *stack_bottom;
3385 Lisp_Object pre_gc_cursor;
3386 struct gcpro gcpro1;
3389 || gc_currently_forbidden
3391 || preparing_for_armageddon)
3394 /* We used to call selected_frame() here.
3396 The following functions cannot be called inside GC
3397 so we move to after the above tests. */
3400 Lisp_Object device = Fselected_device (Qnil);
3401 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3403 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3405 signal_simple_error ("No frames exist on device", device);
3409 pre_gc_cursor = Qnil;
3412 GCPRO1 (pre_gc_cursor);
3414 /* Very important to prevent GC during any of the following
3415 stuff that might run Lisp code; otherwise, we'll likely
3416 have infinite GC recursion. */
3417 speccount = specpdl_depth ();
3418 record_unwind_protect (restore_gc_inhibit,
3419 make_int (gc_currently_forbidden));
3420 gc_currently_forbidden = 1;
3422 if (!gc_hooks_inhibited)
3423 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3425 /* Now show the GC cursor/message. */
3426 if (!noninteractive)
3428 if (FRAME_WIN_P (f))
3430 Lisp_Object frame = make_frame (f);
3431 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3432 FRAME_SELECTED_WINDOW (f),
3434 pre_gc_cursor = f->pointer;
3435 if (POINTER_IMAGE_INSTANCEP (cursor)
3436 /* don't change if we don't know how to change back. */
3437 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3440 Fset_frame_pointer (frame, cursor);
3444 /* Don't print messages to the stream device. */
3445 if (!cursor_changed && !FRAME_STREAM_P (f))
3447 char *msg = (STRINGP (Vgc_message)
3448 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3450 Lisp_Object args[2], whole_msg;
3451 args[0] = build_string (msg ? msg :
3452 GETTEXT ((const char *) gc_default_message));
3453 args[1] = build_string ("...");
3454 whole_msg = Fconcat (2, args);
3455 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3456 Qgarbage_collecting);
3460 /***** Now we actually start the garbage collection. */
3464 gc_generation_number[0]++;
3466 #if MAX_SAVE_STACK > 0
3468 /* Save a copy of the contents of the stack, for debugging. */
3471 /* Static buffer in which we save a copy of the C stack at each GC. */
3472 static char *stack_copy;
3473 static size_t stack_copy_size;
3475 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3476 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3477 if (stack_size < MAX_SAVE_STACK)
3479 if (stack_copy_size < stack_size)
3481 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3482 stack_copy_size = stack_size;
3486 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3490 #endif /* MAX_SAVE_STACK > 0 */
3492 /* Do some totally ad-hoc resource clearing. */
3493 /* #### generalize this? */
3494 clear_event_resource ();
3495 cleanup_specifiers ();
3497 /* Mark all the special slots that serve as the roots of accessibility. */
3500 Lisp_Object **p = Dynarr_begin (staticpros);
3502 for (count = Dynarr_length (staticpros); count; count--)
3503 mark_object (**p++);
3506 { /* staticpro_nodump() */
3507 Lisp_Object **p = Dynarr_begin (staticpros_nodump);
3509 for (count = Dynarr_length (staticpros_nodump); count; count--)
3510 mark_object (**p++);
3516 for (tail = gcprolist; tail; tail = tail->next)
3517 for (i = 0; i < tail->nvars; i++)
3518 mark_object (tail->var[i]);
3522 struct specbinding *bind;
3523 for (bind = specpdl; bind != specpdl_ptr; bind++)
3525 mark_object (bind->symbol);
3526 mark_object (bind->old_value);
3531 struct catchtag *catch;
3532 for (catch = catchlist; catch; catch = catch->next)
3534 mark_object (catch->tag);
3535 mark_object (catch->val);
3540 struct backtrace *backlist;
3541 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3543 int nargs = backlist->nargs;
3546 mark_object (*backlist->function);
3547 if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */)
3548 mark_object (backlist->args[0]);
3550 for (i = 0; i < nargs; i++)
3551 mark_object (backlist->args[i]);
3556 mark_profiling_info ();
3558 /* OK, now do the after-mark stuff. This is for things that
3559 are only marked when something else is marked (e.g. weak hash tables).
3560 There may be complex dependencies between such objects -- e.g.
3561 a weak hash table might be unmarked, but after processing a later
3562 weak hash table, the former one might get marked. So we have to
3563 iterate until nothing more gets marked. */
3565 while (finish_marking_weak_hash_tables () > 0 ||
3566 finish_marking_weak_lists () > 0)
3569 /* And prune (this needs to be called after everything else has been
3570 marked and before we do any sweeping). */
3571 /* #### this is somewhat ad-hoc and should probably be an object
3573 prune_weak_hash_tables ();
3574 prune_weak_lists ();
3575 prune_specifiers ();
3576 prune_syntax_tables ();
3580 consing_since_gc = 0;
3581 #ifndef DEBUG_XEMACS
3582 /* Allow you to set it really fucking low if you really want ... */
3583 if (gc_cons_threshold < 10000)
3584 gc_cons_threshold = 10000;
3589 /******* End of garbage collection ********/
3591 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3593 /* Now remove the GC cursor/message */
3594 if (!noninteractive)
3597 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3598 else if (!FRAME_STREAM_P (f))
3600 char *msg = (STRINGP (Vgc_message)
3601 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3604 /* Show "...done" only if the echo area would otherwise be empty. */
3605 if (NILP (clear_echo_area (selected_frame (),
3606 Qgarbage_collecting, 0)))
3608 Lisp_Object args[2], whole_msg;
3609 args[0] = build_string (msg ? msg :
3610 GETTEXT ((const char *)
3611 gc_default_message));
3612 args[1] = build_string ("... done");
3613 whole_msg = Fconcat (2, args);
3614 echo_area_message (selected_frame (), (Bufbyte *) 0,
3616 Qgarbage_collecting);
3621 /* now stop inhibiting GC */
3622 unbind_to (speccount, Qnil);
3624 if (!breathing_space)
3626 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3633 /* Debugging aids. */
3636 gc_plist_hack (const char *name, int value, Lisp_Object tail)
3638 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3639 or portable numeric datatypes, or bit-vectors, or characters, or
3640 arrays, or exceptions, or ...) */
3641 return cons3 (intern (name), make_int (value), tail);
3644 #define HACK_O_MATIC(type, name, pl) do { \
3646 struct type##_block *x = current_##type##_block; \
3647 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3648 (pl) = gc_plist_hack ((name), s, (pl)); \
3651 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3652 Reclaim storage for Lisp objects no longer needed.
3653 Return info on amount of space in use:
3654 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3655 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3657 where `PLIST' is a list of alternating keyword/value pairs providing
3658 more detailed information.
3659 Garbage collection happens automatically if you cons more than
3660 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3664 Lisp_Object pl = Qnil;
3666 int gc_count_vector_total_size = 0;
3668 garbage_collect_1 ();
3670 for (i = 0; i < lrecord_type_count; i++)
3672 if (lcrecord_stats[i].bytes_in_use != 0
3673 || lcrecord_stats[i].bytes_freed != 0
3674 || lcrecord_stats[i].instances_on_free_list != 0)
3677 const char *name = lrecord_implementations_table[i]->name;
3678 int len = strlen (name);
3679 /* save this for the FSFmacs-compatible part of the summary */
3680 if (i == lrecord_vector.lrecord_type_index)
3681 gc_count_vector_total_size =
3682 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3684 sprintf (buf, "%s-storage", name);
3685 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3686 /* Okay, simple pluralization check for `symbol-value-varalias' */
3687 if (name[len-1] == 's')
3688 sprintf (buf, "%ses-freed", name);
3690 sprintf (buf, "%ss-freed", name);
3691 if (lcrecord_stats[i].instances_freed != 0)
3692 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3693 if (name[len-1] == 's')
3694 sprintf (buf, "%ses-on-free-list", name);
3696 sprintf (buf, "%ss-on-free-list", name);
3697 if (lcrecord_stats[i].instances_on_free_list != 0)
3698 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3700 if (name[len-1] == 's')
3701 sprintf (buf, "%ses-used", name);
3703 sprintf (buf, "%ss-used", name);
3704 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3708 HACK_O_MATIC (extent, "extent-storage", pl);
3709 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3710 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3711 HACK_O_MATIC (event, "event-storage", pl);
3712 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3713 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3714 HACK_O_MATIC (marker, "marker-storage", pl);
3715 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3716 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3717 #ifdef LISP_FLOAT_TYPE
3718 HACK_O_MATIC (float, "float-storage", pl);
3719 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3720 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3721 #endif /* LISP_FLOAT_TYPE */
3722 HACK_O_MATIC (string, "string-header-storage", pl);
3723 pl = gc_plist_hack ("long-strings-total-length",
3724 gc_count_string_total_size
3725 - gc_count_short_string_total_size, pl);
3726 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3727 pl = gc_plist_hack ("short-strings-total-length",
3728 gc_count_short_string_total_size, pl);
3729 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3730 pl = gc_plist_hack ("long-strings-used",
3731 gc_count_num_string_in_use
3732 - gc_count_num_short_string_in_use, pl);
3733 pl = gc_plist_hack ("short-strings-used",
3734 gc_count_num_short_string_in_use, pl);
3736 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3737 pl = gc_plist_hack ("compiled-functions-free",
3738 gc_count_num_compiled_function_freelist, pl);
3739 pl = gc_plist_hack ("compiled-functions-used",
3740 gc_count_num_compiled_function_in_use, pl);
3742 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3743 pl = gc_plist_hack ("bit-vectors-total-length",
3744 gc_count_bit_vector_total_size, pl);
3745 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3747 HACK_O_MATIC (symbol, "symbol-storage", pl);
3748 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3749 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3751 HACK_O_MATIC (cons, "cons-storage", pl);
3752 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3753 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3755 /* The things we do for backwards-compatibility */
3757 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3758 make_int (gc_count_num_cons_freelist)),
3759 Fcons (make_int (gc_count_num_symbol_in_use),
3760 make_int (gc_count_num_symbol_freelist)),
3761 Fcons (make_int (gc_count_num_marker_in_use),
3762 make_int (gc_count_num_marker_freelist)),
3763 make_int (gc_count_string_total_size),
3764 make_int (gc_count_vector_total_size),
3769 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3770 Return the number of bytes consed since the last garbage collection.
3771 \"Consed\" is a misnomer in that this actually counts allocation
3772 of all different kinds of objects, not just conses.
3774 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3778 return make_int (consing_since_gc);
3782 DEFUN ("memory-limit", Fmemory_limit, 0, 0, 0, /*
3783 Return the address of the last byte Emacs has allocated, divided by 1024.
3784 This may be helpful in debugging Emacs's memory usage.
3785 The value is divided by 1024 to make sure it will fit in a lisp integer.
3789 return make_int ((EMACS_INT) sbrk (0) / 1024);
3795 object_dead_p (Lisp_Object obj)
3797 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3798 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3799 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3800 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3801 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3802 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3803 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3806 #ifdef MEMORY_USAGE_STATS
3808 /* Attempt to determine the actual amount of space that is used for
3809 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3811 It seems that the following holds:
3813 1. When using the old allocator (malloc.c):
3815 -- blocks are always allocated in chunks of powers of two. For
3816 each block, there is an overhead of 8 bytes if rcheck is not
3817 defined, 20 bytes if it is defined. In other words, a
3818 one-byte allocation needs 8 bytes of overhead for a total of
3819 9 bytes, and needs to have 16 bytes of memory chunked out for
3822 2. When using the new allocator (gmalloc.c):
3824 -- blocks are always allocated in chunks of powers of two up
3825 to 4096 bytes. Larger blocks are allocated in chunks of
3826 an integral multiple of 4096 bytes. The minimum block
3827 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3828 is defined. There is no per-block overhead, but there
3829 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3832 3. When using the system malloc, anything goes, but they are
3833 generally slower and more space-efficient than the GNU
3834 allocators. One possibly reasonable assumption to make
3835 for want of better data is that sizeof (void *), or maybe
3836 2 * sizeof (void *), is required as overhead and that
3837 blocks are allocated in the minimum required size except
3838 that some minimum block size is imposed (e.g. 16 bytes). */
3841 malloced_storage_size (void *ptr, size_t claimed_size,
3842 struct overhead_stats *stats)
3844 size_t orig_claimed_size = claimed_size;
3848 if (claimed_size < 2 * sizeof (void *))
3849 claimed_size = 2 * sizeof (void *);
3850 # ifdef SUNOS_LOCALTIME_BUG
3851 if (claimed_size < 16)
3854 if (claimed_size < 4096)
3858 /* compute the log base two, more or less, then use it to compute
3859 the block size needed. */
3861 /* It's big, it's heavy, it's wood! */
3862 while ((claimed_size /= 2) != 0)
3865 /* It's better than bad, it's good! */
3871 /* We have to come up with some average about the amount of
3873 if ((size_t) (rand () & 4095) < claimed_size)
3874 claimed_size += 3 * sizeof (void *);
3878 claimed_size += 4095;
3879 claimed_size &= ~4095;
3880 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3883 #elif defined (SYSTEM_MALLOC)
3885 if (claimed_size < 16)
3887 claimed_size += 2 * sizeof (void *);
3889 #else /* old GNU allocator */
3891 # ifdef rcheck /* #### may not be defined here */
3899 /* compute the log base two, more or less, then use it to compute
3900 the block size needed. */
3902 /* It's big, it's heavy, it's wood! */
3903 while ((claimed_size /= 2) != 0)
3906 /* It's better than bad, it's good! */
3914 #endif /* old GNU allocator */
3918 stats->was_requested += orig_claimed_size;
3919 stats->malloc_overhead += claimed_size - orig_claimed_size;
3921 return claimed_size;
3925 fixed_type_block_overhead (size_t size)
3927 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3928 size_t overhead = 0;
3929 size_t storage_size = malloced_storage_size (0, per_block, 0);
3930 while (size >= per_block)
3933 overhead += sizeof (void *) + per_block - storage_size;
3935 if (rand () % per_block < size)
3936 overhead += sizeof (void *) + per_block - storage_size;
3940 #endif /* MEMORY_USAGE_STATS */
3943 /* Initialization */
3945 reinit_alloc_once_early (void)
3947 gc_generation_number[0] = 0;
3948 breathing_space = 0;
3949 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3950 XSETINT (Vgc_message, 0);
3953 all_older_lcrecords = 0;
3955 ignore_malloc_warnings = 1;
3956 #ifdef DOUG_LEA_MALLOC
3957 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3958 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3959 #if 0 /* Moved to emacs.c */
3960 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3963 init_string_alloc ();
3964 init_string_chars_alloc ();
3966 init_symbol_alloc ();
3967 init_compiled_function_alloc ();
3968 #ifdef LISP_FLOAT_TYPE
3969 init_float_alloc ();
3970 #endif /* LISP_FLOAT_TYPE */
3971 init_marker_alloc ();
3972 init_extent_alloc ();
3973 init_event_alloc ();
3975 ignore_malloc_warnings = 0;
3977 if (staticpros_nodump)
3978 Dynarr_free (staticpros_nodump);
3979 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3980 Dynarr_resize (staticpros_nodump, 100); /* merely a small optimization */
3982 consing_since_gc = 0;
3984 gc_cons_threshold = 500000; /* XEmacs change */
3986 gc_cons_threshold = 15000; /* debugging */
3988 lrecord_uid_counter = 259;
3989 debug_string_purity = 0;
3992 gc_currently_forbidden = 0;
3993 gc_hooks_inhibited = 0;
3995 #ifdef ERROR_CHECK_TYPECHECK
3996 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3999 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
4001 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4003 #endif /* ERROR_CHECK_TYPECHECK */
4007 init_alloc_once_early (void)
4009 reinit_alloc_once_early ();
4013 for (i = 0; i < countof (lrecord_implementations_table); i++)
4014 lrecord_implementations_table[i] = 0;
4017 INIT_LRECORD_IMPLEMENTATION (cons);
4018 INIT_LRECORD_IMPLEMENTATION (vector);
4019 INIT_LRECORD_IMPLEMENTATION (string);
4020 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
4022 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
4023 Dynarr_resize (staticpros, 1410); /* merely a small optimization */
4024 dump_add_root_struct_ptr (&staticpros, &staticpros_description);
4034 syms_of_alloc (void)
4036 DEFSYMBOL (Qpre_gc_hook);
4037 DEFSYMBOL (Qpost_gc_hook);
4038 DEFSYMBOL (Qgarbage_collecting);
4043 DEFSUBR (Fbit_vector);
4044 DEFSUBR (Fmake_byte_code);
4045 DEFSUBR (Fmake_list);
4046 DEFSUBR (Fmake_vector);
4047 DEFSUBR (Fmake_bit_vector);
4048 DEFSUBR (Fmake_string);
4050 DEFSUBR (Fmake_symbol);
4051 DEFSUBR (Fmake_marker);
4052 DEFSUBR (Fpurecopy);
4053 DEFSUBR (Fgarbage_collect);
4055 DEFSUBR (Fmemory_limit);
4057 DEFSUBR (Fconsing_since_gc);
4061 vars_of_alloc (void)
4063 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
4064 *Number of bytes of consing between garbage collections.
4065 \"Consing\" is a misnomer in that this actually counts allocation
4066 of all different kinds of objects, not just conses.
4067 Garbage collection can happen automatically once this many bytes have been
4068 allocated since the last garbage collection. All data types count.
4070 Garbage collection happens automatically when `eval' or `funcall' are
4071 called. (Note that `funcall' is called implicitly as part of evaluation.)
4072 By binding this temporarily to a large number, you can effectively
4073 prevent garbage collection during a part of the program.
4075 See also `consing-since-gc'.
4079 DEFVAR_INT ("debug-allocation", &debug_allocation /*
4080 If non-zero, print out information to stderr about all objects allocated.
4081 See also `debug-allocation-backtrace-length'.
4083 debug_allocation = 0;
4085 DEFVAR_INT ("debug-allocation-backtrace-length",
4086 &debug_allocation_backtrace_length /*
4087 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4089 debug_allocation_backtrace_length = 2;
4092 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4093 Non-nil means loading Lisp code in order to dump an executable.
4094 This means that certain objects should be allocated in readonly space.
4097 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4098 Function or functions to be run just before each garbage collection.
4099 Interrupts, garbage collection, and errors are inhibited while this hook
4100 runs, so be extremely careful in what you add here. In particular, avoid
4101 consing, and do not interact with the user.
4103 Vpre_gc_hook = Qnil;
4105 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4106 Function or functions to be run just after each garbage collection.
4107 Interrupts, garbage collection, and errors are inhibited while this hook
4108 runs, so be extremely careful in what you add here. In particular, avoid
4109 consing, and do not interact with the user.
4111 Vpost_gc_hook = Qnil;
4113 DEFVAR_LISP ("gc-message", &Vgc_message /*
4114 String to print to indicate that a garbage collection is in progress.
4115 This is printed in the echo area. If the selected frame is on a
4116 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4117 image instance) in the domain of the selected frame, the mouse pointer
4118 will change instead of this message being printed.
4120 Vgc_message = build_string (gc_default_message);
4122 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4123 Pointer glyph used to indicate that a garbage collection is in progress.
4124 If the selected window is on a window system and this glyph specifies a
4125 value (i.e. a pointer image instance) in the domain of the selected
4126 window, the pointer will be changed as specified during garbage collection.
4127 Otherwise, a message will be printed in the echo area, as controlled
4133 complex_vars_of_alloc (void)
4135 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);