1 /* Storage allocation and gc for XEmacs Lisp interpreter.
2 Copyright (C) 1985-1998 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
4 Copyright (C) 1995, 1996 Ben Wing.
6 This file is part of XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from
28 FSF: Original version; a long time ago.
29 Mly: Significantly rewritten to use new 3-bit tags and
30 nicely abstracted object definitions, for 19.8.
31 JWZ: Improved code to keep track of purespace usage and
32 issue nice purespace and GC stats.
33 Ben Wing: Cleaned up frob-block lrecord code, added error-checking
34 and various changes for Mule, for 19.12.
35 Added bit vectors for 19.13.
36 Added lcrecord lists for 19.14.
37 slb: Lots of work on the purification and dump time code.
38 Synched Doug Lea malloc support from Emacs 20.2.
39 og: Killed the purespace. Portable dumper (moved to dumper.c)
46 #include "backtrace.h"
57 #include "redisplay.h"
58 #include "specifier.h"
62 #include "console-stream.h"
64 #ifdef DOUG_LEA_MALLOC
72 EXFUN (Fgarbage_collect, 0);
74 #if 0 /* this is _way_ too slow to be part of the standard debug options */
75 #if defined(DEBUG_XEMACS) && defined(MULE)
76 #define VERIFY_STRING_CHARS_INTEGRITY
80 /* Define this to use malloc/free with no freelist for all datatypes,
81 the hope being that some debugging tools may help detect
82 freed memory references */
83 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
85 #define ALLOC_NO_POOLS
89 static int debug_allocation;
90 static int debug_allocation_backtrace_length;
93 /* Number of bytes of consing done since the last gc */
94 EMACS_INT consing_since_gc;
95 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
97 #define debug_allocation_backtrace() \
99 if (debug_allocation_backtrace_length > 0) \
100 debug_short_backtrace (debug_allocation_backtrace_length); \
104 #define INCREMENT_CONS_COUNTER(foosize, type) \
106 if (debug_allocation) \
108 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
109 debug_allocation_backtrace (); \
111 INCREMENT_CONS_COUNTER_1 (foosize); \
113 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
115 if (debug_allocation > 1) \
117 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
118 debug_allocation_backtrace (); \
120 INCREMENT_CONS_COUNTER_1 (foosize); \
123 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
124 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
125 INCREMENT_CONS_COUNTER_1 (size)
128 #define DECREMENT_CONS_COUNTER(size) do { \
129 consing_since_gc -= (size); \
130 if (consing_since_gc < 0) \
131 consing_since_gc = 0; \
134 /* Number of bytes of consing since gc before another gc should be done. */
135 EMACS_INT gc_cons_threshold;
137 /* Nonzero during gc */
140 /* Number of times GC has happened at this level or below.
141 * Level 0 is most volatile, contrary to usual convention.
142 * (Of course, there's only one level at present) */
143 EMACS_INT gc_generation_number[1];
145 /* This is just for use by the printer, to allow things to print uniquely */
146 static int lrecord_uid_counter;
148 /* Nonzero when calling certain hooks or doing other things where
150 int gc_currently_forbidden;
153 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
154 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
156 /* "Garbage collecting" */
157 Lisp_Object Vgc_message;
158 Lisp_Object Vgc_pointer_glyph;
159 static const char gc_default_message[] = "Garbage collecting";
160 Lisp_Object Qgarbage_collecting;
162 #ifndef VIRT_ADDR_VARIES
164 #endif /* VIRT_ADDR_VARIES */
165 EMACS_INT malloc_sbrk_used;
167 #ifndef VIRT_ADDR_VARIES
169 #endif /* VIRT_ADDR_VARIES */
170 EMACS_INT malloc_sbrk_unused;
172 /* Non-zero means we're in the process of doing the dump */
175 #ifdef ERROR_CHECK_TYPECHECK
177 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
182 c_readonly (Lisp_Object obj)
184 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
188 lisp_readonly (Lisp_Object obj)
190 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
194 /* Maximum amount of C stack to save when a GC happens. */
196 #ifndef MAX_SAVE_STACK
197 #define MAX_SAVE_STACK 0 /* 16000 */
200 /* Non-zero means ignore malloc warnings. Set during initialization. */
201 int ignore_malloc_warnings;
204 static void *breathing_space;
207 release_breathing_space (void)
211 void *tmp = breathing_space;
217 /* malloc calls this if it finds we are near exhausting storage */
219 malloc_warning (const char *str)
221 if (ignore_malloc_warnings)
227 "Killing some buffers may delay running out of memory.\n"
228 "However, certainly by the time you receive the 95%% warning,\n"
229 "you should clean up, kill this Emacs, and start a new one.",
233 /* Called if malloc returns zero */
237 /* Force a GC next time eval is called.
238 It's better to loop garbage-collecting (we might reclaim enough
239 to win) than to loop beeping and barfing "Memory exhausted"
241 consing_since_gc = gc_cons_threshold + 1;
242 release_breathing_space ();
244 /* Flush some histories which might conceivably contain garbalogical
246 if (!NILP (Fboundp (Qvalues)))
247 Fset (Qvalues, Qnil);
248 Vcommand_history = Qnil;
250 error ("Memory exhausted");
253 /* like malloc and realloc but check for no memory left, and block input. */
257 xmalloc (size_t size)
259 void *val = malloc (size);
261 if (!val && (size != 0)) memory_full ();
267 xcalloc (size_t nelem, size_t elsize)
269 void *val = calloc (nelem, elsize);
271 if (!val && (nelem != 0)) memory_full ();
276 xmalloc_and_zero (size_t size)
278 return xcalloc (size, sizeof (char));
283 xrealloc (void *block, size_t size)
285 /* We must call malloc explicitly when BLOCK is 0, since some
286 reallocs don't do this. */
287 void *val = block ? realloc (block, size) : malloc (size);
289 if (!val && (size != 0)) memory_full ();
294 #ifdef ERROR_CHECK_MALLOC
295 xfree_1 (void *block)
300 #ifdef ERROR_CHECK_MALLOC
301 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
302 error until much later on for many system mallocs, such as
303 the one that comes with Solaris 2.3. FMH!! */
304 assert (block != (void *) 0xDEADBEEF);
306 #endif /* ERROR_CHECK_MALLOC */
310 #ifdef ERROR_CHECK_GC
313 typedef unsigned int four_byte_t;
314 #elif SIZEOF_LONG == 4
315 typedef unsigned long four_byte_t;
316 #elif SIZEOF_SHORT == 4
317 typedef unsigned short four_byte_t;
319 What kind of strange-ass system are we running on?
323 deadbeef_memory (void *ptr, size_t size)
325 four_byte_t *ptr4 = (four_byte_t *) ptr;
326 size_t beefs = size >> 2;
328 /* In practice, size will always be a multiple of four. */
330 (*ptr4++) = 0xDEADBEEF;
333 #else /* !ERROR_CHECK_GC */
336 #define deadbeef_memory(ptr, size)
338 #endif /* !ERROR_CHECK_GC */
342 xstrdup (const char *str)
344 int len = strlen (str) + 1; /* for stupid terminating 0 */
346 void *val = xmalloc (len);
347 if (val == 0) return 0;
348 return (char *) memcpy (val, str, len);
353 strdup (const char *s)
357 #endif /* NEED_STRDUP */
361 allocate_lisp_storage (size_t size)
363 return xmalloc (size);
367 /* lcrecords are chained together through their "next" field.
368 After doing the mark phase, GC will walk this linked list
369 and free any lcrecord which hasn't been marked. */
370 static struct lcrecord_header *all_lcrecords;
372 static struct lcrecord_header *all_older_lcrecords;
376 alloc_lcrecord (size_t size, const struct lrecord_implementation *implementation)
378 struct lcrecord_header *lcheader;
381 ((implementation->static_size == 0 ?
382 implementation->size_in_bytes_method != NULL :
383 implementation->static_size == size)
385 (! implementation->basic_p)
387 (! (implementation->hash == NULL && implementation->equal != NULL)));
389 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
390 set_lheader_implementation (&lcheader->lheader, implementation);
391 lcheader->next = all_lcrecords;
392 #if 1 /* mly prefers to see small ID numbers */
393 lcheader->uid = lrecord_uid_counter++;
394 #else /* jwz prefers to see real addrs */
395 lcheader->uid = (int) &lcheader;
398 all_lcrecords = lcheader;
399 INCREMENT_CONS_COUNTER (size, implementation->name);
405 alloc_older_lcrecord (size_t size,
406 const struct lrecord_implementation *implementation)
408 struct lcrecord_header *lcheader;
411 ((implementation->static_size == 0 ?
412 implementation->size_in_bytes_method != NULL :
413 implementation->static_size == size)
415 (! implementation->basic_p)
417 (! (implementation->hash == NULL && implementation->equal != NULL)));
419 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
420 set_lheader_older_implementation (&lcheader->lheader, implementation);
421 lcheader->next = all_older_lcrecords;
422 #if 1 /* mly prefers to see small ID numbers */
423 lcheader->uid = lrecord_uid_counter++;
424 #else /* jwz prefers to see real addrs */
425 lcheader->uid = (int) &lcheader;
428 all_older_lcrecords = lcheader;
429 INCREMENT_CONS_COUNTER (size, implementation->name);
434 #if 0 /* Presently unused */
435 /* Very, very poor man's EGC?
436 * This may be slow and thrash pages all over the place.
437 * Only call it if you really feel you must (and if the
438 * lrecord was fairly recently allocated).
439 * Otherwise, just let the GC do its job -- that's what it's there for
442 free_lcrecord (struct lcrecord_header *lcrecord)
444 if (all_lcrecords == lcrecord)
446 all_lcrecords = lcrecord->next;
450 struct lrecord_header *header = all_lcrecords;
453 struct lrecord_header *next = header->next;
454 if (next == lcrecord)
456 header->next = lrecord->next;
465 if (lrecord->implementation->finalizer)
466 lrecord->implementation->finalizer (lrecord, 0);
474 disksave_object_finalization_1 (void)
476 struct lcrecord_header *header;
478 for (header = all_lcrecords; header; header = header->next)
480 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
482 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
485 for (header = all_older_lcrecords; header; header = header->next)
487 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
489 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
495 /************************************************************************/
496 /* Debugger support */
497 /************************************************************************/
498 /* Give gdb/dbx enough information to decode Lisp Objects. We make
499 sure certain symbols are always defined, so gdb doesn't complain
500 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
501 to see how this is used. */
503 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
504 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
506 #ifdef USE_UNION_TYPE
507 unsigned char dbg_USE_UNION_TYPE = 1;
509 unsigned char dbg_USE_UNION_TYPE = 0;
512 unsigned char dbg_valbits = VALBITS;
513 unsigned char dbg_gctypebits = GCTYPEBITS;
515 /* Macros turned into functions for ease of debugging.
516 Debuggers don't know about macros! */
517 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
519 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
521 return EQ (obj1, obj2);
525 /************************************************************************/
526 /* Fixed-size type macros */
527 /************************************************************************/
529 /* For fixed-size types that are commonly used, we malloc() large blocks
530 of memory at a time and subdivide them into chunks of the correct
531 size for an object of that type. This is more efficient than
532 malloc()ing each object separately because we save on malloc() time
533 and overhead due to the fewer number of malloc()ed blocks, and
534 also because we don't need any extra pointers within each object
535 to keep them threaded together for GC purposes. For less common
536 (and frequently large-size) types, we use lcrecords, which are
537 malloc()ed individually and chained together through a pointer
538 in the lcrecord header. lcrecords do not need to be fixed-size
539 (i.e. two objects of the same type need not have the same size;
540 however, the size of a particular object cannot vary dynamically).
541 It is also much easier to create a new lcrecord type because no
542 additional code needs to be added to alloc.c. Finally, lcrecords
543 may be more efficient when there are only a small number of them.
545 The types that are stored in these large blocks (or "frob blocks")
546 are cons, float, compiled-function, symbol, marker, extent, event,
549 Note that strings are special in that they are actually stored in
550 two parts: a structure containing information about the string, and
551 the actual data associated with the string. The former structure
552 (a struct Lisp_String) is a fixed-size structure and is managed the
553 same way as all the other such types. This structure contains a
554 pointer to the actual string data, which is stored in structures of
555 type struct string_chars_block. Each string_chars_block consists
556 of a pointer to a struct Lisp_String, followed by the data for that
557 string, followed by another pointer to a Lisp_String, followed by
558 the data for that string, etc. At GC time, the data in these
559 blocks is compacted by searching sequentially through all the
560 blocks and compressing out any holes created by unmarked strings.
561 Strings that are more than a certain size (bigger than the size of
562 a string_chars_block, although something like half as big might
563 make more sense) are malloc()ed separately and not stored in
564 string_chars_blocks. Furthermore, no one string stretches across
565 two string_chars_blocks.
567 Vectors are each malloc()ed separately, similar to lcrecords.
569 In the following discussion, we use conses, but it applies equally
570 well to the other fixed-size types.
572 We store cons cells inside of cons_blocks, allocating a new
573 cons_block with malloc() whenever necessary. Cons cells reclaimed
574 by GC are put on a free list to be reallocated before allocating
575 any new cons cells from the latest cons_block. Each cons_block is
576 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
577 the versions in malloc.c and gmalloc.c) really allocates in units
578 of powers of two and uses 4 bytes for its own overhead.
580 What GC actually does is to search through all the cons_blocks,
581 from the most recently allocated to the oldest, and put all
582 cons cells that are not marked (whether or not they're already
583 free) on a cons_free_list. The cons_free_list is a stack, and
584 so the cons cells in the oldest-allocated cons_block end up
585 at the head of the stack and are the first to be reallocated.
586 If any cons_block is entirely free, it is freed with free()
587 and its cons cells removed from the cons_free_list. Because
588 the cons_free_list ends up basically in memory order, we have
589 a high locality of reference (assuming a reasonable turnover
590 of allocating and freeing) and have a reasonable probability
591 of entirely freeing up cons_blocks that have been more recently
592 allocated. This stage is called the "sweep stage" of GC, and
593 is executed after the "mark stage", which involves starting
594 from all places that are known to point to in-use Lisp objects
595 (e.g. the obarray, where are all symbols are stored; the
596 current catches and condition-cases; the backtrace list of
597 currently executing functions; the gcpro list; etc.) and
598 recursively marking all objects that are accessible.
600 At the beginning of the sweep stage, the conses in the cons
601 blocks are in one of three states: in use and marked, in use
602 but not marked, and not in use (already freed). Any conses
603 that are marked have been marked in the mark stage just
604 executed, because as part of the sweep stage we unmark any
605 marked objects. The way we tell whether or not a cons cell
606 is in use is through the FREE_STRUCT_P macro. This basically
607 looks at the first 4 bytes (or however many bytes a pointer
608 fits in) to see if all the bits in those bytes are 1. The
609 resulting value (0xFFFFFFFF) is not a valid pointer and is
610 not a valid Lisp_Object. All current fixed-size types have
611 a pointer or Lisp_Object as their first element with the
612 exception of strings; they have a size value, which can
613 never be less than zero, and so 0xFFFFFFFF is invalid for
614 strings as well. Now assuming that a cons cell is in use,
615 the way we tell whether or not it is marked is to look at
616 the mark bit of its car (each Lisp_Object has one bit
617 reserved as a mark bit, in case it's needed). Note that
618 different types of objects use different fields to indicate
619 whether the object is marked, but the principle is the same.
621 Conses on the free_cons_list are threaded through a pointer
622 stored in the bytes directly after the bytes that are set
623 to 0xFFFFFFFF (we cannot overwrite these because the cons
624 is still in a cons_block and needs to remain marked as
625 not in use for the next time that GC happens). This
626 implies that all fixed-size types must be at least big
627 enough to store two pointers, which is indeed the case
628 for all current fixed-size types.
630 Some types of objects need additional "finalization" done
631 when an object is converted from in use to not in use;
632 this is the purpose of the ADDITIONAL_FREE_type macro.
633 For example, markers need to be removed from the chain
634 of markers that is kept in each buffer. This is because
635 markers in a buffer automatically disappear if the marker
636 is no longer referenced anywhere (the same does not
637 apply to extents, however).
639 WARNING: Things are in an extremely bizarre state when
640 the ADDITIONAL_FREE_type macros are called, so beware!
642 When ERROR_CHECK_GC is defined, we do things differently
643 so as to maximize our chances of catching places where
644 there is insufficient GCPROing. The thing we want to
645 avoid is having an object that we're using but didn't
646 GCPRO get freed by GC and then reallocated while we're
647 in the process of using it -- this will result in something
648 seemingly unrelated getting trashed, and is extremely
649 difficult to track down. If the object gets freed but
650 not reallocated, we can usually catch this because we
651 set all bytes of a freed object to 0xDEADBEEF. (The
652 first four bytes, however, are 0xFFFFFFFF, and the next
653 four are a pointer used to chain freed objects together;
654 we play some tricks with this pointer to make it more
655 bogus, so crashes are more likely to occur right away.)
657 We want freed objects to stay free as long as possible,
658 so instead of doing what we do above, we maintain the
659 free objects in a first-in first-out queue. We also
660 don't recompute the free list each GC, unlike above;
661 this ensures that the queue ordering is preserved.
662 [This means that we are likely to have worse locality
663 of reference, and that we can never free a frob block
664 once it's allocated. (Even if we know that all cells
665 in it are free, there's no easy way to remove all those
666 cells from the free list because the objects on the
667 free list are unlikely to be in memory order.)]
668 Furthermore, we never take objects off the free list
669 unless there's a large number (usually 1000, but
670 varies depending on type) of them already on the list.
671 This way, we ensure that an object that gets freed will
672 remain free for the next 1000 (or whatever) times that
673 an object of that type is allocated. */
675 #ifndef MALLOC_OVERHEAD
677 #define MALLOC_OVERHEAD 0
678 #elif defined (rcheck)
679 #define MALLOC_OVERHEAD 20
681 #define MALLOC_OVERHEAD 8
683 #endif /* MALLOC_OVERHEAD */
685 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
686 /* If we released our reserve (due to running out of memory),
687 and we have a fair amount free once again,
688 try to set aside another reserve in case we run out once more.
690 This is called when a relocatable block is freed in ralloc.c. */
691 void refill_memory_reserve (void);
693 refill_memory_reserve (void)
695 if (breathing_space == 0)
696 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
700 #ifdef ALLOC_NO_POOLS
701 # define TYPE_ALLOC_SIZE(type, structtype) 1
703 # define TYPE_ALLOC_SIZE(type, structtype) \
704 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
705 / sizeof (structtype))
706 #endif /* ALLOC_NO_POOLS */
708 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
710 struct type##_block \
712 struct type##_block *prev; \
713 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
716 static struct type##_block *current_##type##_block; \
717 static int current_##type##_block_index; \
719 static structtype *type##_free_list; \
720 static structtype *type##_free_list_tail; \
723 init_##type##_alloc (void) \
725 current_##type##_block = 0; \
726 current_##type##_block_index = \
727 countof (current_##type##_block->block); \
728 type##_free_list = 0; \
729 type##_free_list_tail = 0; \
732 static int gc_count_num_##type##_in_use; \
733 static int gc_count_num_##type##_freelist
735 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
736 if (current_##type##_block_index \
737 == countof (current_##type##_block->block)) \
739 struct type##_block *AFTFB_new = (struct type##_block *) \
740 allocate_lisp_storage (sizeof (struct type##_block)); \
741 AFTFB_new->prev = current_##type##_block; \
742 current_##type##_block = AFTFB_new; \
743 current_##type##_block_index = 0; \
746 &(current_##type##_block->block[current_##type##_block_index++]); \
749 /* Allocate an instance of a type that is stored in blocks.
750 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
753 #ifdef ERROR_CHECK_GC
755 /* Note: if you get crashes in this function, suspect incorrect calls
756 to free_cons() and friends. This happened once because the cons
757 cell was not GC-protected and was getting collected before
758 free_cons() was called. */
760 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
763 if (gc_count_num_##type##_freelist > \
764 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
766 result = type##_free_list; \
767 /* Before actually using the chain pointer, we complement all its \
768 bits; see FREE_FIXED_TYPE(). */ \
770 (structtype *) ~(unsigned long) \
771 (* (structtype **) ((char *) result + sizeof (void *))); \
772 gc_count_num_##type##_freelist--; \
775 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
776 MARK_STRUCT_AS_NOT_FREE (result); \
779 #else /* !ERROR_CHECK_GC */
781 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
784 if (type##_free_list) \
786 result = type##_free_list; \
788 * (structtype **) ((char *) result + sizeof (void *)); \
791 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
792 MARK_STRUCT_AS_NOT_FREE (result); \
795 #endif /* !ERROR_CHECK_GC */
797 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
800 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
801 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
804 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
807 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
808 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
811 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
812 to a Lisp object and invalid as an actual Lisp_Object value. We have
813 to make sure that this value cannot be an integer in Lisp_Object form.
814 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
815 On a 32-bit system, the type bits will be non-zero, making the value
816 be a pointer, and the pointer will be misaligned.
818 Even if Emacs is run on some weirdo system that allows and allocates
819 byte-aligned pointers, this pointer is at the very top of the address
820 space and so it's almost inconceivable that it could ever be valid. */
823 # define INVALID_POINTER_VALUE 0xFFFFFFFF
825 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
827 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
829 You have some weird system and need to supply a reasonable value here.
832 /* The construct (* (void **) (ptr)) would cause aliasing problems
833 with modern optimizing compilers like `gcc -O3 -fstrict-aliasing'.
834 But `char *' can legally alias any pointer. Hence this union trick. */
835 typedef union { char c; void *p; } *aliasing_voidpp;
836 #define ALIASING_VOIDPP_DEREFERENCE(ptr) \
837 (((aliasing_voidpp) (ptr))->p)
838 #define FREE_STRUCT_P(ptr) \
839 (ALIASING_VOIDPP_DEREFERENCE (ptr) == (void *) INVALID_POINTER_VALUE)
840 #define MARK_STRUCT_AS_FREE(ptr) \
841 (ALIASING_VOIDPP_DEREFERENCE (ptr) = (void *) INVALID_POINTER_VALUE)
842 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
843 (ALIASING_VOIDPP_DEREFERENCE (ptr) = 0)
845 #ifdef ERROR_CHECK_GC
847 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
848 do { if (type##_free_list_tail) \
850 /* When we store the chain pointer, we complement all \
851 its bits; this should significantly increase its \
852 bogosity in case someone tries to use the value, and \
853 should make us dump faster if someone stores something \
854 over the pointer because when it gets un-complemented in \
855 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
856 extremely bogus. */ \
858 ((char *) type##_free_list_tail + sizeof (void *)) = \
859 (structtype *) ~(unsigned long) ptr; \
862 type##_free_list = ptr; \
863 type##_free_list_tail = ptr; \
866 #else /* !ERROR_CHECK_GC */
868 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
869 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
871 type##_free_list = (ptr); \
874 #endif /* !ERROR_CHECK_GC */
876 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
878 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
879 structtype *FFT_ptr = (ptr); \
880 ADDITIONAL_FREE_##type (FFT_ptr); \
881 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
882 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
883 MARK_STRUCT_AS_FREE (FFT_ptr); \
886 /* Like FREE_FIXED_TYPE() but used when we are explicitly
887 freeing a structure through free_cons(), free_marker(), etc.
888 rather than through the normal process of sweeping.
889 We attempt to undo the changes made to the allocation counters
890 as a result of this structure being allocated. This is not
891 completely necessary but helps keep things saner: e.g. this way,
892 repeatedly allocating and freeing a cons will not result in
893 the consing-since-gc counter advancing, which would cause a GC
894 and somewhat defeat the purpose of explicitly freeing. */
896 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
897 do { FREE_FIXED_TYPE (type, structtype, ptr); \
898 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
899 gc_count_num_##type##_freelist++; \
904 /************************************************************************/
905 /* Cons allocation */
906 /************************************************************************/
908 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
909 /* conses are used and freed so often that we set this really high */
910 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
911 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
914 mark_cons (Lisp_Object obj)
916 if (NILP (XCDR (obj)))
919 mark_object (XCAR (obj));
924 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
927 while (internal_equal (XCAR (ob1), XCAR (ob2), depth))
931 if (! CONSP (ob1) || ! CONSP (ob2))
932 return internal_equal (ob1, ob2, depth);
937 static const struct lrecord_description cons_description[] = {
938 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
939 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
943 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
944 mark_cons, print_cons, 0,
947 * No `hash' method needed.
948 * internal_hash knows how to
955 DEFUN ("cons", Fcons, 2, 2, 0, /*
956 Create a new cons, give it CAR and CDR as components, and return it.
960 /* This cannot GC. */
964 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
965 set_lheader_implementation (&c->lheader, &lrecord_cons);
972 /* This is identical to Fcons() but it used for conses that we're
973 going to free later, and is useful when trying to track down
976 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
981 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
982 set_lheader_implementation (&c->lheader, &lrecord_cons);
989 DEFUN ("list", Flist, 0, MANY, 0, /*
990 Return a newly created list with specified arguments as elements.
991 Any number of arguments, even zero arguments, are allowed.
993 (int nargs, Lisp_Object *args))
995 Lisp_Object val = Qnil;
996 Lisp_Object *argp = args + nargs;
999 val = Fcons (*--argp, val);
1004 list1 (Lisp_Object obj0)
1006 /* This cannot GC. */
1007 return Fcons (obj0, Qnil);
1011 list2 (Lisp_Object obj0, Lisp_Object obj1)
1013 /* This cannot GC. */
1014 return Fcons (obj0, Fcons (obj1, Qnil));
1018 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1020 /* This cannot GC. */
1021 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1025 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1027 /* This cannot GC. */
1028 return Fcons (obj0, Fcons (obj1, obj2));
1032 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1034 return Fcons (Fcons (key, value), alist);
1038 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1040 /* This cannot GC. */
1041 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1045 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1048 /* This cannot GC. */
1049 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1053 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1054 Lisp_Object obj4, Lisp_Object obj5)
1056 /* This cannot GC. */
1057 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1060 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1061 Return a new list of length LENGTH, with each element being INIT.
1065 CHECK_NATNUM (length);
1068 Lisp_Object val = Qnil;
1069 size_t size = XINT (length);
1072 val = Fcons (init, val);
1078 /************************************************************************/
1079 /* Float allocation */
1080 /************************************************************************/
1082 #ifdef LISP_FLOAT_TYPE
1084 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
1085 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1088 make_float (double float_value)
1093 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
1095 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1096 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1099 set_lheader_implementation (&f->lheader, &lrecord_float);
1100 float_data (f) = float_value;
1105 #endif /* LISP_FLOAT_TYPE */
1108 /************************************************************************/
1109 /* Vector allocation */
1110 /************************************************************************/
1113 mark_vector (Lisp_Object obj)
1115 Lisp_Vector *ptr = XVECTOR (obj);
1116 int len = vector_length (ptr);
1119 for (i = 0; i < len - 1; i++)
1120 mark_object (ptr->contents[i]);
1121 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1125 size_vector (const void *lheader)
1127 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, contents,
1128 ((Lisp_Vector *) lheader)->size);
1132 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1134 int len = XVECTOR_LENGTH (obj1);
1135 if (len != XVECTOR_LENGTH (obj2))
1139 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1140 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1142 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1149 vector_hash (Lisp_Object obj, int depth)
1151 return HASH2 (XVECTOR_LENGTH (obj),
1152 internal_array_hash (XVECTOR_DATA (obj),
1153 XVECTOR_LENGTH (obj),
1157 static const struct lrecord_description vector_description[] = {
1158 { XD_LONG, offsetof (Lisp_Vector, size) },
1159 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1163 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1164 mark_vector, print_vector, 0,
1168 size_vector, Lisp_Vector);
1170 /* #### should allocate `small' vectors from a frob-block */
1171 static Lisp_Vector *
1172 make_vector_internal (size_t sizei)
1174 /* no vector_next */
1175 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1176 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1183 make_vector (size_t length, Lisp_Object init)
1185 Lisp_Vector *vecp = make_vector_internal (length);
1186 Lisp_Object *p = vector_data (vecp);
1193 XSETVECTOR (vector, vecp);
1200 make_older_vector (size_t length, Lisp_Object init)
1202 struct lcrecord_header* orig_all_lcrecords = all_lcrecords;
1205 all_lcrecords = all_older_lcrecords;
1206 obj = make_vector (length, init);
1207 all_older_lcrecords = all_lcrecords;
1208 all_lcrecords = orig_all_lcrecords;
1213 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1214 Return a new vector of length LENGTH, with each element being INIT.
1215 See also the function `vector'.
1219 CONCHECK_NATNUM (length);
1220 return make_vector (XINT (length), init);
1223 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1224 Return a newly created vector with specified arguments as elements.
1225 Any number of arguments, even zero arguments, are allowed.
1227 (int nargs, Lisp_Object *args))
1229 Lisp_Vector *vecp = make_vector_internal (nargs);
1230 Lisp_Object *p = vector_data (vecp);
1237 XSETVECTOR (vector, vecp);
1243 vector1 (Lisp_Object obj0)
1245 return Fvector (1, &obj0);
1249 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1251 Lisp_Object args[2];
1254 return Fvector (2, args);
1258 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1260 Lisp_Object args[3];
1264 return Fvector (3, args);
1267 #if 0 /* currently unused */
1270 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1273 Lisp_Object args[4];
1278 return Fvector (4, args);
1282 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1283 Lisp_Object obj3, Lisp_Object obj4)
1285 Lisp_Object args[5];
1291 return Fvector (5, args);
1295 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1296 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1298 Lisp_Object args[6];
1305 return Fvector (6, args);
1309 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1310 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1313 Lisp_Object args[7];
1321 return Fvector (7, args);
1325 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1326 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1327 Lisp_Object obj6, Lisp_Object obj7)
1329 Lisp_Object args[8];
1338 return Fvector (8, args);
1342 /************************************************************************/
1343 /* Bit Vector allocation */
1344 /************************************************************************/
1346 static Lisp_Object all_bit_vectors;
1348 /* #### should allocate `small' bit vectors from a frob-block */
1349 static Lisp_Bit_Vector *
1350 make_bit_vector_internal (size_t sizei)
1352 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1353 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1354 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1355 set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
1357 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1359 bit_vector_length (p) = sizei;
1360 bit_vector_next (p) = all_bit_vectors;
1361 /* make sure the extra bits in the last long are 0; the calling
1362 functions might not set them. */
1363 p->bits[num_longs - 1] = 0;
1364 XSETBIT_VECTOR (all_bit_vectors, p);
1369 make_bit_vector (size_t length, Lisp_Object init)
1371 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1372 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1377 memset (p->bits, 0, num_longs * sizeof (long));
1380 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1381 memset (p->bits, ~0, num_longs * sizeof (long));
1382 /* But we have to make sure that the unused bits in the
1383 last long are 0, so that equal/hash is easy. */
1385 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1389 Lisp_Object bit_vector;
1390 XSETBIT_VECTOR (bit_vector, p);
1396 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1399 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1401 for (i = 0; i < length; i++)
1402 set_bit_vector_bit (p, i, bytevec[i]);
1405 Lisp_Object bit_vector;
1406 XSETBIT_VECTOR (bit_vector, p);
1411 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1412 Return a new bit vector of length LENGTH. with each bit being INIT.
1413 Each element is set to INIT. See also the function `bit-vector'.
1417 CONCHECK_NATNUM (length);
1419 return make_bit_vector (XINT (length), init);
1422 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1423 Return a newly created bit vector with specified arguments as elements.
1424 Any number of arguments, even zero arguments, are allowed.
1426 (int nargs, Lisp_Object *args))
1429 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1431 for (i = 0; i < nargs; i++)
1433 CHECK_BIT (args[i]);
1434 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1438 Lisp_Object bit_vector;
1439 XSETBIT_VECTOR (bit_vector, p);
1445 /************************************************************************/
1446 /* Compiled-function allocation */
1447 /************************************************************************/
1449 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1450 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1453 make_compiled_function (void)
1455 Lisp_Compiled_Function *f;
1458 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1459 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
1462 f->specpdl_depth = 0;
1463 f->flags.documentationp = 0;
1464 f->flags.interactivep = 0;
1465 f->flags.domainp = 0; /* I18N3 */
1466 f->instructions = Qzero;
1467 f->constants = Qzero;
1469 f->doc_and_interactive = Qnil;
1470 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1471 f->annotated = Qnil;
1473 XSETCOMPILED_FUNCTION (fun, f);
1477 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1478 Return a new compiled-function object.
1479 Usage: (arglist instructions constants stack-depth
1480 &optional doc-string interactive)
1481 Note that, unlike all other emacs-lisp functions, calling this with five
1482 arguments is NOT the same as calling it with six arguments, the last of
1483 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1484 that this function was defined with `(interactive)'. If the arg is not
1485 specified, then that means the function is not interactive.
1486 This is terrible behavior which is retained for compatibility with old
1487 `.elc' files which expect these semantics.
1489 (int nargs, Lisp_Object *args))
1491 /* In a non-insane world this function would have this arglist...
1492 (arglist instructions constants stack_depth &optional doc_string interactive)
1494 Lisp_Object fun = make_compiled_function ();
1495 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1497 Lisp_Object arglist = args[0];
1498 Lisp_Object instructions = args[1];
1499 Lisp_Object constants = args[2];
1500 Lisp_Object stack_depth = args[3];
1501 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1502 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1504 if (nargs < 4 || nargs > 6)
1505 return Fsignal (Qwrong_number_of_arguments,
1506 list2 (intern ("make-byte-code"), make_int (nargs)));
1508 /* Check for valid formal parameter list now, to allow us to use
1509 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1511 Lisp_Object symbol, tail;
1512 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1514 CHECK_SYMBOL (symbol);
1515 if (EQ (symbol, Qt) ||
1516 EQ (symbol, Qnil) ||
1517 SYMBOL_IS_KEYWORD (symbol))
1518 signal_simple_error_2
1519 ("Invalid constant symbol in formal parameter list",
1523 f->arglist = arglist;
1525 /* `instructions' is a string or a cons (string . int) for a
1526 lazy-loaded function. */
1527 if (CONSP (instructions))
1529 CHECK_STRING (XCAR (instructions));
1530 CHECK_INT (XCDR (instructions));
1534 CHECK_STRING (instructions);
1536 f->instructions = instructions;
1538 if (!NILP (constants))
1539 CHECK_VECTOR (constants);
1540 f->constants = constants;
1542 CHECK_NATNUM (stack_depth);
1543 f->stack_depth = (unsigned short) XINT (stack_depth);
1545 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1546 if (!NILP (Vcurrent_compiled_function_annotation))
1547 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1548 else if (!NILP (Vload_file_name_internal_the_purecopy))
1549 f->annotated = Vload_file_name_internal_the_purecopy;
1550 else if (!NILP (Vload_file_name_internal))
1552 struct gcpro gcpro1;
1553 GCPRO1 (fun); /* don't let fun get reaped */
1554 Vload_file_name_internal_the_purecopy =
1555 Ffile_name_nondirectory (Vload_file_name_internal);
1556 f->annotated = Vload_file_name_internal_the_purecopy;
1559 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1561 /* doc_string may be nil, string, int, or a cons (string . int).
1562 interactive may be list or string (or unbound). */
1563 f->doc_and_interactive = Qunbound;
1565 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1566 f->doc_and_interactive = Vfile_domain;
1568 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1570 f->doc_and_interactive
1571 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1572 Fcons (interactive, f->doc_and_interactive));
1574 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1576 f->doc_and_interactive
1577 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1578 Fcons (doc_string, f->doc_and_interactive));
1580 if (UNBOUNDP (f->doc_and_interactive))
1581 f->doc_and_interactive = Qnil;
1587 /************************************************************************/
1588 /* Symbol allocation */
1589 /************************************************************************/
1591 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1592 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1594 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1595 Return a newly allocated uninterned symbol whose name is NAME.
1596 Its value and function definition are void, and its property list is nil.
1603 CHECK_STRING (name);
1605 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1606 set_lheader_implementation (&p->lheader, &lrecord_symbol);
1607 p->name = XSTRING (name);
1609 p->value = Qunbound;
1610 p->function = Qunbound;
1611 symbol_next (p) = 0;
1612 XSETSYMBOL (val, p);
1617 /************************************************************************/
1618 /* Extent allocation */
1619 /************************************************************************/
1621 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1622 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1625 allocate_extent (void)
1629 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1630 set_lheader_implementation (&e->lheader, &lrecord_extent);
1631 extent_object (e) = Qnil;
1632 set_extent_start (e, -1);
1633 set_extent_end (e, -1);
1638 extent_face (e) = Qnil;
1639 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1640 e->flags.detachable = 1;
1646 /************************************************************************/
1647 /* Event allocation */
1648 /************************************************************************/
1650 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1651 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1654 allocate_event (void)
1659 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1660 set_lheader_implementation (&e->lheader, &lrecord_event);
1667 /************************************************************************/
1668 /* Marker allocation */
1669 /************************************************************************/
1671 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1672 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1674 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1675 Return a new marker which does not point at any place.
1682 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1683 set_lheader_implementation (&p->lheader, &lrecord_marker);
1686 marker_next (p) = 0;
1687 marker_prev (p) = 0;
1688 p->insertion_type = 0;
1689 XSETMARKER (val, p);
1694 noseeum_make_marker (void)
1699 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1700 set_lheader_implementation (&p->lheader, &lrecord_marker);
1703 marker_next (p) = 0;
1704 marker_prev (p) = 0;
1705 p->insertion_type = 0;
1706 XSETMARKER (val, p);
1711 /************************************************************************/
1712 /* String allocation */
1713 /************************************************************************/
1715 /* The data for "short" strings generally resides inside of structs of type
1716 string_chars_block. The Lisp_String structure is allocated just like any
1717 other Lisp object (except for vectors), and these are freelisted when
1718 they get garbage collected. The data for short strings get compacted,
1719 but the data for large strings do not.
1721 Previously Lisp_String structures were relocated, but this caused a lot
1722 of bus-errors because the C code didn't include enough GCPRO's for
1723 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1724 that the reference would get relocated).
1726 This new method makes things somewhat bigger, but it is MUCH safer. */
1728 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1729 /* strings are used and freed quite often */
1730 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1731 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1734 mark_string (Lisp_Object obj)
1736 Lisp_String *ptr = XSTRING (obj);
1738 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1739 flush_cached_extent_info (XCAR (ptr->plist));
1744 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1747 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1748 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1751 static const struct lrecord_description string_description[] = {
1752 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1753 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1754 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1758 /* We store the string's extent info as the first element of the string's
1759 property list; and the string's MODIFF as the first or second element
1760 of the string's property list (depending on whether the extent info
1761 is present), but only if the string has been modified. This is ugly
1762 but it reduces the memory allocated for the string in the vast
1763 majority of cases, where the string is never modified and has no
1766 #### This means you can't use an int as a key in a string's plist. */
1768 static Lisp_Object *
1769 string_plist_ptr (Lisp_Object string)
1771 Lisp_Object *ptr = &XSTRING (string)->plist;
1773 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
1775 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
1781 string_getprop (Lisp_Object string, Lisp_Object property)
1783 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
1787 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
1789 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
1794 string_remprop (Lisp_Object string, Lisp_Object property)
1796 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
1800 string_plist (Lisp_Object string)
1802 return *string_plist_ptr (string);
1805 /* No `finalize', or `hash' methods.
1806 internal_hash() already knows how to hash strings and finalization
1807 is done with the ADDITIONAL_FREE_string macro, which is the
1808 standard way to do finalization when using
1809 SWEEP_FIXED_TYPE_BLOCK(). */
1810 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
1811 mark_string, print_string,
1820 /* String blocks contain this many useful bytes. */
1821 #define STRING_CHARS_BLOCK_SIZE \
1822 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1823 ((2 * sizeof (struct string_chars_block *)) \
1824 + sizeof (EMACS_INT))))
1825 /* Block header for small strings. */
1826 struct string_chars_block
1829 struct string_chars_block *next;
1830 struct string_chars_block *prev;
1831 /* Contents of string_chars_block->string_chars are interleaved
1832 string_chars structures (see below) and the actual string data */
1833 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1836 static struct string_chars_block *first_string_chars_block;
1837 static struct string_chars_block *current_string_chars_block;
1839 /* If SIZE is the length of a string, this returns how many bytes
1840 * the string occupies in string_chars_block->string_chars
1841 * (including alignment padding).
1843 #define STRING_FULLSIZE(size) \
1844 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1845 ALIGNOF (Lisp_String *))
1847 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1848 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1852 Lisp_String *string;
1853 unsigned char chars[1];
1856 struct unused_string_chars
1858 Lisp_String *string;
1863 init_string_chars_alloc (void)
1865 first_string_chars_block = xnew (struct string_chars_block);
1866 first_string_chars_block->prev = 0;
1867 first_string_chars_block->next = 0;
1868 first_string_chars_block->pos = 0;
1869 current_string_chars_block = first_string_chars_block;
1872 static struct string_chars *
1873 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1876 struct string_chars *s_chars;
1879 (countof (current_string_chars_block->string_chars)
1880 - current_string_chars_block->pos))
1882 /* This string can fit in the current string chars block */
1883 s_chars = (struct string_chars *)
1884 (current_string_chars_block->string_chars
1885 + current_string_chars_block->pos);
1886 current_string_chars_block->pos += fullsize;
1890 /* Make a new current string chars block */
1891 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1893 current_string_chars_block->next = new_scb;
1894 new_scb->prev = current_string_chars_block;
1896 current_string_chars_block = new_scb;
1897 new_scb->pos = fullsize;
1898 s_chars = (struct string_chars *)
1899 current_string_chars_block->string_chars;
1902 s_chars->string = string_it_goes_with;
1904 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1910 make_uninit_string (Bytecount length)
1913 EMACS_INT fullsize = STRING_FULLSIZE (length);
1916 assert (length >= 0 && fullsize > 0);
1918 /* Allocate the string header */
1919 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1920 set_lheader_implementation (&s->lheader, &lrecord_string);
1922 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1923 ? xnew_array (Bufbyte, length + 1)
1924 : allocate_string_chars_struct (s, fullsize)->chars);
1926 set_string_length (s, length);
1929 set_string_byte (s, length, 0);
1931 XSETSTRING (val, s);
1935 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1936 static void verify_string_chars_integrity (void);
1939 /* Resize the string S so that DELTA bytes can be inserted starting
1940 at POS. If DELTA < 0, it means deletion starting at POS. If
1941 POS < 0, resize the string but don't copy any characters. Use
1942 this if you're planning on completely overwriting the string.
1946 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
1948 Bytecount oldfullsize, newfullsize;
1949 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1950 verify_string_chars_integrity ();
1953 #ifdef ERROR_CHECK_BUFPOS
1956 assert (pos <= string_length (s));
1958 assert (pos + (-delta) <= string_length (s));
1963 assert ((-delta) <= string_length (s));
1965 #endif /* ERROR_CHECK_BUFPOS */
1968 /* simplest case: no size change. */
1971 if (pos >= 0 && delta < 0)
1972 /* If DELTA < 0, the functions below will delete the characters
1973 before POS. We want to delete characters *after* POS, however,
1974 so convert this to the appropriate form. */
1977 oldfullsize = STRING_FULLSIZE (string_length (s));
1978 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1980 if (BIG_STRING_FULLSIZE_P (oldfullsize))
1982 if (BIG_STRING_FULLSIZE_P (newfullsize))
1984 /* Both strings are big. We can just realloc().
1985 But careful! If the string is shrinking, we have to
1986 memmove() _before_ realloc(), and if growing, we have to
1987 memmove() _after_ realloc() - otherwise the access is
1988 illegal, and we might crash. */
1989 Bytecount len = string_length (s) + 1 - pos;
1991 if (delta < 0 && pos >= 0)
1992 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1993 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1994 string_length (s) + delta + 1));
1995 if (delta > 0 && pos >= 0)
1996 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1998 else /* String has been demoted from BIG_STRING. */
2001 allocate_string_chars_struct (s, newfullsize)->chars;
2002 Bufbyte *old_data = string_data (s);
2006 memcpy (new_data, old_data, pos);
2007 memcpy (new_data + pos + delta, old_data + pos,
2008 string_length (s) + 1 - pos);
2010 set_string_data (s, new_data);
2014 else /* old string is small */
2016 if (oldfullsize == newfullsize)
2018 /* special case; size change but the necessary
2019 allocation size won't change (up or down; code
2020 somewhere depends on there not being any unused
2021 allocation space, modulo any alignment
2025 Bufbyte *addroff = pos + string_data (s);
2027 memmove (addroff + delta, addroff,
2028 /* +1 due to zero-termination. */
2029 string_length (s) + 1 - pos);
2034 Bufbyte *old_data = string_data (s);
2036 BIG_STRING_FULLSIZE_P (newfullsize)
2037 ? xnew_array (Bufbyte, string_length (s) + delta + 1)
2038 : allocate_string_chars_struct (s, newfullsize)->chars;
2042 memcpy (new_data, old_data, pos);
2043 memcpy (new_data + pos + delta, old_data + pos,
2044 string_length (s) + 1 - pos);
2046 set_string_data (s, new_data);
2049 /* We need to mark this chunk of the string_chars_block
2050 as unused so that compact_string_chars() doesn't
2052 struct string_chars *old_s_chars = (struct string_chars *)
2053 ((char *) old_data - offsetof (struct string_chars, chars));
2054 /* Sanity check to make sure we aren't hosed by strange
2055 alignment/padding. */
2056 assert (old_s_chars->string == s);
2057 MARK_STRUCT_AS_FREE (old_s_chars);
2058 ((struct unused_string_chars *) old_s_chars)->fullsize =
2064 set_string_length (s, string_length (s) + delta);
2065 /* If pos < 0, the string won't be zero-terminated.
2066 Terminate now just to make sure. */
2067 string_data (s)[string_length (s)] = '\0';
2073 XSETSTRING (string, s);
2074 /* We also have to adjust all of the extent indices after the
2075 place we did the change. We say "pos - 1" because
2076 adjust_extents() is exclusive of the starting position
2078 adjust_extents (string, pos - 1, string_length (s),
2082 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2083 verify_string_chars_integrity ();
2090 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2092 Bufbyte newstr[MAX_EMCHAR_LEN];
2093 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2094 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2095 Bytecount newlen = set_charptr_emchar (newstr, c);
2097 if (oldlen != newlen)
2098 resize_string (s, bytoff, newlen - oldlen);
2099 /* Remember, string_data (s) might have changed so we can't cache it. */
2100 memcpy (string_data (s) + bytoff, newstr, newlen);
2105 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2106 Return a new string of length LENGTH, with each character being INIT.
2107 LENGTH must be an integer and INIT must be a character.
2111 CHECK_NATNUM (length);
2112 CHECK_CHAR_COERCE_INT (init);
2114 Bufbyte init_str[MAX_EMCHAR_LEN];
2115 int len = set_charptr_emchar (init_str, XCHAR (init));
2116 Lisp_Object val = make_uninit_string (len * XINT (length));
2119 /* Optimize the single-byte case */
2120 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2124 Bufbyte *ptr = XSTRING_DATA (val);
2126 for (i = XINT (length); i; i--)
2128 Bufbyte *init_ptr = init_str;
2132 case 6: *ptr++ = *init_ptr++;
2133 case 5: *ptr++ = *init_ptr++;
2135 case 4: *ptr++ = *init_ptr++;
2136 case 3: *ptr++ = *init_ptr++;
2137 case 2: *ptr++ = *init_ptr++;
2138 case 1: *ptr++ = *init_ptr++;
2146 DEFUN ("string", Fstring, 0, MANY, 0, /*
2147 Concatenate all the argument characters and make the result a string.
2149 (int nargs, Lisp_Object *args))
2151 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2152 Bufbyte *p = storage;
2154 for (; nargs; nargs--, args++)
2156 Lisp_Object lisp_char = *args;
2157 CHECK_CHAR_COERCE_INT (lisp_char);
2158 p += set_charptr_emchar (p, XCHAR (lisp_char));
2160 return make_string (storage, p - storage);
2164 /* Take some raw memory, which MUST already be in internal format,
2165 and package it up into a Lisp string. */
2167 make_string (const Bufbyte *contents, Bytecount length)
2171 /* Make sure we find out about bad make_string's when they happen */
2172 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2173 bytecount_to_charcount (contents, length); /* Just for the assertions */
2176 val = make_uninit_string (length);
2177 memcpy (XSTRING_DATA (val), contents, length);
2181 /* Take some raw memory, encoded in some external data format,
2182 and convert it into a Lisp string. */
2184 make_ext_string (const Extbyte *contents, EMACS_INT length,
2185 Lisp_Object coding_system)
2188 TO_INTERNAL_FORMAT (DATA, (contents, length),
2189 LISP_STRING, string,
2195 build_string (const char *str)
2197 /* Some strlen's crash and burn if passed null. */
2198 return make_string ((const Bufbyte *) str, (str ? strlen(str) : 0));
2202 build_ext_string (const char *str, Lisp_Object coding_system)
2204 /* Some strlen's crash and burn if passed null. */
2205 return make_ext_string ((const Extbyte *) str, (str ? strlen(str) : 0),
2210 build_translated_string (const char *str)
2212 return build_string (GETTEXT (str));
2216 make_string_nocopy (const Bufbyte *contents, Bytecount length)
2221 /* Make sure we find out about bad make_string_nocopy's when they happen */
2222 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2223 bytecount_to_charcount (contents, length); /* Just for the assertions */
2226 /* Allocate the string header */
2227 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2228 set_lheader_implementation (&s->lheader, &lrecord_string);
2229 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2231 set_string_data (s, (Bufbyte *)contents);
2232 set_string_length (s, length);
2234 XSETSTRING (val, s);
2239 /************************************************************************/
2240 /* lcrecord lists */
2241 /************************************************************************/
2243 /* Lcrecord lists are used to manage the allocation of particular
2244 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2245 malloc() and garbage-collection junk) as much as possible.
2246 It is similar to the Blocktype class.
2250 1) Create an lcrecord-list object using make_lcrecord_list().
2251 This is often done at initialization. Remember to staticpro_nodump
2252 this object! The arguments to make_lcrecord_list() are the
2253 same as would be passed to alloc_lcrecord().
2254 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2255 and pass the lcrecord-list earlier created.
2256 3) When done with the lcrecord, call free_managed_lcrecord().
2257 The standard freeing caveats apply: ** make sure there are no
2258 pointers to the object anywhere! **
2259 4) Calling free_managed_lcrecord() is just like kissing the
2260 lcrecord goodbye as if it were garbage-collected. This means:
2261 -- the contents of the freed lcrecord are undefined, and the
2262 contents of something produced by allocate_managed_lcrecord()
2263 are undefined, just like for alloc_lcrecord().
2264 -- the mark method for the lcrecord's type will *NEVER* be called
2266 -- the finalize method for the lcrecord's type will be called
2267 at the time that free_managed_lcrecord() is called.
2272 mark_lcrecord_list (Lisp_Object obj)
2274 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2275 Lisp_Object chain = list->free;
2277 while (!NILP (chain))
2279 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2280 struct free_lcrecord_header *free_header =
2281 (struct free_lcrecord_header *) lheader;
2284 (/* There should be no other pointers to the free list. */
2285 ! MARKED_RECORD_HEADER_P (lheader)
2287 /* Only lcrecords should be here. */
2288 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
2290 /* Only free lcrecords should be here. */
2291 free_header->lcheader.free
2293 /* The type of the lcrecord must be right. */
2294 LHEADER_IMPLEMENTATION (lheader) == list->implementation
2296 /* So must the size. */
2297 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2298 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
2301 MARK_RECORD_HEADER (lheader);
2302 chain = free_header->chain;
2308 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2309 mark_lcrecord_list, internal_object_printer,
2310 0, 0, 0, 0, struct lcrecord_list);
2312 make_lcrecord_list (size_t size,
2313 const struct lrecord_implementation *implementation)
2315 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2316 &lrecord_lcrecord_list);
2319 p->implementation = implementation;
2322 XSETLCRECORD_LIST (val, p);
2327 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2329 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2330 if (!NILP (list->free))
2332 Lisp_Object val = list->free;
2333 struct free_lcrecord_header *free_header =
2334 (struct free_lcrecord_header *) XPNTR (val);
2336 #ifdef ERROR_CHECK_GC
2337 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2339 /* There should be no other pointers to the free list. */
2340 assert (! MARKED_RECORD_HEADER_P (lheader));
2341 /* Only lcrecords should be here. */
2342 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
2343 /* Only free lcrecords should be here. */
2344 assert (free_header->lcheader.free);
2345 /* The type of the lcrecord must be right. */
2346 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
2347 /* So must the size. */
2348 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2349 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
2350 #endif /* ERROR_CHECK_GC */
2352 list->free = free_header->chain;
2353 free_header->lcheader.free = 0;
2360 XSETOBJ (val, Lisp_Type_Record,
2361 alloc_lcrecord (list->size, list->implementation));
2367 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2369 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2370 struct free_lcrecord_header *free_header =
2371 (struct free_lcrecord_header *) XPNTR (lcrecord);
2372 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2373 const struct lrecord_implementation *implementation
2374 = LHEADER_IMPLEMENTATION (lheader);
2376 /* Make sure the size is correct. This will catch, for example,
2377 putting a window configuration on the wrong free list. */
2378 gc_checking_assert ((implementation->size_in_bytes_method ?
2379 implementation->size_in_bytes_method (lheader) :
2380 implementation->static_size)
2383 if (implementation->finalizer)
2384 implementation->finalizer (lheader, 0);
2385 free_header->chain = list->free;
2386 free_header->lcheader.free = 1;
2387 list->free = lcrecord;
2393 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2394 Kept for compatibility, returns its argument.
2396 Make a copy of OBJECT in pure storage.
2397 Recursively copies contents of vectors and cons cells.
2398 Does not copy symbols.
2406 /************************************************************************/
2407 /* Garbage Collection */
2408 /************************************************************************/
2410 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
2411 Additional ones may be defined by a module (none yet). We leave some
2412 room in `lrecord_implementations_table' for such new lisp object types. */
2413 #define MODULE_DEFINABLE_TYPE_COUNT 32
2414 const struct lrecord_implementation *lrecord_implementations_table[lrecord_type_count + MODULE_DEFINABLE_TYPE_COUNT];
2416 /* Object marker functions are in the lrecord_implementation structure.
2417 But copying them to a parallel array is much more cache-friendly.
2418 This hack speeds up (garbage-collect) by about 5%. */
2419 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
2421 struct gcpro *gcprolist;
2423 /* 415 used Mly 29-Jun-93 */
2424 /* 1327 used slb 28-Feb-98 */
2425 /* 1328 used og 03-Oct-99 (moving slowly, heh?) */
2427 #define NSTATICS 4000
2429 #define NSTATICS 2000
2432 /* Not "static" because used by dumper.c */
2433 Lisp_Object *staticvec[NSTATICS];
2436 /* Put an entry in staticvec, pointing at the variable whose address is given
2439 staticpro (Lisp_Object *varaddress)
2441 /* #### This is now a dubious assert() since this routine may be called */
2442 /* by Lisp attempting to load a DLL. */
2443 assert (staticidx < countof (staticvec));
2444 staticvec[staticidx++] = varaddress;
2448 Lisp_Object *staticvec_nodump[200];
2449 int staticidx_nodump;
2451 /* Put an entry in staticvec_nodump, pointing at the variable whose address is given
2454 staticpro_nodump (Lisp_Object *varaddress)
2456 /* #### This is now a dubious assert() since this routine may be called */
2457 /* by Lisp attempting to load a DLL. */
2458 assert (staticidx_nodump < countof (staticvec_nodump));
2459 staticvec_nodump[staticidx_nodump++] = varaddress;
2463 struct pdump_dumpstructinfo dumpstructvec[200];
2466 /* Put an entry in dumpstructvec, pointing at the variable whose address is given
2469 dumpstruct (void *varaddress, const struct struct_description *desc)
2471 assert (dumpstructidx < countof (dumpstructvec));
2472 dumpstructvec[dumpstructidx].data = varaddress;
2473 dumpstructvec[dumpstructidx].desc = desc;
2477 struct pdump_dumpopaqueinfo dumpopaquevec[250];
2480 /* Put an entry in dumpopaquevec, pointing at the variable whose address is given
2483 dumpopaque (void *varaddress, size_t size)
2485 assert (dumpopaqueidx < countof (dumpopaquevec));
2487 dumpopaquevec[dumpopaqueidx].data = varaddress;
2488 dumpopaquevec[dumpopaqueidx].size = size;
2492 Lisp_Object *pdump_wirevec[50];
2495 /* Put an entry in pdump_wirevec, pointing at the variable whose address is given
2498 pdump_wire (Lisp_Object *varaddress)
2500 assert (pdump_wireidx < countof (pdump_wirevec));
2501 pdump_wirevec[pdump_wireidx++] = varaddress;
2505 Lisp_Object *pdump_wirevec_list[50];
2506 int pdump_wireidx_list;
2508 /* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given
2511 pdump_wire_list (Lisp_Object *varaddress)
2513 assert (pdump_wireidx_list < countof (pdump_wirevec_list));
2514 pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
2517 #ifdef ERROR_CHECK_GC
2518 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
2519 struct lrecord_header * GCLI_lh = (lheader); \
2520 assert (GCLI_lh != 0); \
2521 assert (GCLI_lh->type < lrecord_type_count); \
2522 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
2523 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
2524 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
2527 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
2531 /* Mark reference to a Lisp_Object. If the object referred to has not been
2532 seen yet, recursively mark all the references contained in it. */
2535 mark_object (Lisp_Object obj)
2539 /* Checks we used to perform */
2540 /* if (EQ (obj, Qnull_pointer)) return; */
2541 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2542 /* if (PURIFIED (XPNTR (obj))) return; */
2544 if (XTYPE (obj) == Lisp_Type_Record)
2546 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2548 GC_CHECK_LHEADER_INVARIANTS (lheader);
2550 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
2551 ! ((struct lcrecord_header *) lheader)->free);
2553 /* All c_readonly objects have their mark bit set,
2554 so that we only need to check the mark bit here. */
2555 if ( (!MARKED_RECORD_HEADER_P (lheader))
2557 && (!OLDER_RECORD_HEADER_P (lheader))
2561 MARK_RECORD_HEADER (lheader);
2563 if (RECORD_MARKER (lheader))
2565 obj = RECORD_MARKER (lheader) (obj);
2566 if (!NILP (obj)) goto tail_recurse;
2572 /* mark all of the conses in a list and mark the final cdr; but
2573 DO NOT mark the cars.
2575 Use only for internal lists! There should never be other pointers
2576 to the cons cells, because if so, the cars will remain unmarked
2577 even when they maybe should be marked. */
2579 mark_conses_in_list (Lisp_Object obj)
2583 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2585 if (CONS_MARKED_P (XCONS (rest)))
2587 MARK_CONS (XCONS (rest));
2594 /* Find all structures not marked, and free them. */
2596 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2597 static int gc_count_bit_vector_storage;
2598 static int gc_count_num_short_string_in_use;
2599 static int gc_count_string_total_size;
2600 static int gc_count_short_string_total_size;
2602 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2605 /* stats on lcrecords in use - kinda kludgy */
2609 int instances_in_use;
2611 int instances_freed;
2613 int instances_on_free_list;
2614 } lcrecord_stats [countof (lrecord_implementations_table)];
2617 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
2619 unsigned int type_index = h->type;
2621 if (((struct lcrecord_header *) h)->free)
2623 gc_checking_assert (!free_p);
2624 lcrecord_stats[type_index].instances_on_free_list++;
2628 const struct lrecord_implementation *implementation =
2629 LHEADER_IMPLEMENTATION (h);
2631 size_t sz = (implementation->size_in_bytes_method ?
2632 implementation->size_in_bytes_method (h) :
2633 implementation->static_size);
2636 lcrecord_stats[type_index].instances_freed++;
2637 lcrecord_stats[type_index].bytes_freed += sz;
2641 lcrecord_stats[type_index].instances_in_use++;
2642 lcrecord_stats[type_index].bytes_in_use += sz;
2648 /* Free all unmarked records */
2650 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2652 struct lcrecord_header *header;
2654 /* int total_size = 0; */
2656 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2658 /* First go through and call all the finalize methods.
2659 Then go through and free the objects. There used to
2660 be only one loop here, with the call to the finalizer
2661 occurring directly before the xfree() below. That
2662 is marginally faster but much less safe -- if the
2663 finalize method for an object needs to reference any
2664 other objects contained within it (and many do),
2665 we could easily be screwed by having already freed that
2668 for (header = *prev; header; header = header->next)
2670 struct lrecord_header *h = &(header->lheader);
2672 GC_CHECK_LHEADER_INVARIANTS (h);
2674 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
2676 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2677 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2681 for (header = *prev; header; )
2683 struct lrecord_header *h = &(header->lheader);
2684 if (MARKED_RECORD_HEADER_P (h))
2686 if (! C_READONLY_RECORD_HEADER_P (h))
2687 UNMARK_RECORD_HEADER (h);
2689 /* total_size += n->implementation->size_in_bytes (h);*/
2690 /* #### May modify header->next on a C_READONLY lcrecord */
2691 prev = &(header->next);
2693 tick_lcrecord_stats (h, 0);
2697 struct lcrecord_header *next = header->next;
2699 tick_lcrecord_stats (h, 1);
2700 /* used to call finalizer right here. */
2706 /* *total = total_size; */
2711 sweep_bit_vectors_1 (Lisp_Object *prev,
2712 int *used, int *total, int *storage)
2714 Lisp_Object bit_vector;
2717 int total_storage = 0;
2719 /* BIT_VECTORP fails because the objects are marked, which changes
2720 their implementation */
2721 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2723 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2725 if (MARKED_RECORD_P (bit_vector))
2727 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
2728 UNMARK_RECORD_HEADER (&(v->lheader));
2732 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2733 BIT_VECTOR_LONG_STORAGE (len));
2735 /* #### May modify next on a C_READONLY bitvector */
2736 prev = &(bit_vector_next (v));
2741 Lisp_Object next = bit_vector_next (v);
2748 *total = total_size;
2749 *storage = total_storage;
2752 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2753 to make macros prettier. */
2755 #ifdef ERROR_CHECK_GC
2757 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2759 struct typename##_block *SFTB_current; \
2760 struct typename##_block **SFTB_prev; \
2762 int num_free = 0, num_used = 0; \
2764 for (SFTB_prev = ¤t_##typename##_block, \
2765 SFTB_current = current_##typename##_block, \
2766 SFTB_limit = current_##typename##_block_index; \
2772 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2774 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2776 if (FREE_STRUCT_P (SFTB_victim)) \
2780 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2784 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2787 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2792 UNMARK_##typename (SFTB_victim); \
2795 SFTB_prev = &(SFTB_current->prev); \
2796 SFTB_current = SFTB_current->prev; \
2797 SFTB_limit = countof (current_##typename##_block->block); \
2800 gc_count_num_##typename##_in_use = num_used; \
2801 gc_count_num_##typename##_freelist = num_free; \
2804 #else /* !ERROR_CHECK_GC */
2806 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2808 struct typename##_block *SFTB_current; \
2809 struct typename##_block **SFTB_prev; \
2811 int num_free = 0, num_used = 0; \
2813 typename##_free_list = 0; \
2815 for (SFTB_prev = ¤t_##typename##_block, \
2816 SFTB_current = current_##typename##_block, \
2817 SFTB_limit = current_##typename##_block_index; \
2822 int SFTB_empty = 1; \
2823 obj_type *SFTB_old_free_list = typename##_free_list; \
2825 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2827 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2829 if (FREE_STRUCT_P (SFTB_victim)) \
2832 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2834 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2839 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2842 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2848 UNMARK_##typename (SFTB_victim); \
2853 SFTB_prev = &(SFTB_current->prev); \
2854 SFTB_current = SFTB_current->prev; \
2856 else if (SFTB_current == current_##typename##_block \
2857 && !SFTB_current->prev) \
2859 /* No real point in freeing sole allocation block */ \
2864 struct typename##_block *SFTB_victim_block = SFTB_current; \
2865 if (SFTB_victim_block == current_##typename##_block) \
2866 current_##typename##_block_index \
2867 = countof (current_##typename##_block->block); \
2868 SFTB_current = SFTB_current->prev; \
2870 *SFTB_prev = SFTB_current; \
2871 xfree (SFTB_victim_block); \
2872 /* Restore free list to what it was before victim was swept */ \
2873 typename##_free_list = SFTB_old_free_list; \
2874 num_free -= SFTB_limit; \
2877 SFTB_limit = countof (current_##typename##_block->block); \
2880 gc_count_num_##typename##_in_use = num_used; \
2881 gc_count_num_##typename##_freelist = num_free; \
2884 #endif /* !ERROR_CHECK_GC */
2892 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2893 #define ADDITIONAL_FREE_cons(ptr)
2895 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2898 /* Explicitly free a cons cell. */
2900 free_cons (Lisp_Cons *ptr)
2902 #ifdef ERROR_CHECK_GC
2903 /* If the CAR is not an int, then it will be a pointer, which will
2904 always be four-byte aligned. If this cons cell has already been
2905 placed on the free list, however, its car will probably contain
2906 a chain pointer to the next cons on the list, which has cleverly
2907 had all its 0's and 1's inverted. This allows for a quick
2908 check to make sure we're not freeing something already freed. */
2909 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2910 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2911 #endif /* ERROR_CHECK_GC */
2913 #ifndef ALLOC_NO_POOLS
2914 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2915 #endif /* ALLOC_NO_POOLS */
2918 /* explicitly free a list. You **must make sure** that you have
2919 created all the cons cells that make up this list and that there
2920 are no pointers to any of these cons cells anywhere else. If there
2921 are, you will lose. */
2924 free_list (Lisp_Object list)
2926 Lisp_Object rest, next;
2928 for (rest = list; !NILP (rest); rest = next)
2931 free_cons (XCONS (rest));
2935 /* explicitly free an alist. You **must make sure** that you have
2936 created all the cons cells that make up this alist and that there
2937 are no pointers to any of these cons cells anywhere else. If there
2938 are, you will lose. */
2941 free_alist (Lisp_Object alist)
2943 Lisp_Object rest, next;
2945 for (rest = alist; !NILP (rest); rest = next)
2948 free_cons (XCONS (XCAR (rest)));
2949 free_cons (XCONS (rest));
2954 sweep_compiled_functions (void)
2956 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2957 #define ADDITIONAL_FREE_compiled_function(ptr)
2959 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2963 #ifdef LISP_FLOAT_TYPE
2967 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2968 #define ADDITIONAL_FREE_float(ptr)
2970 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
2972 #endif /* LISP_FLOAT_TYPE */
2975 sweep_symbols (void)
2977 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2978 #define ADDITIONAL_FREE_symbol(ptr)
2980 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
2984 sweep_extents (void)
2986 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2987 #define ADDITIONAL_FREE_extent(ptr)
2989 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2995 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2996 #define ADDITIONAL_FREE_event(ptr)
2998 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
3002 sweep_markers (void)
3004 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3005 #define ADDITIONAL_FREE_marker(ptr) \
3006 do { Lisp_Object tem; \
3007 XSETMARKER (tem, ptr); \
3008 unchain_marker (tem); \
3011 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
3014 /* Explicitly free a marker. */
3016 free_marker (Lisp_Marker *ptr)
3018 /* Perhaps this will catch freeing an already-freed marker. */
3019 gc_checking_assert (ptr->lheader.type = lrecord_type_marker);
3021 #ifndef ALLOC_NO_POOLS
3022 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
3023 #endif /* ALLOC_NO_POOLS */
3027 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
3030 verify_string_chars_integrity (void)
3032 struct string_chars_block *sb;
3034 /* Scan each existing string block sequentially, string by string. */
3035 for (sb = first_string_chars_block; sb; sb = sb->next)
3038 /* POS is the index of the next string in the block. */
3039 while (pos < sb->pos)
3041 struct string_chars *s_chars =
3042 (struct string_chars *) &(sb->string_chars[pos]);
3043 Lisp_String *string;
3047 /* If the string_chars struct is marked as free (i.e. the STRING
3048 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3049 storage. (See below.) */
3051 if (FREE_STRUCT_P (s_chars))
3053 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3058 string = s_chars->string;
3059 /* Must be 32-bit aligned. */
3060 assert ((((int) string) & 3) == 0);
3062 size = string_length (string);
3063 fullsize = STRING_FULLSIZE (size);
3065 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3066 assert (string_data (string) == s_chars->chars);
3069 assert (pos == sb->pos);
3073 #endif /* MULE && ERROR_CHECK_GC */
3075 /* Compactify string chars, relocating the reference to each --
3076 free any empty string_chars_block we see. */
3078 compact_string_chars (void)
3080 struct string_chars_block *to_sb = first_string_chars_block;
3082 struct string_chars_block *from_sb;
3084 /* Scan each existing string block sequentially, string by string. */
3085 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3088 /* FROM_POS is the index of the next string in the block. */
3089 while (from_pos < from_sb->pos)
3091 struct string_chars *from_s_chars =
3092 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3093 struct string_chars *to_s_chars;
3094 Lisp_String *string;
3098 /* If the string_chars struct is marked as free (i.e. the STRING
3099 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3100 storage. This happens under Mule when a string's size changes
3101 in such a way that its fullsize changes. (Strings can change
3102 size because a different-length character can be substituted
3103 for another character.) In this case, after the bogus string
3104 pointer is the "fullsize" of this entry, i.e. how many bytes
3107 if (FREE_STRUCT_P (from_s_chars))
3109 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3110 from_pos += fullsize;
3114 string = from_s_chars->string;
3115 assert (!(FREE_STRUCT_P (string)));
3117 size = string_length (string);
3118 fullsize = STRING_FULLSIZE (size);
3120 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
3122 /* Just skip it if it isn't marked. */
3123 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3125 from_pos += fullsize;
3129 /* If it won't fit in what's left of TO_SB, close TO_SB out
3130 and go on to the next string_chars_block. We know that TO_SB
3131 cannot advance past FROM_SB here since FROM_SB is large enough
3132 to currently contain this string. */
3133 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3135 to_sb->pos = to_pos;
3136 to_sb = to_sb->next;
3140 /* Compute new address of this string
3141 and update TO_POS for the space being used. */
3142 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3144 /* Copy the string_chars to the new place. */
3145 if (from_s_chars != to_s_chars)
3146 memmove (to_s_chars, from_s_chars, fullsize);
3148 /* Relocate FROM_S_CHARS's reference */
3149 set_string_data (string, &(to_s_chars->chars[0]));
3151 from_pos += fullsize;
3156 /* Set current to the last string chars block still used and
3157 free any that follow. */
3159 struct string_chars_block *victim;
3161 for (victim = to_sb->next; victim; )
3163 struct string_chars_block *next = victim->next;
3168 current_string_chars_block = to_sb;
3169 current_string_chars_block->pos = to_pos;
3170 current_string_chars_block->next = 0;
3174 #if 1 /* Hack to debug missing purecopy's */
3175 static int debug_string_purity;
3178 debug_string_purity_print (Lisp_String *p)
3181 Charcount s = string_char_length (p);
3183 for (i = 0; i < s; i++)
3185 Emchar ch = string_char (p, i);
3186 if (ch < 32 || ch >= 126)
3187 stderr_out ("\\%03o", ch);
3188 else if (ch == '\\' || ch == '\"')
3189 stderr_out ("\\%c", ch);
3191 stderr_out ("%c", ch);
3193 stderr_out ("\"\n");
3199 sweep_strings (void)
3201 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3202 int debug = debug_string_purity;
3204 #define UNMARK_string(ptr) do { \
3205 Lisp_String *p = (ptr); \
3206 size_t size = string_length (p); \
3207 UNMARK_RECORD_HEADER (&(p->lheader)); \
3208 num_bytes += size; \
3209 if (!BIG_STRING_SIZE_P (size)) \
3211 num_small_bytes += size; \
3215 debug_string_purity_print (p); \
3217 #define ADDITIONAL_FREE_string(ptr) do { \
3218 size_t size = string_length (ptr); \
3219 if (BIG_STRING_SIZE_P (size)) \
3220 xfree (ptr->data); \
3223 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3225 gc_count_num_short_string_in_use = num_small_used;
3226 gc_count_string_total_size = num_bytes;
3227 gc_count_short_string_total_size = num_small_bytes;
3231 /* I hate duplicating all this crap! */
3233 marked_p (Lisp_Object obj)
3235 /* Checks we used to perform. */
3236 /* if (EQ (obj, Qnull_pointer)) return 1; */
3237 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3238 /* if (PURIFIED (XPNTR (obj))) return 1; */
3240 if (XTYPE (obj) == Lisp_Type_Record)
3242 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3244 GC_CHECK_LHEADER_INVARIANTS (lheader);
3246 return MARKED_RECORD_HEADER_P (lheader);
3254 /* Free all unmarked records. Do this at the very beginning,
3255 before anything else, so that the finalize methods can safely
3256 examine items in the objects. sweep_lcrecords_1() makes
3257 sure to call all the finalize methods *before* freeing anything,
3258 to complete the safety. */
3261 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3264 compact_string_chars ();
3266 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3267 macros) must be *extremely* careful to make sure they're not
3268 referencing freed objects. The only two existing finalize
3269 methods (for strings and markers) pass muster -- the string
3270 finalizer doesn't look at anything but its own specially-
3271 created block, and the marker finalizer only looks at live
3272 buffers (which will never be freed) and at the markers before
3273 and after it in the chain (which, by induction, will never be
3274 freed because if so, they would have already removed themselves
3277 /* Put all unmarked strings on free list, free'ing the string chars
3278 of large unmarked strings */
3281 /* Put all unmarked conses on free list */
3284 /* Free all unmarked bit vectors */
3285 sweep_bit_vectors_1 (&all_bit_vectors,
3286 &gc_count_num_bit_vector_used,
3287 &gc_count_bit_vector_total_size,
3288 &gc_count_bit_vector_storage);
3290 /* Free all unmarked compiled-function objects */
3291 sweep_compiled_functions ();
3293 #ifdef LISP_FLOAT_TYPE
3294 /* Put all unmarked floats on free list */
3298 /* Put all unmarked symbols on free list */
3301 /* Put all unmarked extents on free list */
3304 /* Put all unmarked markers on free list.
3305 Dechain each one first from the buffer into which it points. */
3311 pdump_objects_unmark ();
3315 /* Clearing for disksave. */
3318 disksave_object_finalization (void)
3320 /* It's important that certain information from the environment not get
3321 dumped with the executable (pathnames, environment variables, etc.).
3322 To make it easier to tell when this has happened with strings(1) we
3323 clear some known-to-be-garbage blocks of memory, so that leftover
3324 results of old evaluation don't look like potential problems.
3325 But first we set some notable variables to nil and do one more GC,
3326 to turn those strings into garbage.
3329 /* Yeah, this list is pretty ad-hoc... */
3330 Vprocess_environment = Qnil;
3331 Vexec_directory = Qnil;
3332 Vdata_directory = Qnil;
3333 Vsite_directory = Qnil;
3334 Vdoc_directory = Qnil;
3335 Vconfigure_info_directory = Qnil;
3338 /* Vdump_load_path = Qnil; */
3339 /* Release hash tables for locate_file */
3340 Flocate_file_clear_hashing (Qt);
3341 uncache_home_directory();
3343 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3344 defined(LOADHIST_BUILTIN))
3345 Vload_history = Qnil;
3347 Vshell_file_name = Qnil;
3349 garbage_collect_1 ();
3351 /* Run the disksave finalization methods of all live objects. */
3352 disksave_object_finalization_1 ();
3354 /* Zero out the uninitialized (really, unused) part of the containers
3355 for the live strings. */
3357 struct string_chars_block *scb;
3358 for (scb = first_string_chars_block; scb; scb = scb->next)
3360 int count = sizeof (scb->string_chars) - scb->pos;
3362 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3365 /* from the block's fill ptr to the end */
3366 memset ((scb->string_chars + scb->pos), 0, count);
3371 /* There, that ought to be enough... */
3377 restore_gc_inhibit (Lisp_Object val)
3379 gc_currently_forbidden = XINT (val);
3383 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3384 static int gc_hooks_inhibited;
3388 garbage_collect_1 (void)
3390 #if MAX_SAVE_STACK > 0
3391 char stack_top_variable;
3392 extern char *stack_bottom;
3397 Lisp_Object pre_gc_cursor;
3398 struct gcpro gcpro1;
3401 || gc_currently_forbidden
3403 || preparing_for_armageddon)
3406 /* We used to call selected_frame() here.
3408 The following functions cannot be called inside GC
3409 so we move to after the above tests. */
3412 Lisp_Object device = Fselected_device (Qnil);
3413 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3415 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3417 signal_simple_error ("No frames exist on device", device);
3421 pre_gc_cursor = Qnil;
3424 GCPRO1 (pre_gc_cursor);
3426 /* Very important to prevent GC during any of the following
3427 stuff that might run Lisp code; otherwise, we'll likely
3428 have infinite GC recursion. */
3429 speccount = specpdl_depth ();
3430 record_unwind_protect (restore_gc_inhibit,
3431 make_int (gc_currently_forbidden));
3432 gc_currently_forbidden = 1;
3434 if (!gc_hooks_inhibited)
3435 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3437 /* Now show the GC cursor/message. */
3438 if (!noninteractive)
3440 if (FRAME_WIN_P (f))
3442 Lisp_Object frame = make_frame (f);
3443 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3444 FRAME_SELECTED_WINDOW (f),
3446 pre_gc_cursor = f->pointer;
3447 if (POINTER_IMAGE_INSTANCEP (cursor)
3448 /* don't change if we don't know how to change back. */
3449 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3452 Fset_frame_pointer (frame, cursor);
3456 /* Don't print messages to the stream device. */
3457 if (!cursor_changed && !FRAME_STREAM_P (f))
3459 char *msg = (STRINGP (Vgc_message)
3460 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3462 Lisp_Object args[2], whole_msg;
3463 args[0] = build_string (msg ? msg :
3464 GETTEXT ((const char *) gc_default_message));
3465 args[1] = build_string ("...");
3466 whole_msg = Fconcat (2, args);
3467 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3468 Qgarbage_collecting);
3472 /***** Now we actually start the garbage collection. */
3476 gc_generation_number[0]++;
3478 #if MAX_SAVE_STACK > 0
3480 /* Save a copy of the contents of the stack, for debugging. */
3483 /* Static buffer in which we save a copy of the C stack at each GC. */
3484 static char *stack_copy;
3485 static size_t stack_copy_size;
3487 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3488 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3489 if (stack_size < MAX_SAVE_STACK)
3491 if (stack_copy_size < stack_size)
3493 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3494 stack_copy_size = stack_size;
3498 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3502 #endif /* MAX_SAVE_STACK > 0 */
3504 /* Do some totally ad-hoc resource clearing. */
3505 /* #### generalize this? */
3506 clear_event_resource ();
3507 cleanup_specifiers ();
3509 /* Mark all the special slots that serve as the roots of accessibility. */
3513 for (i = 0; i < staticidx; i++)
3514 mark_object (*(staticvec[i]));
3515 for (i = 0; i < staticidx_nodump; i++)
3516 mark_object (*(staticvec_nodump[i]));
3522 for (tail = gcprolist; tail; tail = tail->next)
3523 for (i = 0; i < tail->nvars; i++)
3524 mark_object (tail->var[i]);
3528 struct specbinding *bind;
3529 for (bind = specpdl; bind != specpdl_ptr; bind++)
3531 mark_object (bind->symbol);
3532 mark_object (bind->old_value);
3537 struct catchtag *catch;
3538 for (catch = catchlist; catch; catch = catch->next)
3540 mark_object (catch->tag);
3541 mark_object (catch->val);
3546 struct backtrace *backlist;
3547 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3549 int nargs = backlist->nargs;
3552 mark_object (*backlist->function);
3553 if (nargs == UNEVALLED || nargs == MANY)
3554 mark_object (backlist->args[0]);
3556 for (i = 0; i < nargs; i++)
3557 mark_object (backlist->args[i]);
3562 mark_profiling_info ();
3564 /* OK, now do the after-mark stuff. This is for things that
3565 are only marked when something else is marked (e.g. weak hash tables).
3566 There may be complex dependencies between such objects -- e.g.
3567 a weak hash table might be unmarked, but after processing a later
3568 weak hash table, the former one might get marked. So we have to
3569 iterate until nothing more gets marked. */
3571 while (finish_marking_weak_hash_tables () > 0 ||
3572 finish_marking_weak_lists () > 0)
3575 /* And prune (this needs to be called after everything else has been
3576 marked and before we do any sweeping). */
3577 /* #### this is somewhat ad-hoc and should probably be an object
3579 prune_weak_hash_tables ();
3580 prune_weak_lists ();
3581 prune_specifiers ();
3582 prune_syntax_tables ();
3586 consing_since_gc = 0;
3587 #ifndef DEBUG_XEMACS
3588 /* Allow you to set it really fucking low if you really want ... */
3589 if (gc_cons_threshold < 10000)
3590 gc_cons_threshold = 10000;
3595 /******* End of garbage collection ********/
3597 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3599 /* Now remove the GC cursor/message */
3600 if (!noninteractive)
3603 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3604 else if (!FRAME_STREAM_P (f))
3606 char *msg = (STRINGP (Vgc_message)
3607 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3610 /* Show "...done" only if the echo area would otherwise be empty. */
3611 if (NILP (clear_echo_area (selected_frame (),
3612 Qgarbage_collecting, 0)))
3614 Lisp_Object args[2], whole_msg;
3615 args[0] = build_string (msg ? msg :
3616 GETTEXT ((const char *)
3617 gc_default_message));
3618 args[1] = build_string ("... done");
3619 whole_msg = Fconcat (2, args);
3620 echo_area_message (selected_frame (), (Bufbyte *) 0,
3622 Qgarbage_collecting);
3627 /* now stop inhibiting GC */
3628 unbind_to (speccount, Qnil);
3630 if (!breathing_space)
3632 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3639 /* Debugging aids. */
3642 gc_plist_hack (const char *name, int value, Lisp_Object tail)
3644 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3645 or portable numeric datatypes, or bit-vectors, or characters, or
3646 arrays, or exceptions, or ...) */
3647 return cons3 (intern (name), make_int (value), tail);
3650 #define HACK_O_MATIC(type, name, pl) do { \
3652 struct type##_block *x = current_##type##_block; \
3653 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3654 (pl) = gc_plist_hack ((name), s, (pl)); \
3657 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3658 Reclaim storage for Lisp objects no longer needed.
3659 Return info on amount of space in use:
3660 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3661 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3663 where `PLIST' is a list of alternating keyword/value pairs providing
3664 more detailed information.
3665 Garbage collection happens automatically if you cons more than
3666 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3670 Lisp_Object pl = Qnil;
3672 int gc_count_vector_total_size = 0;
3674 garbage_collect_1 ();
3676 for (i = 0; i < lrecord_type_count; i++)
3678 if (lcrecord_stats[i].bytes_in_use != 0
3679 || lcrecord_stats[i].bytes_freed != 0
3680 || lcrecord_stats[i].instances_on_free_list != 0)
3683 const char *name = lrecord_implementations_table[i]->name;
3684 int len = strlen (name);
3685 /* save this for the FSFmacs-compatible part of the summary */
3686 if (i == lrecord_vector.lrecord_type_index)
3687 gc_count_vector_total_size =
3688 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3690 sprintf (buf, "%s-storage", name);
3691 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3692 /* Okay, simple pluralization check for `symbol-value-varalias' */
3693 if (name[len-1] == 's')
3694 sprintf (buf, "%ses-freed", name);
3696 sprintf (buf, "%ss-freed", name);
3697 if (lcrecord_stats[i].instances_freed != 0)
3698 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3699 if (name[len-1] == 's')
3700 sprintf (buf, "%ses-on-free-list", name);
3702 sprintf (buf, "%ss-on-free-list", name);
3703 if (lcrecord_stats[i].instances_on_free_list != 0)
3704 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3706 if (name[len-1] == 's')
3707 sprintf (buf, "%ses-used", name);
3709 sprintf (buf, "%ss-used", name);
3710 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3714 HACK_O_MATIC (extent, "extent-storage", pl);
3715 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3716 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3717 HACK_O_MATIC (event, "event-storage", pl);
3718 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3719 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3720 HACK_O_MATIC (marker, "marker-storage", pl);
3721 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3722 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3723 #ifdef LISP_FLOAT_TYPE
3724 HACK_O_MATIC (float, "float-storage", pl);
3725 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3726 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3727 #endif /* LISP_FLOAT_TYPE */
3728 HACK_O_MATIC (string, "string-header-storage", pl);
3729 pl = gc_plist_hack ("long-strings-total-length",
3730 gc_count_string_total_size
3731 - gc_count_short_string_total_size, pl);
3732 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3733 pl = gc_plist_hack ("short-strings-total-length",
3734 gc_count_short_string_total_size, pl);
3735 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3736 pl = gc_plist_hack ("long-strings-used",
3737 gc_count_num_string_in_use
3738 - gc_count_num_short_string_in_use, pl);
3739 pl = gc_plist_hack ("short-strings-used",
3740 gc_count_num_short_string_in_use, pl);
3742 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3743 pl = gc_plist_hack ("compiled-functions-free",
3744 gc_count_num_compiled_function_freelist, pl);
3745 pl = gc_plist_hack ("compiled-functions-used",
3746 gc_count_num_compiled_function_in_use, pl);
3748 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3749 pl = gc_plist_hack ("bit-vectors-total-length",
3750 gc_count_bit_vector_total_size, pl);
3751 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3753 HACK_O_MATIC (symbol, "symbol-storage", pl);
3754 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3755 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3757 HACK_O_MATIC (cons, "cons-storage", pl);
3758 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3759 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3761 /* The things we do for backwards-compatibility */
3763 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3764 make_int (gc_count_num_cons_freelist)),
3765 Fcons (make_int (gc_count_num_symbol_in_use),
3766 make_int (gc_count_num_symbol_freelist)),
3767 Fcons (make_int (gc_count_num_marker_in_use),
3768 make_int (gc_count_num_marker_freelist)),
3769 make_int (gc_count_string_total_size),
3770 make_int (gc_count_vector_total_size),
3775 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3776 Return the number of bytes consed since the last garbage collection.
3777 \"Consed\" is a misnomer in that this actually counts allocation
3778 of all different kinds of objects, not just conses.
3780 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3784 return make_int (consing_since_gc);
3788 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
3789 Return the address of the last byte Emacs has allocated, divided by 1024.
3790 This may be helpful in debugging Emacs's memory usage.
3791 The value is divided by 1024 to make sure it will fit in a lisp integer.
3795 return make_int ((EMACS_INT) sbrk (0) / 1024);
3801 object_dead_p (Lisp_Object obj)
3803 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3804 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3805 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3806 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3807 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3808 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3809 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3812 #ifdef MEMORY_USAGE_STATS
3814 /* Attempt to determine the actual amount of space that is used for
3815 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3817 It seems that the following holds:
3819 1. When using the old allocator (malloc.c):
3821 -- blocks are always allocated in chunks of powers of two. For
3822 each block, there is an overhead of 8 bytes if rcheck is not
3823 defined, 20 bytes if it is defined. In other words, a
3824 one-byte allocation needs 8 bytes of overhead for a total of
3825 9 bytes, and needs to have 16 bytes of memory chunked out for
3828 2. When using the new allocator (gmalloc.c):
3830 -- blocks are always allocated in chunks of powers of two up
3831 to 4096 bytes. Larger blocks are allocated in chunks of
3832 an integral multiple of 4096 bytes. The minimum block
3833 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3834 is defined. There is no per-block overhead, but there
3835 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3838 3. When using the system malloc, anything goes, but they are
3839 generally slower and more space-efficient than the GNU
3840 allocators. One possibly reasonable assumption to make
3841 for want of better data is that sizeof (void *), or maybe
3842 2 * sizeof (void *), is required as overhead and that
3843 blocks are allocated in the minimum required size except
3844 that some minimum block size is imposed (e.g. 16 bytes). */
3847 malloced_storage_size (void *ptr, size_t claimed_size,
3848 struct overhead_stats *stats)
3850 size_t orig_claimed_size = claimed_size;
3854 if (claimed_size < 2 * sizeof (void *))
3855 claimed_size = 2 * sizeof (void *);
3856 # ifdef SUNOS_LOCALTIME_BUG
3857 if (claimed_size < 16)
3860 if (claimed_size < 4096)
3864 /* compute the log base two, more or less, then use it to compute
3865 the block size needed. */
3867 /* It's big, it's heavy, it's wood! */
3868 while ((claimed_size /= 2) != 0)
3871 /* It's better than bad, it's good! */
3877 /* We have to come up with some average about the amount of
3879 if ((size_t) (rand () & 4095) < claimed_size)
3880 claimed_size += 3 * sizeof (void *);
3884 claimed_size += 4095;
3885 claimed_size &= ~4095;
3886 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3889 #elif defined (SYSTEM_MALLOC)
3891 if (claimed_size < 16)
3893 claimed_size += 2 * sizeof (void *);
3895 #else /* old GNU allocator */
3897 # ifdef rcheck /* #### may not be defined here */
3905 /* compute the log base two, more or less, then use it to compute
3906 the block size needed. */
3908 /* It's big, it's heavy, it's wood! */
3909 while ((claimed_size /= 2) != 0)
3912 /* It's better than bad, it's good! */
3920 #endif /* old GNU allocator */
3924 stats->was_requested += orig_claimed_size;
3925 stats->malloc_overhead += claimed_size - orig_claimed_size;
3927 return claimed_size;
3931 fixed_type_block_overhead (size_t size)
3933 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3934 size_t overhead = 0;
3935 size_t storage_size = malloced_storage_size (0, per_block, 0);
3936 while (size >= per_block)
3939 overhead += sizeof (void *) + per_block - storage_size;
3941 if (rand () % per_block < size)
3942 overhead += sizeof (void *) + per_block - storage_size;
3946 #endif /* MEMORY_USAGE_STATS */
3949 /* Initialization */
3951 reinit_alloc_once_early (void)
3953 gc_generation_number[0] = 0;
3954 breathing_space = 0;
3955 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3956 XSETINT (Vgc_message, 0);
3959 all_older_lcrecords = 0;
3961 ignore_malloc_warnings = 1;
3962 #ifdef DOUG_LEA_MALLOC
3963 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3964 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3965 #if 0 /* Moved to emacs.c */
3966 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3969 init_string_alloc ();
3970 init_string_chars_alloc ();
3972 init_symbol_alloc ();
3973 init_compiled_function_alloc ();
3974 #ifdef LISP_FLOAT_TYPE
3975 init_float_alloc ();
3976 #endif /* LISP_FLOAT_TYPE */
3977 init_marker_alloc ();
3978 init_extent_alloc ();
3979 init_event_alloc ();
3981 ignore_malloc_warnings = 0;
3983 staticidx_nodump = 0;
3987 consing_since_gc = 0;
3989 gc_cons_threshold = 500000; /* XEmacs change */
3991 gc_cons_threshold = 15000; /* debugging */
3993 #ifdef VIRT_ADDR_VARIES
3994 malloc_sbrk_unused = 1<<22; /* A large number */
3995 malloc_sbrk_used = 100000; /* as reasonable as any number */
3996 #endif /* VIRT_ADDR_VARIES */
3997 lrecord_uid_counter = 259;
3998 debug_string_purity = 0;
4001 gc_currently_forbidden = 0;
4002 gc_hooks_inhibited = 0;
4004 #ifdef ERROR_CHECK_TYPECHECK
4005 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4008 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
4010 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4012 #endif /* ERROR_CHECK_TYPECHECK */
4016 init_alloc_once_early (void)
4018 reinit_alloc_once_early ();
4022 for (i = 0; i < countof (lrecord_implementations_table); i++)
4023 lrecord_implementations_table[i] = 0;
4026 INIT_LRECORD_IMPLEMENTATION (cons);
4027 INIT_LRECORD_IMPLEMENTATION (vector);
4028 INIT_LRECORD_IMPLEMENTATION (string);
4029 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
4034 int pure_bytes_used = 0;
4043 syms_of_alloc (void)
4045 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
4046 defsymbol (&Qpost_gc_hook, "post-gc-hook");
4047 defsymbol (&Qgarbage_collecting, "garbage-collecting");
4052 DEFSUBR (Fbit_vector);
4053 DEFSUBR (Fmake_byte_code);
4054 DEFSUBR (Fmake_list);
4055 DEFSUBR (Fmake_vector);
4056 DEFSUBR (Fmake_bit_vector);
4057 DEFSUBR (Fmake_string);
4059 DEFSUBR (Fmake_symbol);
4060 DEFSUBR (Fmake_marker);
4061 DEFSUBR (Fpurecopy);
4062 DEFSUBR (Fgarbage_collect);
4064 DEFSUBR (Fmemory_limit);
4066 DEFSUBR (Fconsing_since_gc);
4070 vars_of_alloc (void)
4072 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
4073 *Number of bytes of consing between garbage collections.
4074 \"Consing\" is a misnomer in that this actually counts allocation
4075 of all different kinds of objects, not just conses.
4076 Garbage collection can happen automatically once this many bytes have been
4077 allocated since the last garbage collection. All data types count.
4079 Garbage collection happens automatically when `eval' or `funcall' are
4080 called. (Note that `funcall' is called implicitly as part of evaluation.)
4081 By binding this temporarily to a large number, you can effectively
4082 prevent garbage collection during a part of the program.
4084 See also `consing-since-gc'.
4087 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
4088 Number of bytes of sharable Lisp data allocated so far.
4092 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
4093 Number of bytes of unshared memory allocated in this session.
4096 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
4097 Number of bytes of unshared memory remaining available in this session.
4102 DEFVAR_INT ("debug-allocation", &debug_allocation /*
4103 If non-zero, print out information to stderr about all objects allocated.
4104 See also `debug-allocation-backtrace-length'.
4106 debug_allocation = 0;
4108 DEFVAR_INT ("debug-allocation-backtrace-length",
4109 &debug_allocation_backtrace_length /*
4110 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4112 debug_allocation_backtrace_length = 2;
4115 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4116 Non-nil means loading Lisp code in order to dump an executable.
4117 This means that certain objects should be allocated in readonly space.
4120 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4121 Function or functions to be run just before each garbage collection.
4122 Interrupts, garbage collection, and errors are inhibited while this hook
4123 runs, so be extremely careful in what you add here. In particular, avoid
4124 consing, and do not interact with the user.
4126 Vpre_gc_hook = Qnil;
4128 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4129 Function or functions to be run just after each garbage collection.
4130 Interrupts, garbage collection, and errors are inhibited while this hook
4131 runs, so be extremely careful in what you add here. In particular, avoid
4132 consing, and do not interact with the user.
4134 Vpost_gc_hook = Qnil;
4136 DEFVAR_LISP ("gc-message", &Vgc_message /*
4137 String to print to indicate that a garbage collection is in progress.
4138 This is printed in the echo area. If the selected frame is on a
4139 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4140 image instance) in the domain of the selected frame, the mouse pointer
4141 will change instead of this message being printed.
4143 Vgc_message = build_string (gc_default_message);
4145 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4146 Pointer glyph used to indicate that a garbage collection is in progress.
4147 If the selected window is on a window system and this glyph specifies a
4148 value (i.e. a pointer image instance) in the domain of the selected
4149 window, the pointer will be changed as specified during garbage collection.
4150 Otherwise, a message will be printed in the echo area, as controlled
4156 complex_vars_of_alloc (void)
4158 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);