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;
1212 void make_vector_newer_1 (Lisp_Object v);
1214 make_vector_newer_1 (Lisp_Object v)
1216 struct lcrecord_header* lcrecords = all_older_lcrecords;
1218 if (lcrecords != NULL)
1220 if (lcrecords == XPNTR (v))
1222 lcrecords->lheader.older = 0;
1223 all_older_lcrecords = all_older_lcrecords->next;
1224 lcrecords->next = all_lcrecords;
1225 all_lcrecords = lcrecords;
1230 struct lcrecord_header* plcrecords = lcrecords;
1232 lcrecords = lcrecords->next;
1233 while (lcrecords != NULL)
1235 if (lcrecords == XPNTR (v))
1237 lcrecords->lheader.older = 0;
1238 plcrecords->next = lcrecords->next;
1239 lcrecords->next = all_lcrecords;
1240 all_lcrecords = lcrecords;
1243 plcrecords = lcrecords;
1244 lcrecords = lcrecords->next;
1251 make_vector_newer (Lisp_Object v)
1255 for (i = 0; i < XVECTOR_LENGTH (v); i++)
1257 Lisp_Object obj = XVECTOR_DATA (v)[i];
1259 if (VECTORP (obj) && !EQ (obj, v))
1260 make_vector_newer (obj);
1262 make_vector_newer_1 (v);
1266 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1267 Return a new vector of length LENGTH, with each element being INIT.
1268 See also the function `vector'.
1272 CONCHECK_NATNUM (length);
1273 return make_vector (XINT (length), init);
1276 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1277 Return a newly created vector with specified arguments as elements.
1278 Any number of arguments, even zero arguments, are allowed.
1280 (int nargs, Lisp_Object *args))
1282 Lisp_Vector *vecp = make_vector_internal (nargs);
1283 Lisp_Object *p = vector_data (vecp);
1290 XSETVECTOR (vector, vecp);
1296 vector1 (Lisp_Object obj0)
1298 return Fvector (1, &obj0);
1302 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1304 Lisp_Object args[2];
1307 return Fvector (2, args);
1311 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1313 Lisp_Object args[3];
1317 return Fvector (3, args);
1320 #if 0 /* currently unused */
1323 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1326 Lisp_Object args[4];
1331 return Fvector (4, args);
1335 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1336 Lisp_Object obj3, Lisp_Object obj4)
1338 Lisp_Object args[5];
1344 return Fvector (5, args);
1348 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1349 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1351 Lisp_Object args[6];
1358 return Fvector (6, args);
1362 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1363 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1366 Lisp_Object args[7];
1374 return Fvector (7, args);
1378 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1379 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1380 Lisp_Object obj6, Lisp_Object obj7)
1382 Lisp_Object args[8];
1391 return Fvector (8, args);
1395 /************************************************************************/
1396 /* Bit Vector allocation */
1397 /************************************************************************/
1399 static Lisp_Object all_bit_vectors;
1401 /* #### should allocate `small' bit vectors from a frob-block */
1402 static Lisp_Bit_Vector *
1403 make_bit_vector_internal (size_t sizei)
1405 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1406 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1407 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1408 set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
1410 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1412 bit_vector_length (p) = sizei;
1413 bit_vector_next (p) = all_bit_vectors;
1414 /* make sure the extra bits in the last long are 0; the calling
1415 functions might not set them. */
1416 p->bits[num_longs - 1] = 0;
1417 XSETBIT_VECTOR (all_bit_vectors, p);
1422 make_bit_vector (size_t length, Lisp_Object init)
1424 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1425 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1430 memset (p->bits, 0, num_longs * sizeof (long));
1433 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1434 memset (p->bits, ~0, num_longs * sizeof (long));
1435 /* But we have to make sure that the unused bits in the
1436 last long are 0, so that equal/hash is easy. */
1438 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1442 Lisp_Object bit_vector;
1443 XSETBIT_VECTOR (bit_vector, p);
1449 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1452 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1454 for (i = 0; i < length; i++)
1455 set_bit_vector_bit (p, i, bytevec[i]);
1458 Lisp_Object bit_vector;
1459 XSETBIT_VECTOR (bit_vector, p);
1464 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1465 Return a new bit vector of length LENGTH. with each bit being INIT.
1466 Each element is set to INIT. See also the function `bit-vector'.
1470 CONCHECK_NATNUM (length);
1472 return make_bit_vector (XINT (length), init);
1475 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1476 Return a newly created bit vector with specified arguments as elements.
1477 Any number of arguments, even zero arguments, are allowed.
1479 (int nargs, Lisp_Object *args))
1482 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1484 for (i = 0; i < nargs; i++)
1486 CHECK_BIT (args[i]);
1487 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1491 Lisp_Object bit_vector;
1492 XSETBIT_VECTOR (bit_vector, p);
1498 /************************************************************************/
1499 /* Compiled-function allocation */
1500 /************************************************************************/
1502 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1503 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1506 make_compiled_function (void)
1508 Lisp_Compiled_Function *f;
1511 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1512 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
1515 f->specpdl_depth = 0;
1516 f->flags.documentationp = 0;
1517 f->flags.interactivep = 0;
1518 f->flags.domainp = 0; /* I18N3 */
1519 f->instructions = Qzero;
1520 f->constants = Qzero;
1522 f->doc_and_interactive = Qnil;
1523 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1524 f->annotated = Qnil;
1526 XSETCOMPILED_FUNCTION (fun, f);
1530 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1531 Return a new compiled-function object.
1532 Usage: (arglist instructions constants stack-depth
1533 &optional doc-string interactive)
1534 Note that, unlike all other emacs-lisp functions, calling this with five
1535 arguments is NOT the same as calling it with six arguments, the last of
1536 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1537 that this function was defined with `(interactive)'. If the arg is not
1538 specified, then that means the function is not interactive.
1539 This is terrible behavior which is retained for compatibility with old
1540 `.elc' files which expect these semantics.
1542 (int nargs, Lisp_Object *args))
1544 /* In a non-insane world this function would have this arglist...
1545 (arglist instructions constants stack_depth &optional doc_string interactive)
1547 Lisp_Object fun = make_compiled_function ();
1548 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1550 Lisp_Object arglist = args[0];
1551 Lisp_Object instructions = args[1];
1552 Lisp_Object constants = args[2];
1553 Lisp_Object stack_depth = args[3];
1554 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1555 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1557 if (nargs < 4 || nargs > 6)
1558 return Fsignal (Qwrong_number_of_arguments,
1559 list2 (intern ("make-byte-code"), make_int (nargs)));
1561 /* Check for valid formal parameter list now, to allow us to use
1562 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1564 Lisp_Object symbol, tail;
1565 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1567 CHECK_SYMBOL (symbol);
1568 if (EQ (symbol, Qt) ||
1569 EQ (symbol, Qnil) ||
1570 SYMBOL_IS_KEYWORD (symbol))
1571 signal_simple_error_2
1572 ("Invalid constant symbol in formal parameter list",
1576 f->arglist = arglist;
1578 /* `instructions' is a string or a cons (string . int) for a
1579 lazy-loaded function. */
1580 if (CONSP (instructions))
1582 CHECK_STRING (XCAR (instructions));
1583 CHECK_INT (XCDR (instructions));
1587 CHECK_STRING (instructions);
1589 f->instructions = instructions;
1591 if (!NILP (constants))
1592 CHECK_VECTOR (constants);
1593 f->constants = constants;
1595 CHECK_NATNUM (stack_depth);
1596 f->stack_depth = (unsigned short) XINT (stack_depth);
1598 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1599 if (!NILP (Vcurrent_compiled_function_annotation))
1600 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1601 else if (!NILP (Vload_file_name_internal_the_purecopy))
1602 f->annotated = Vload_file_name_internal_the_purecopy;
1603 else if (!NILP (Vload_file_name_internal))
1605 struct gcpro gcpro1;
1606 GCPRO1 (fun); /* don't let fun get reaped */
1607 Vload_file_name_internal_the_purecopy =
1608 Ffile_name_nondirectory (Vload_file_name_internal);
1609 f->annotated = Vload_file_name_internal_the_purecopy;
1612 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1614 /* doc_string may be nil, string, int, or a cons (string . int).
1615 interactive may be list or string (or unbound). */
1616 f->doc_and_interactive = Qunbound;
1618 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1619 f->doc_and_interactive = Vfile_domain;
1621 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1623 f->doc_and_interactive
1624 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1625 Fcons (interactive, f->doc_and_interactive));
1627 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1629 f->doc_and_interactive
1630 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1631 Fcons (doc_string, f->doc_and_interactive));
1633 if (UNBOUNDP (f->doc_and_interactive))
1634 f->doc_and_interactive = Qnil;
1640 /************************************************************************/
1641 /* Symbol allocation */
1642 /************************************************************************/
1644 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1645 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1647 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1648 Return a newly allocated uninterned symbol whose name is NAME.
1649 Its value and function definition are void, and its property list is nil.
1656 CHECK_STRING (name);
1658 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1659 set_lheader_implementation (&p->lheader, &lrecord_symbol);
1660 p->name = XSTRING (name);
1662 p->value = Qunbound;
1663 p->function = Qunbound;
1664 symbol_next (p) = 0;
1665 XSETSYMBOL (val, p);
1670 /************************************************************************/
1671 /* Extent allocation */
1672 /************************************************************************/
1674 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1675 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1678 allocate_extent (void)
1682 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1683 set_lheader_implementation (&e->lheader, &lrecord_extent);
1684 extent_object (e) = Qnil;
1685 set_extent_start (e, -1);
1686 set_extent_end (e, -1);
1691 extent_face (e) = Qnil;
1692 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1693 e->flags.detachable = 1;
1699 /************************************************************************/
1700 /* Event allocation */
1701 /************************************************************************/
1703 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1704 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1707 allocate_event (void)
1712 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1713 set_lheader_implementation (&e->lheader, &lrecord_event);
1720 /************************************************************************/
1721 /* Marker allocation */
1722 /************************************************************************/
1724 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1725 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1727 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1728 Return a new marker which does not point at any place.
1735 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1736 set_lheader_implementation (&p->lheader, &lrecord_marker);
1739 marker_next (p) = 0;
1740 marker_prev (p) = 0;
1741 p->insertion_type = 0;
1742 XSETMARKER (val, p);
1747 noseeum_make_marker (void)
1752 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1753 set_lheader_implementation (&p->lheader, &lrecord_marker);
1756 marker_next (p) = 0;
1757 marker_prev (p) = 0;
1758 p->insertion_type = 0;
1759 XSETMARKER (val, p);
1764 /************************************************************************/
1765 /* String allocation */
1766 /************************************************************************/
1768 /* The data for "short" strings generally resides inside of structs of type
1769 string_chars_block. The Lisp_String structure is allocated just like any
1770 other Lisp object (except for vectors), and these are freelisted when
1771 they get garbage collected. The data for short strings get compacted,
1772 but the data for large strings do not.
1774 Previously Lisp_String structures were relocated, but this caused a lot
1775 of bus-errors because the C code didn't include enough GCPRO's for
1776 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1777 that the reference would get relocated).
1779 This new method makes things somewhat bigger, but it is MUCH safer. */
1781 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1782 /* strings are used and freed quite often */
1783 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1784 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1787 mark_string (Lisp_Object obj)
1789 Lisp_String *ptr = XSTRING (obj);
1791 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1792 flush_cached_extent_info (XCAR (ptr->plist));
1797 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1800 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1801 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1804 static const struct lrecord_description string_description[] = {
1805 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1806 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1807 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1811 /* We store the string's extent info as the first element of the string's
1812 property list; and the string's MODIFF as the first or second element
1813 of the string's property list (depending on whether the extent info
1814 is present), but only if the string has been modified. This is ugly
1815 but it reduces the memory allocated for the string in the vast
1816 majority of cases, where the string is never modified and has no
1819 #### This means you can't use an int as a key in a string's plist. */
1821 static Lisp_Object *
1822 string_plist_ptr (Lisp_Object string)
1824 Lisp_Object *ptr = &XSTRING (string)->plist;
1826 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
1828 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
1834 string_getprop (Lisp_Object string, Lisp_Object property)
1836 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
1840 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
1842 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
1847 string_remprop (Lisp_Object string, Lisp_Object property)
1849 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
1853 string_plist (Lisp_Object string)
1855 return *string_plist_ptr (string);
1858 /* No `finalize', or `hash' methods.
1859 internal_hash() already knows how to hash strings and finalization
1860 is done with the ADDITIONAL_FREE_string macro, which is the
1861 standard way to do finalization when using
1862 SWEEP_FIXED_TYPE_BLOCK(). */
1863 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
1864 mark_string, print_string,
1873 /* String blocks contain this many useful bytes. */
1874 #define STRING_CHARS_BLOCK_SIZE \
1875 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1876 ((2 * sizeof (struct string_chars_block *)) \
1877 + sizeof (EMACS_INT))))
1878 /* Block header for small strings. */
1879 struct string_chars_block
1882 struct string_chars_block *next;
1883 struct string_chars_block *prev;
1884 /* Contents of string_chars_block->string_chars are interleaved
1885 string_chars structures (see below) and the actual string data */
1886 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1889 static struct string_chars_block *first_string_chars_block;
1890 static struct string_chars_block *current_string_chars_block;
1892 /* If SIZE is the length of a string, this returns how many bytes
1893 * the string occupies in string_chars_block->string_chars
1894 * (including alignment padding).
1896 #define STRING_FULLSIZE(size) \
1897 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1898 ALIGNOF (Lisp_String *))
1900 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1901 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1905 Lisp_String *string;
1906 unsigned char chars[1];
1909 struct unused_string_chars
1911 Lisp_String *string;
1916 init_string_chars_alloc (void)
1918 first_string_chars_block = xnew (struct string_chars_block);
1919 first_string_chars_block->prev = 0;
1920 first_string_chars_block->next = 0;
1921 first_string_chars_block->pos = 0;
1922 current_string_chars_block = first_string_chars_block;
1925 static struct string_chars *
1926 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1929 struct string_chars *s_chars;
1932 (countof (current_string_chars_block->string_chars)
1933 - current_string_chars_block->pos))
1935 /* This string can fit in the current string chars block */
1936 s_chars = (struct string_chars *)
1937 (current_string_chars_block->string_chars
1938 + current_string_chars_block->pos);
1939 current_string_chars_block->pos += fullsize;
1943 /* Make a new current string chars block */
1944 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1946 current_string_chars_block->next = new_scb;
1947 new_scb->prev = current_string_chars_block;
1949 current_string_chars_block = new_scb;
1950 new_scb->pos = fullsize;
1951 s_chars = (struct string_chars *)
1952 current_string_chars_block->string_chars;
1955 s_chars->string = string_it_goes_with;
1957 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1963 make_uninit_string (Bytecount length)
1966 EMACS_INT fullsize = STRING_FULLSIZE (length);
1969 assert (length >= 0 && fullsize > 0);
1971 /* Allocate the string header */
1972 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1973 set_lheader_implementation (&s->lheader, &lrecord_string);
1975 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1976 ? xnew_array (Bufbyte, length + 1)
1977 : allocate_string_chars_struct (s, fullsize)->chars);
1979 set_string_length (s, length);
1982 set_string_byte (s, length, 0);
1984 XSETSTRING (val, s);
1988 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1989 static void verify_string_chars_integrity (void);
1992 /* Resize the string S so that DELTA bytes can be inserted starting
1993 at POS. If DELTA < 0, it means deletion starting at POS. If
1994 POS < 0, resize the string but don't copy any characters. Use
1995 this if you're planning on completely overwriting the string.
1999 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
2001 Bytecount oldfullsize, newfullsize;
2002 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2003 verify_string_chars_integrity ();
2006 #ifdef ERROR_CHECK_BUFPOS
2009 assert (pos <= string_length (s));
2011 assert (pos + (-delta) <= string_length (s));
2016 assert ((-delta) <= string_length (s));
2018 #endif /* ERROR_CHECK_BUFPOS */
2021 /* simplest case: no size change. */
2024 if (pos >= 0 && delta < 0)
2025 /* If DELTA < 0, the functions below will delete the characters
2026 before POS. We want to delete characters *after* POS, however,
2027 so convert this to the appropriate form. */
2030 oldfullsize = STRING_FULLSIZE (string_length (s));
2031 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
2033 if (BIG_STRING_FULLSIZE_P (oldfullsize))
2035 if (BIG_STRING_FULLSIZE_P (newfullsize))
2037 /* Both strings are big. We can just realloc().
2038 But careful! If the string is shrinking, we have to
2039 memmove() _before_ realloc(), and if growing, we have to
2040 memmove() _after_ realloc() - otherwise the access is
2041 illegal, and we might crash. */
2042 Bytecount len = string_length (s) + 1 - pos;
2044 if (delta < 0 && pos >= 0)
2045 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
2046 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
2047 string_length (s) + delta + 1));
2048 if (delta > 0 && pos >= 0)
2049 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
2051 else /* String has been demoted from BIG_STRING. */
2054 allocate_string_chars_struct (s, newfullsize)->chars;
2055 Bufbyte *old_data = string_data (s);
2059 memcpy (new_data, old_data, pos);
2060 memcpy (new_data + pos + delta, old_data + pos,
2061 string_length (s) + 1 - pos);
2063 set_string_data (s, new_data);
2067 else /* old string is small */
2069 if (oldfullsize == newfullsize)
2071 /* special case; size change but the necessary
2072 allocation size won't change (up or down; code
2073 somewhere depends on there not being any unused
2074 allocation space, modulo any alignment
2078 Bufbyte *addroff = pos + string_data (s);
2080 memmove (addroff + delta, addroff,
2081 /* +1 due to zero-termination. */
2082 string_length (s) + 1 - pos);
2087 Bufbyte *old_data = string_data (s);
2089 BIG_STRING_FULLSIZE_P (newfullsize)
2090 ? xnew_array (Bufbyte, string_length (s) + delta + 1)
2091 : allocate_string_chars_struct (s, newfullsize)->chars;
2095 memcpy (new_data, old_data, pos);
2096 memcpy (new_data + pos + delta, old_data + pos,
2097 string_length (s) + 1 - pos);
2099 set_string_data (s, new_data);
2102 /* We need to mark this chunk of the string_chars_block
2103 as unused so that compact_string_chars() doesn't
2105 struct string_chars *old_s_chars = (struct string_chars *)
2106 ((char *) old_data - offsetof (struct string_chars, chars));
2107 /* Sanity check to make sure we aren't hosed by strange
2108 alignment/padding. */
2109 assert (old_s_chars->string == s);
2110 MARK_STRUCT_AS_FREE (old_s_chars);
2111 ((struct unused_string_chars *) old_s_chars)->fullsize =
2117 set_string_length (s, string_length (s) + delta);
2118 /* If pos < 0, the string won't be zero-terminated.
2119 Terminate now just to make sure. */
2120 string_data (s)[string_length (s)] = '\0';
2126 XSETSTRING (string, s);
2127 /* We also have to adjust all of the extent indices after the
2128 place we did the change. We say "pos - 1" because
2129 adjust_extents() is exclusive of the starting position
2131 adjust_extents (string, pos - 1, string_length (s),
2135 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2136 verify_string_chars_integrity ();
2143 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2145 Bufbyte newstr[MAX_EMCHAR_LEN];
2146 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2147 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2148 Bytecount newlen = set_charptr_emchar (newstr, c);
2150 if (oldlen != newlen)
2151 resize_string (s, bytoff, newlen - oldlen);
2152 /* Remember, string_data (s) might have changed so we can't cache it. */
2153 memcpy (string_data (s) + bytoff, newstr, newlen);
2158 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2159 Return a new string of length LENGTH, with each character being INIT.
2160 LENGTH must be an integer and INIT must be a character.
2164 CHECK_NATNUM (length);
2165 CHECK_CHAR_COERCE_INT (init);
2167 Bufbyte init_str[MAX_EMCHAR_LEN];
2168 int len = set_charptr_emchar (init_str, XCHAR (init));
2169 Lisp_Object val = make_uninit_string (len * XINT (length));
2172 /* Optimize the single-byte case */
2173 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2177 Bufbyte *ptr = XSTRING_DATA (val);
2179 for (i = XINT (length); i; i--)
2181 Bufbyte *init_ptr = init_str;
2185 case 6: *ptr++ = *init_ptr++;
2186 case 5: *ptr++ = *init_ptr++;
2188 case 4: *ptr++ = *init_ptr++;
2189 case 3: *ptr++ = *init_ptr++;
2190 case 2: *ptr++ = *init_ptr++;
2191 case 1: *ptr++ = *init_ptr++;
2199 DEFUN ("string", Fstring, 0, MANY, 0, /*
2200 Concatenate all the argument characters and make the result a string.
2202 (int nargs, Lisp_Object *args))
2204 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2205 Bufbyte *p = storage;
2207 for (; nargs; nargs--, args++)
2209 Lisp_Object lisp_char = *args;
2210 CHECK_CHAR_COERCE_INT (lisp_char);
2211 p += set_charptr_emchar (p, XCHAR (lisp_char));
2213 return make_string (storage, p - storage);
2217 /* Take some raw memory, which MUST already be in internal format,
2218 and package it up into a Lisp string. */
2220 make_string (const Bufbyte *contents, Bytecount length)
2224 /* Make sure we find out about bad make_string's when they happen */
2225 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2226 bytecount_to_charcount (contents, length); /* Just for the assertions */
2229 val = make_uninit_string (length);
2230 memcpy (XSTRING_DATA (val), contents, length);
2234 /* Take some raw memory, encoded in some external data format,
2235 and convert it into a Lisp string. */
2237 make_ext_string (const Extbyte *contents, EMACS_INT length,
2238 Lisp_Object coding_system)
2241 TO_INTERNAL_FORMAT (DATA, (contents, length),
2242 LISP_STRING, string,
2248 build_string (const char *str)
2250 /* Some strlen's crash and burn if passed null. */
2251 return make_string ((const Bufbyte *) str, (str ? strlen(str) : 0));
2255 build_ext_string (const char *str, Lisp_Object coding_system)
2257 /* Some strlen's crash and burn if passed null. */
2258 return make_ext_string ((const Extbyte *) str, (str ? strlen(str) : 0),
2263 build_translated_string (const char *str)
2265 return build_string (GETTEXT (str));
2269 make_string_nocopy (const Bufbyte *contents, Bytecount length)
2274 /* Make sure we find out about bad make_string_nocopy's when they happen */
2275 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2276 bytecount_to_charcount (contents, length); /* Just for the assertions */
2279 /* Allocate the string header */
2280 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2281 set_lheader_implementation (&s->lheader, &lrecord_string);
2282 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2284 set_string_data (s, (Bufbyte *)contents);
2285 set_string_length (s, length);
2287 XSETSTRING (val, s);
2292 /************************************************************************/
2293 /* lcrecord lists */
2294 /************************************************************************/
2296 /* Lcrecord lists are used to manage the allocation of particular
2297 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2298 malloc() and garbage-collection junk) as much as possible.
2299 It is similar to the Blocktype class.
2303 1) Create an lcrecord-list object using make_lcrecord_list().
2304 This is often done at initialization. Remember to staticpro_nodump
2305 this object! The arguments to make_lcrecord_list() are the
2306 same as would be passed to alloc_lcrecord().
2307 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2308 and pass the lcrecord-list earlier created.
2309 3) When done with the lcrecord, call free_managed_lcrecord().
2310 The standard freeing caveats apply: ** make sure there are no
2311 pointers to the object anywhere! **
2312 4) Calling free_managed_lcrecord() is just like kissing the
2313 lcrecord goodbye as if it were garbage-collected. This means:
2314 -- the contents of the freed lcrecord are undefined, and the
2315 contents of something produced by allocate_managed_lcrecord()
2316 are undefined, just like for alloc_lcrecord().
2317 -- the mark method for the lcrecord's type will *NEVER* be called
2319 -- the finalize method for the lcrecord's type will be called
2320 at the time that free_managed_lcrecord() is called.
2325 mark_lcrecord_list (Lisp_Object obj)
2327 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2328 Lisp_Object chain = list->free;
2330 while (!NILP (chain))
2332 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2333 struct free_lcrecord_header *free_header =
2334 (struct free_lcrecord_header *) lheader;
2337 (/* There should be no other pointers to the free list. */
2338 ! MARKED_RECORD_HEADER_P (lheader)
2340 /* Only lcrecords should be here. */
2341 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
2343 /* Only free lcrecords should be here. */
2344 free_header->lcheader.free
2346 /* The type of the lcrecord must be right. */
2347 LHEADER_IMPLEMENTATION (lheader) == list->implementation
2349 /* So must the size. */
2350 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2351 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
2354 MARK_RECORD_HEADER (lheader);
2355 chain = free_header->chain;
2361 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2362 mark_lcrecord_list, internal_object_printer,
2363 0, 0, 0, 0, struct lcrecord_list);
2365 make_lcrecord_list (size_t size,
2366 const struct lrecord_implementation *implementation)
2368 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2369 &lrecord_lcrecord_list);
2372 p->implementation = implementation;
2375 XSETLCRECORD_LIST (val, p);
2380 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2382 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2383 if (!NILP (list->free))
2385 Lisp_Object val = list->free;
2386 struct free_lcrecord_header *free_header =
2387 (struct free_lcrecord_header *) XPNTR (val);
2389 #ifdef ERROR_CHECK_GC
2390 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2392 /* There should be no other pointers to the free list. */
2393 assert (! MARKED_RECORD_HEADER_P (lheader));
2394 /* Only lcrecords should be here. */
2395 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
2396 /* Only free lcrecords should be here. */
2397 assert (free_header->lcheader.free);
2398 /* The type of the lcrecord must be right. */
2399 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
2400 /* So must the size. */
2401 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2402 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
2403 #endif /* ERROR_CHECK_GC */
2405 list->free = free_header->chain;
2406 free_header->lcheader.free = 0;
2413 XSETOBJ (val, Lisp_Type_Record,
2414 alloc_lcrecord (list->size, list->implementation));
2420 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2422 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2423 struct free_lcrecord_header *free_header =
2424 (struct free_lcrecord_header *) XPNTR (lcrecord);
2425 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2426 const struct lrecord_implementation *implementation
2427 = LHEADER_IMPLEMENTATION (lheader);
2429 /* Make sure the size is correct. This will catch, for example,
2430 putting a window configuration on the wrong free list. */
2431 gc_checking_assert ((implementation->size_in_bytes_method ?
2432 implementation->size_in_bytes_method (lheader) :
2433 implementation->static_size)
2436 if (implementation->finalizer)
2437 implementation->finalizer (lheader, 0);
2438 free_header->chain = list->free;
2439 free_header->lcheader.free = 1;
2440 list->free = lcrecord;
2446 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2447 Kept for compatibility, returns its argument.
2449 Make a copy of OBJECT in pure storage.
2450 Recursively copies contents of vectors and cons cells.
2451 Does not copy symbols.
2459 /************************************************************************/
2460 /* Garbage Collection */
2461 /************************************************************************/
2463 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
2464 Additional ones may be defined by a module (none yet). We leave some
2465 room in `lrecord_implementations_table' for such new lisp object types. */
2466 #define MODULE_DEFINABLE_TYPE_COUNT 32
2467 const struct lrecord_implementation *lrecord_implementations_table[lrecord_type_count + MODULE_DEFINABLE_TYPE_COUNT];
2469 /* Object marker functions are in the lrecord_implementation structure.
2470 But copying them to a parallel array is much more cache-friendly.
2471 This hack speeds up (garbage-collect) by about 5%. */
2472 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
2474 struct gcpro *gcprolist;
2476 /* 415 used Mly 29-Jun-93 */
2477 /* 1327 used slb 28-Feb-98 */
2478 /* 1328 used og 03-Oct-99 (moving slowly, heh?) */
2480 #define NSTATICS 4000
2482 #define NSTATICS 2000
2485 /* Not "static" because used by dumper.c */
2486 Lisp_Object *staticvec[NSTATICS];
2489 /* Put an entry in staticvec, pointing at the variable whose address is given
2492 staticpro (Lisp_Object *varaddress)
2494 /* #### This is now a dubious assert() since this routine may be called */
2495 /* by Lisp attempting to load a DLL. */
2496 assert (staticidx < countof (staticvec));
2497 staticvec[staticidx++] = varaddress;
2501 Lisp_Object *staticvec_nodump[200];
2502 int staticidx_nodump;
2504 /* Put an entry in staticvec_nodump, pointing at the variable whose address is given
2507 staticpro_nodump (Lisp_Object *varaddress)
2509 /* #### This is now a dubious assert() since this routine may be called */
2510 /* by Lisp attempting to load a DLL. */
2511 assert (staticidx_nodump < countof (staticvec_nodump));
2512 staticvec_nodump[staticidx_nodump++] = varaddress;
2516 struct pdump_dumpstructinfo dumpstructvec[200];
2519 /* Put an entry in dumpstructvec, pointing at the variable whose address is given
2522 dumpstruct (void *varaddress, const struct struct_description *desc)
2524 assert (dumpstructidx < countof (dumpstructvec));
2525 dumpstructvec[dumpstructidx].data = varaddress;
2526 dumpstructvec[dumpstructidx].desc = desc;
2530 struct pdump_dumpopaqueinfo dumpopaquevec[250];
2533 /* Put an entry in dumpopaquevec, pointing at the variable whose address is given
2536 dumpopaque (void *varaddress, size_t size)
2538 assert (dumpopaqueidx < countof (dumpopaquevec));
2540 dumpopaquevec[dumpopaqueidx].data = varaddress;
2541 dumpopaquevec[dumpopaqueidx].size = size;
2545 Lisp_Object *pdump_wirevec[50];
2548 /* Put an entry in pdump_wirevec, pointing at the variable whose address is given
2551 pdump_wire (Lisp_Object *varaddress)
2553 assert (pdump_wireidx < countof (pdump_wirevec));
2554 pdump_wirevec[pdump_wireidx++] = varaddress;
2558 Lisp_Object *pdump_wirevec_list[50];
2559 int pdump_wireidx_list;
2561 /* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given
2564 pdump_wire_list (Lisp_Object *varaddress)
2566 assert (pdump_wireidx_list < countof (pdump_wirevec_list));
2567 pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
2570 #ifdef ERROR_CHECK_GC
2571 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
2572 struct lrecord_header * GCLI_lh = (lheader); \
2573 assert (GCLI_lh != 0); \
2574 assert (GCLI_lh->type < lrecord_type_count); \
2575 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
2576 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
2577 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
2580 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
2584 /* Mark reference to a Lisp_Object. If the object referred to has not been
2585 seen yet, recursively mark all the references contained in it. */
2588 mark_object (Lisp_Object obj)
2592 /* Checks we used to perform */
2593 /* if (EQ (obj, Qnull_pointer)) return; */
2594 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2595 /* if (PURIFIED (XPNTR (obj))) return; */
2597 if (XTYPE (obj) == Lisp_Type_Record)
2599 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2601 GC_CHECK_LHEADER_INVARIANTS (lheader);
2603 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
2604 ! ((struct lcrecord_header *) lheader)->free);
2606 /* All c_readonly objects have their mark bit set,
2607 so that we only need to check the mark bit here. */
2608 if ( (!MARKED_RECORD_HEADER_P (lheader))
2610 && (!OLDER_RECORD_HEADER_P (lheader))
2614 MARK_RECORD_HEADER (lheader);
2616 if (RECORD_MARKER (lheader))
2618 obj = RECORD_MARKER (lheader) (obj);
2619 if (!NILP (obj)) goto tail_recurse;
2625 /* mark all of the conses in a list and mark the final cdr; but
2626 DO NOT mark the cars.
2628 Use only for internal lists! There should never be other pointers
2629 to the cons cells, because if so, the cars will remain unmarked
2630 even when they maybe should be marked. */
2632 mark_conses_in_list (Lisp_Object obj)
2636 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2638 if (CONS_MARKED_P (XCONS (rest)))
2640 MARK_CONS (XCONS (rest));
2647 /* Find all structures not marked, and free them. */
2649 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2650 static int gc_count_bit_vector_storage;
2651 static int gc_count_num_short_string_in_use;
2652 static int gc_count_string_total_size;
2653 static int gc_count_short_string_total_size;
2655 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2658 /* stats on lcrecords in use - kinda kludgy */
2662 int instances_in_use;
2664 int instances_freed;
2666 int instances_on_free_list;
2667 } lcrecord_stats [countof (lrecord_implementations_table)];
2670 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
2672 unsigned int type_index = h->type;
2674 if (((struct lcrecord_header *) h)->free)
2676 gc_checking_assert (!free_p);
2677 lcrecord_stats[type_index].instances_on_free_list++;
2681 const struct lrecord_implementation *implementation =
2682 LHEADER_IMPLEMENTATION (h);
2684 size_t sz = (implementation->size_in_bytes_method ?
2685 implementation->size_in_bytes_method (h) :
2686 implementation->static_size);
2689 lcrecord_stats[type_index].instances_freed++;
2690 lcrecord_stats[type_index].bytes_freed += sz;
2694 lcrecord_stats[type_index].instances_in_use++;
2695 lcrecord_stats[type_index].bytes_in_use += sz;
2701 /* Free all unmarked records */
2703 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2705 struct lcrecord_header *header;
2707 /* int total_size = 0; */
2709 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2711 /* First go through and call all the finalize methods.
2712 Then go through and free the objects. There used to
2713 be only one loop here, with the call to the finalizer
2714 occurring directly before the xfree() below. That
2715 is marginally faster but much less safe -- if the
2716 finalize method for an object needs to reference any
2717 other objects contained within it (and many do),
2718 we could easily be screwed by having already freed that
2721 for (header = *prev; header; header = header->next)
2723 struct lrecord_header *h = &(header->lheader);
2725 GC_CHECK_LHEADER_INVARIANTS (h);
2727 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
2729 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2730 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2734 for (header = *prev; header; )
2736 struct lrecord_header *h = &(header->lheader);
2737 if (MARKED_RECORD_HEADER_P (h))
2739 if (! C_READONLY_RECORD_HEADER_P (h))
2740 UNMARK_RECORD_HEADER (h);
2742 /* total_size += n->implementation->size_in_bytes (h);*/
2743 /* #### May modify header->next on a C_READONLY lcrecord */
2744 prev = &(header->next);
2746 tick_lcrecord_stats (h, 0);
2750 struct lcrecord_header *next = header->next;
2752 tick_lcrecord_stats (h, 1);
2753 /* used to call finalizer right here. */
2759 /* *total = total_size; */
2764 sweep_bit_vectors_1 (Lisp_Object *prev,
2765 int *used, int *total, int *storage)
2767 Lisp_Object bit_vector;
2770 int total_storage = 0;
2772 /* BIT_VECTORP fails because the objects are marked, which changes
2773 their implementation */
2774 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2776 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2778 if (MARKED_RECORD_P (bit_vector))
2780 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
2781 UNMARK_RECORD_HEADER (&(v->lheader));
2785 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2786 BIT_VECTOR_LONG_STORAGE (len));
2788 /* #### May modify next on a C_READONLY bitvector */
2789 prev = &(bit_vector_next (v));
2794 Lisp_Object next = bit_vector_next (v);
2801 *total = total_size;
2802 *storage = total_storage;
2805 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2806 to make macros prettier. */
2808 #ifdef ERROR_CHECK_GC
2810 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2812 struct typename##_block *SFTB_current; \
2813 struct typename##_block **SFTB_prev; \
2815 int num_free = 0, num_used = 0; \
2817 for (SFTB_prev = ¤t_##typename##_block, \
2818 SFTB_current = current_##typename##_block, \
2819 SFTB_limit = current_##typename##_block_index; \
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)) \
2833 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2837 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2840 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2845 UNMARK_##typename (SFTB_victim); \
2848 SFTB_prev = &(SFTB_current->prev); \
2849 SFTB_current = SFTB_current->prev; \
2850 SFTB_limit = countof (current_##typename##_block->block); \
2853 gc_count_num_##typename##_in_use = num_used; \
2854 gc_count_num_##typename##_freelist = num_free; \
2857 #else /* !ERROR_CHECK_GC */
2859 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2861 struct typename##_block *SFTB_current; \
2862 struct typename##_block **SFTB_prev; \
2864 int num_free = 0, num_used = 0; \
2866 typename##_free_list = 0; \
2868 for (SFTB_prev = ¤t_##typename##_block, \
2869 SFTB_current = current_##typename##_block, \
2870 SFTB_limit = current_##typename##_block_index; \
2875 int SFTB_empty = 1; \
2876 obj_type *SFTB_old_free_list = typename##_free_list; \
2878 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2880 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2882 if (FREE_STRUCT_P (SFTB_victim)) \
2885 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2887 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2892 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2895 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2901 UNMARK_##typename (SFTB_victim); \
2906 SFTB_prev = &(SFTB_current->prev); \
2907 SFTB_current = SFTB_current->prev; \
2909 else if (SFTB_current == current_##typename##_block \
2910 && !SFTB_current->prev) \
2912 /* No real point in freeing sole allocation block */ \
2917 struct typename##_block *SFTB_victim_block = SFTB_current; \
2918 if (SFTB_victim_block == current_##typename##_block) \
2919 current_##typename##_block_index \
2920 = countof (current_##typename##_block->block); \
2921 SFTB_current = SFTB_current->prev; \
2923 *SFTB_prev = SFTB_current; \
2924 xfree (SFTB_victim_block); \
2925 /* Restore free list to what it was before victim was swept */ \
2926 typename##_free_list = SFTB_old_free_list; \
2927 num_free -= SFTB_limit; \
2930 SFTB_limit = countof (current_##typename##_block->block); \
2933 gc_count_num_##typename##_in_use = num_used; \
2934 gc_count_num_##typename##_freelist = num_free; \
2937 #endif /* !ERROR_CHECK_GC */
2945 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2946 #define ADDITIONAL_FREE_cons(ptr)
2948 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2951 /* Explicitly free a cons cell. */
2953 free_cons (Lisp_Cons *ptr)
2955 #ifdef ERROR_CHECK_GC
2956 /* If the CAR is not an int, then it will be a pointer, which will
2957 always be four-byte aligned. If this cons cell has already been
2958 placed on the free list, however, its car will probably contain
2959 a chain pointer to the next cons on the list, which has cleverly
2960 had all its 0's and 1's inverted. This allows for a quick
2961 check to make sure we're not freeing something already freed. */
2962 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2963 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2964 #endif /* ERROR_CHECK_GC */
2966 #ifndef ALLOC_NO_POOLS
2967 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2968 #endif /* ALLOC_NO_POOLS */
2971 /* explicitly free a list. You **must make sure** that you have
2972 created all the cons cells that make up this list and that there
2973 are no pointers to any of these cons cells anywhere else. If there
2974 are, you will lose. */
2977 free_list (Lisp_Object list)
2979 Lisp_Object rest, next;
2981 for (rest = list; !NILP (rest); rest = next)
2984 free_cons (XCONS (rest));
2988 /* explicitly free an alist. You **must make sure** that you have
2989 created all the cons cells that make up this alist and that there
2990 are no pointers to any of these cons cells anywhere else. If there
2991 are, you will lose. */
2994 free_alist (Lisp_Object alist)
2996 Lisp_Object rest, next;
2998 for (rest = alist; !NILP (rest); rest = next)
3001 free_cons (XCONS (XCAR (rest)));
3002 free_cons (XCONS (rest));
3007 sweep_compiled_functions (void)
3009 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3010 #define ADDITIONAL_FREE_compiled_function(ptr)
3012 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
3016 #ifdef LISP_FLOAT_TYPE
3020 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3021 #define ADDITIONAL_FREE_float(ptr)
3023 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
3025 #endif /* LISP_FLOAT_TYPE */
3028 sweep_symbols (void)
3030 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3031 #define ADDITIONAL_FREE_symbol(ptr)
3033 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
3037 sweep_extents (void)
3039 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3040 #define ADDITIONAL_FREE_extent(ptr)
3042 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
3048 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3049 #define ADDITIONAL_FREE_event(ptr)
3051 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
3055 sweep_markers (void)
3057 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3058 #define ADDITIONAL_FREE_marker(ptr) \
3059 do { Lisp_Object tem; \
3060 XSETMARKER (tem, ptr); \
3061 unchain_marker (tem); \
3064 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
3067 /* Explicitly free a marker. */
3069 free_marker (Lisp_Marker *ptr)
3071 /* Perhaps this will catch freeing an already-freed marker. */
3072 gc_checking_assert (ptr->lheader.type = lrecord_type_marker);
3074 #ifndef ALLOC_NO_POOLS
3075 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
3076 #endif /* ALLOC_NO_POOLS */
3080 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
3083 verify_string_chars_integrity (void)
3085 struct string_chars_block *sb;
3087 /* Scan each existing string block sequentially, string by string. */
3088 for (sb = first_string_chars_block; sb; sb = sb->next)
3091 /* POS is the index of the next string in the block. */
3092 while (pos < sb->pos)
3094 struct string_chars *s_chars =
3095 (struct string_chars *) &(sb->string_chars[pos]);
3096 Lisp_String *string;
3100 /* If the string_chars struct is marked as free (i.e. the STRING
3101 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3102 storage. (See below.) */
3104 if (FREE_STRUCT_P (s_chars))
3106 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3111 string = s_chars->string;
3112 /* Must be 32-bit aligned. */
3113 assert ((((int) string) & 3) == 0);
3115 size = string_length (string);
3116 fullsize = STRING_FULLSIZE (size);
3118 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3119 assert (string_data (string) == s_chars->chars);
3122 assert (pos == sb->pos);
3126 #endif /* MULE && ERROR_CHECK_GC */
3128 /* Compactify string chars, relocating the reference to each --
3129 free any empty string_chars_block we see. */
3131 compact_string_chars (void)
3133 struct string_chars_block *to_sb = first_string_chars_block;
3135 struct string_chars_block *from_sb;
3137 /* Scan each existing string block sequentially, string by string. */
3138 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3141 /* FROM_POS is the index of the next string in the block. */
3142 while (from_pos < from_sb->pos)
3144 struct string_chars *from_s_chars =
3145 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3146 struct string_chars *to_s_chars;
3147 Lisp_String *string;
3151 /* If the string_chars struct is marked as free (i.e. the STRING
3152 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3153 storage. This happens under Mule when a string's size changes
3154 in such a way that its fullsize changes. (Strings can change
3155 size because a different-length character can be substituted
3156 for another character.) In this case, after the bogus string
3157 pointer is the "fullsize" of this entry, i.e. how many bytes
3160 if (FREE_STRUCT_P (from_s_chars))
3162 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3163 from_pos += fullsize;
3167 string = from_s_chars->string;
3168 assert (!(FREE_STRUCT_P (string)));
3170 size = string_length (string);
3171 fullsize = STRING_FULLSIZE (size);
3173 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
3175 /* Just skip it if it isn't marked. */
3176 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3178 from_pos += fullsize;
3182 /* If it won't fit in what's left of TO_SB, close TO_SB out
3183 and go on to the next string_chars_block. We know that TO_SB
3184 cannot advance past FROM_SB here since FROM_SB is large enough
3185 to currently contain this string. */
3186 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3188 to_sb->pos = to_pos;
3189 to_sb = to_sb->next;
3193 /* Compute new address of this string
3194 and update TO_POS for the space being used. */
3195 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3197 /* Copy the string_chars to the new place. */
3198 if (from_s_chars != to_s_chars)
3199 memmove (to_s_chars, from_s_chars, fullsize);
3201 /* Relocate FROM_S_CHARS's reference */
3202 set_string_data (string, &(to_s_chars->chars[0]));
3204 from_pos += fullsize;
3209 /* Set current to the last string chars block still used and
3210 free any that follow. */
3212 struct string_chars_block *victim;
3214 for (victim = to_sb->next; victim; )
3216 struct string_chars_block *next = victim->next;
3221 current_string_chars_block = to_sb;
3222 current_string_chars_block->pos = to_pos;
3223 current_string_chars_block->next = 0;
3227 #if 1 /* Hack to debug missing purecopy's */
3228 static int debug_string_purity;
3231 debug_string_purity_print (Lisp_String *p)
3234 Charcount s = string_char_length (p);
3236 for (i = 0; i < s; i++)
3238 Emchar ch = string_char (p, i);
3239 if (ch < 32 || ch >= 126)
3240 stderr_out ("\\%03o", ch);
3241 else if (ch == '\\' || ch == '\"')
3242 stderr_out ("\\%c", ch);
3244 stderr_out ("%c", ch);
3246 stderr_out ("\"\n");
3252 sweep_strings (void)
3254 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3255 int debug = debug_string_purity;
3257 #define UNMARK_string(ptr) do { \
3258 Lisp_String *p = (ptr); \
3259 size_t size = string_length (p); \
3260 UNMARK_RECORD_HEADER (&(p->lheader)); \
3261 num_bytes += size; \
3262 if (!BIG_STRING_SIZE_P (size)) \
3264 num_small_bytes += size; \
3268 debug_string_purity_print (p); \
3270 #define ADDITIONAL_FREE_string(ptr) do { \
3271 size_t size = string_length (ptr); \
3272 if (BIG_STRING_SIZE_P (size)) \
3273 xfree (ptr->data); \
3276 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3278 gc_count_num_short_string_in_use = num_small_used;
3279 gc_count_string_total_size = num_bytes;
3280 gc_count_short_string_total_size = num_small_bytes;
3284 /* I hate duplicating all this crap! */
3286 marked_p (Lisp_Object obj)
3288 /* Checks we used to perform. */
3289 /* if (EQ (obj, Qnull_pointer)) return 1; */
3290 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3291 /* if (PURIFIED (XPNTR (obj))) return 1; */
3293 if (XTYPE (obj) == Lisp_Type_Record)
3295 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3297 GC_CHECK_LHEADER_INVARIANTS (lheader);
3299 return MARKED_RECORD_HEADER_P (lheader);
3307 /* Free all unmarked records. Do this at the very beginning,
3308 before anything else, so that the finalize methods can safely
3309 examine items in the objects. sweep_lcrecords_1() makes
3310 sure to call all the finalize methods *before* freeing anything,
3311 to complete the safety. */
3314 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3317 compact_string_chars ();
3319 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3320 macros) must be *extremely* careful to make sure they're not
3321 referencing freed objects. The only two existing finalize
3322 methods (for strings and markers) pass muster -- the string
3323 finalizer doesn't look at anything but its own specially-
3324 created block, and the marker finalizer only looks at live
3325 buffers (which will never be freed) and at the markers before
3326 and after it in the chain (which, by induction, will never be
3327 freed because if so, they would have already removed themselves
3330 /* Put all unmarked strings on free list, free'ing the string chars
3331 of large unmarked strings */
3334 /* Put all unmarked conses on free list */
3337 /* Free all unmarked bit vectors */
3338 sweep_bit_vectors_1 (&all_bit_vectors,
3339 &gc_count_num_bit_vector_used,
3340 &gc_count_bit_vector_total_size,
3341 &gc_count_bit_vector_storage);
3343 /* Free all unmarked compiled-function objects */
3344 sweep_compiled_functions ();
3346 #ifdef LISP_FLOAT_TYPE
3347 /* Put all unmarked floats on free list */
3351 /* Put all unmarked symbols on free list */
3354 /* Put all unmarked extents on free list */
3357 /* Put all unmarked markers on free list.
3358 Dechain each one first from the buffer into which it points. */
3364 pdump_objects_unmark ();
3368 /* Clearing for disksave. */
3371 disksave_object_finalization (void)
3373 /* It's important that certain information from the environment not get
3374 dumped with the executable (pathnames, environment variables, etc.).
3375 To make it easier to tell when this has happened with strings(1) we
3376 clear some known-to-be-garbage blocks of memory, so that leftover
3377 results of old evaluation don't look like potential problems.
3378 But first we set some notable variables to nil and do one more GC,
3379 to turn those strings into garbage.
3382 /* Yeah, this list is pretty ad-hoc... */
3383 Vprocess_environment = Qnil;
3384 Vexec_directory = Qnil;
3385 Vdata_directory = Qnil;
3386 Vsite_directory = Qnil;
3387 Vdoc_directory = Qnil;
3388 Vconfigure_info_directory = Qnil;
3391 /* Vdump_load_path = Qnil; */
3392 /* Release hash tables for locate_file */
3393 Flocate_file_clear_hashing (Qt);
3394 uncache_home_directory();
3396 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3397 defined(LOADHIST_BUILTIN))
3398 Vload_history = Qnil;
3400 Vshell_file_name = Qnil;
3402 garbage_collect_1 ();
3404 /* Run the disksave finalization methods of all live objects. */
3405 disksave_object_finalization_1 ();
3407 /* Zero out the uninitialized (really, unused) part of the containers
3408 for the live strings. */
3410 struct string_chars_block *scb;
3411 for (scb = first_string_chars_block; scb; scb = scb->next)
3413 int count = sizeof (scb->string_chars) - scb->pos;
3415 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3418 /* from the block's fill ptr to the end */
3419 memset ((scb->string_chars + scb->pos), 0, count);
3424 /* There, that ought to be enough... */
3430 restore_gc_inhibit (Lisp_Object val)
3432 gc_currently_forbidden = XINT (val);
3436 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3437 static int gc_hooks_inhibited;
3441 garbage_collect_1 (void)
3443 #if MAX_SAVE_STACK > 0
3444 char stack_top_variable;
3445 extern char *stack_bottom;
3450 Lisp_Object pre_gc_cursor;
3451 struct gcpro gcpro1;
3454 || gc_currently_forbidden
3456 || preparing_for_armageddon)
3459 /* We used to call selected_frame() here.
3461 The following functions cannot be called inside GC
3462 so we move to after the above tests. */
3465 Lisp_Object device = Fselected_device (Qnil);
3466 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3468 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3470 signal_simple_error ("No frames exist on device", device);
3474 pre_gc_cursor = Qnil;
3477 GCPRO1 (pre_gc_cursor);
3479 /* Very important to prevent GC during any of the following
3480 stuff that might run Lisp code; otherwise, we'll likely
3481 have infinite GC recursion. */
3482 speccount = specpdl_depth ();
3483 record_unwind_protect (restore_gc_inhibit,
3484 make_int (gc_currently_forbidden));
3485 gc_currently_forbidden = 1;
3487 if (!gc_hooks_inhibited)
3488 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3490 /* Now show the GC cursor/message. */
3491 if (!noninteractive)
3493 if (FRAME_WIN_P (f))
3495 Lisp_Object frame = make_frame (f);
3496 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3497 FRAME_SELECTED_WINDOW (f),
3499 pre_gc_cursor = f->pointer;
3500 if (POINTER_IMAGE_INSTANCEP (cursor)
3501 /* don't change if we don't know how to change back. */
3502 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3505 Fset_frame_pointer (frame, cursor);
3509 /* Don't print messages to the stream device. */
3510 if (!cursor_changed && !FRAME_STREAM_P (f))
3512 char *msg = (STRINGP (Vgc_message)
3513 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3515 Lisp_Object args[2], whole_msg;
3516 args[0] = build_string (msg ? msg :
3517 GETTEXT ((const char *) gc_default_message));
3518 args[1] = build_string ("...");
3519 whole_msg = Fconcat (2, args);
3520 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3521 Qgarbage_collecting);
3525 /***** Now we actually start the garbage collection. */
3529 gc_generation_number[0]++;
3531 #if MAX_SAVE_STACK > 0
3533 /* Save a copy of the contents of the stack, for debugging. */
3536 /* Static buffer in which we save a copy of the C stack at each GC. */
3537 static char *stack_copy;
3538 static size_t stack_copy_size;
3540 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3541 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3542 if (stack_size < MAX_SAVE_STACK)
3544 if (stack_copy_size < stack_size)
3546 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3547 stack_copy_size = stack_size;
3551 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3555 #endif /* MAX_SAVE_STACK > 0 */
3557 /* Do some totally ad-hoc resource clearing. */
3558 /* #### generalize this? */
3559 clear_event_resource ();
3560 cleanup_specifiers ();
3562 /* Mark all the special slots that serve as the roots of accessibility. */
3566 for (i = 0; i < staticidx; i++)
3567 mark_object (*(staticvec[i]));
3568 for (i = 0; i < staticidx_nodump; i++)
3569 mark_object (*(staticvec_nodump[i]));
3575 for (tail = gcprolist; tail; tail = tail->next)
3576 for (i = 0; i < tail->nvars; i++)
3577 mark_object (tail->var[i]);
3581 struct specbinding *bind;
3582 for (bind = specpdl; bind != specpdl_ptr; bind++)
3584 mark_object (bind->symbol);
3585 mark_object (bind->old_value);
3590 struct catchtag *catch;
3591 for (catch = catchlist; catch; catch = catch->next)
3593 mark_object (catch->tag);
3594 mark_object (catch->val);
3599 struct backtrace *backlist;
3600 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3602 int nargs = backlist->nargs;
3605 mark_object (*backlist->function);
3606 if (nargs == UNEVALLED || nargs == MANY)
3607 mark_object (backlist->args[0]);
3609 for (i = 0; i < nargs; i++)
3610 mark_object (backlist->args[i]);
3615 mark_profiling_info ();
3617 /* OK, now do the after-mark stuff. This is for things that
3618 are only marked when something else is marked (e.g. weak hash tables).
3619 There may be complex dependencies between such objects -- e.g.
3620 a weak hash table might be unmarked, but after processing a later
3621 weak hash table, the former one might get marked. So we have to
3622 iterate until nothing more gets marked. */
3624 while (finish_marking_weak_hash_tables () > 0 ||
3625 finish_marking_weak_lists () > 0)
3628 /* And prune (this needs to be called after everything else has been
3629 marked and before we do any sweeping). */
3630 /* #### this is somewhat ad-hoc and should probably be an object
3632 prune_weak_hash_tables ();
3633 prune_weak_lists ();
3634 prune_specifiers ();
3635 prune_syntax_tables ();
3639 consing_since_gc = 0;
3640 #ifndef DEBUG_XEMACS
3641 /* Allow you to set it really fucking low if you really want ... */
3642 if (gc_cons_threshold < 10000)
3643 gc_cons_threshold = 10000;
3648 /******* End of garbage collection ********/
3650 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3652 /* Now remove the GC cursor/message */
3653 if (!noninteractive)
3656 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3657 else if (!FRAME_STREAM_P (f))
3659 char *msg = (STRINGP (Vgc_message)
3660 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3663 /* Show "...done" only if the echo area would otherwise be empty. */
3664 if (NILP (clear_echo_area (selected_frame (),
3665 Qgarbage_collecting, 0)))
3667 Lisp_Object args[2], whole_msg;
3668 args[0] = build_string (msg ? msg :
3669 GETTEXT ((const char *)
3670 gc_default_message));
3671 args[1] = build_string ("... done");
3672 whole_msg = Fconcat (2, args);
3673 echo_area_message (selected_frame (), (Bufbyte *) 0,
3675 Qgarbage_collecting);
3680 /* now stop inhibiting GC */
3681 unbind_to (speccount, Qnil);
3683 if (!breathing_space)
3685 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3692 /* Debugging aids. */
3695 gc_plist_hack (const char *name, int value, Lisp_Object tail)
3697 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3698 or portable numeric datatypes, or bit-vectors, or characters, or
3699 arrays, or exceptions, or ...) */
3700 return cons3 (intern (name), make_int (value), tail);
3703 #define HACK_O_MATIC(type, name, pl) do { \
3705 struct type##_block *x = current_##type##_block; \
3706 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3707 (pl) = gc_plist_hack ((name), s, (pl)); \
3710 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3711 Reclaim storage for Lisp objects no longer needed.
3712 Return info on amount of space in use:
3713 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3714 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3716 where `PLIST' is a list of alternating keyword/value pairs providing
3717 more detailed information.
3718 Garbage collection happens automatically if you cons more than
3719 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3723 Lisp_Object pl = Qnil;
3725 int gc_count_vector_total_size = 0;
3727 garbage_collect_1 ();
3729 for (i = 0; i < lrecord_type_count; i++)
3731 if (lcrecord_stats[i].bytes_in_use != 0
3732 || lcrecord_stats[i].bytes_freed != 0
3733 || lcrecord_stats[i].instances_on_free_list != 0)
3736 const char *name = lrecord_implementations_table[i]->name;
3737 int len = strlen (name);
3738 /* save this for the FSFmacs-compatible part of the summary */
3739 if (i == lrecord_vector.lrecord_type_index)
3740 gc_count_vector_total_size =
3741 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3743 sprintf (buf, "%s-storage", name);
3744 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3745 /* Okay, simple pluralization check for `symbol-value-varalias' */
3746 if (name[len-1] == 's')
3747 sprintf (buf, "%ses-freed", name);
3749 sprintf (buf, "%ss-freed", name);
3750 if (lcrecord_stats[i].instances_freed != 0)
3751 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3752 if (name[len-1] == 's')
3753 sprintf (buf, "%ses-on-free-list", name);
3755 sprintf (buf, "%ss-on-free-list", name);
3756 if (lcrecord_stats[i].instances_on_free_list != 0)
3757 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3759 if (name[len-1] == 's')
3760 sprintf (buf, "%ses-used", name);
3762 sprintf (buf, "%ss-used", name);
3763 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3767 HACK_O_MATIC (extent, "extent-storage", pl);
3768 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3769 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3770 HACK_O_MATIC (event, "event-storage", pl);
3771 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3772 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3773 HACK_O_MATIC (marker, "marker-storage", pl);
3774 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3775 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3776 #ifdef LISP_FLOAT_TYPE
3777 HACK_O_MATIC (float, "float-storage", pl);
3778 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3779 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3780 #endif /* LISP_FLOAT_TYPE */
3781 HACK_O_MATIC (string, "string-header-storage", pl);
3782 pl = gc_plist_hack ("long-strings-total-length",
3783 gc_count_string_total_size
3784 - gc_count_short_string_total_size, pl);
3785 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3786 pl = gc_plist_hack ("short-strings-total-length",
3787 gc_count_short_string_total_size, pl);
3788 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3789 pl = gc_plist_hack ("long-strings-used",
3790 gc_count_num_string_in_use
3791 - gc_count_num_short_string_in_use, pl);
3792 pl = gc_plist_hack ("short-strings-used",
3793 gc_count_num_short_string_in_use, pl);
3795 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3796 pl = gc_plist_hack ("compiled-functions-free",
3797 gc_count_num_compiled_function_freelist, pl);
3798 pl = gc_plist_hack ("compiled-functions-used",
3799 gc_count_num_compiled_function_in_use, pl);
3801 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3802 pl = gc_plist_hack ("bit-vectors-total-length",
3803 gc_count_bit_vector_total_size, pl);
3804 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3806 HACK_O_MATIC (symbol, "symbol-storage", pl);
3807 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3808 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3810 HACK_O_MATIC (cons, "cons-storage", pl);
3811 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3812 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3814 /* The things we do for backwards-compatibility */
3816 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3817 make_int (gc_count_num_cons_freelist)),
3818 Fcons (make_int (gc_count_num_symbol_in_use),
3819 make_int (gc_count_num_symbol_freelist)),
3820 Fcons (make_int (gc_count_num_marker_in_use),
3821 make_int (gc_count_num_marker_freelist)),
3822 make_int (gc_count_string_total_size),
3823 make_int (gc_count_vector_total_size),
3828 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3829 Return the number of bytes consed since the last garbage collection.
3830 \"Consed\" is a misnomer in that this actually counts allocation
3831 of all different kinds of objects, not just conses.
3833 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3837 return make_int (consing_since_gc);
3841 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
3842 Return the address of the last byte Emacs has allocated, divided by 1024.
3843 This may be helpful in debugging Emacs's memory usage.
3844 The value is divided by 1024 to make sure it will fit in a lisp integer.
3848 return make_int ((EMACS_INT) sbrk (0) / 1024);
3854 object_dead_p (Lisp_Object obj)
3856 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3857 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3858 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3859 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3860 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3861 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3862 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3865 #ifdef MEMORY_USAGE_STATS
3867 /* Attempt to determine the actual amount of space that is used for
3868 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3870 It seems that the following holds:
3872 1. When using the old allocator (malloc.c):
3874 -- blocks are always allocated in chunks of powers of two. For
3875 each block, there is an overhead of 8 bytes if rcheck is not
3876 defined, 20 bytes if it is defined. In other words, a
3877 one-byte allocation needs 8 bytes of overhead for a total of
3878 9 bytes, and needs to have 16 bytes of memory chunked out for
3881 2. When using the new allocator (gmalloc.c):
3883 -- blocks are always allocated in chunks of powers of two up
3884 to 4096 bytes. Larger blocks are allocated in chunks of
3885 an integral multiple of 4096 bytes. The minimum block
3886 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3887 is defined. There is no per-block overhead, but there
3888 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3891 3. When using the system malloc, anything goes, but they are
3892 generally slower and more space-efficient than the GNU
3893 allocators. One possibly reasonable assumption to make
3894 for want of better data is that sizeof (void *), or maybe
3895 2 * sizeof (void *), is required as overhead and that
3896 blocks are allocated in the minimum required size except
3897 that some minimum block size is imposed (e.g. 16 bytes). */
3900 malloced_storage_size (void *ptr, size_t claimed_size,
3901 struct overhead_stats *stats)
3903 size_t orig_claimed_size = claimed_size;
3907 if (claimed_size < 2 * sizeof (void *))
3908 claimed_size = 2 * sizeof (void *);
3909 # ifdef SUNOS_LOCALTIME_BUG
3910 if (claimed_size < 16)
3913 if (claimed_size < 4096)
3917 /* compute the log base two, more or less, then use it to compute
3918 the block size needed. */
3920 /* It's big, it's heavy, it's wood! */
3921 while ((claimed_size /= 2) != 0)
3924 /* It's better than bad, it's good! */
3930 /* We have to come up with some average about the amount of
3932 if ((size_t) (rand () & 4095) < claimed_size)
3933 claimed_size += 3 * sizeof (void *);
3937 claimed_size += 4095;
3938 claimed_size &= ~4095;
3939 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3942 #elif defined (SYSTEM_MALLOC)
3944 if (claimed_size < 16)
3946 claimed_size += 2 * sizeof (void *);
3948 #else /* old GNU allocator */
3950 # ifdef rcheck /* #### may not be defined here */
3958 /* compute the log base two, more or less, then use it to compute
3959 the block size needed. */
3961 /* It's big, it's heavy, it's wood! */
3962 while ((claimed_size /= 2) != 0)
3965 /* It's better than bad, it's good! */
3973 #endif /* old GNU allocator */
3977 stats->was_requested += orig_claimed_size;
3978 stats->malloc_overhead += claimed_size - orig_claimed_size;
3980 return claimed_size;
3984 fixed_type_block_overhead (size_t size)
3986 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3987 size_t overhead = 0;
3988 size_t storage_size = malloced_storage_size (0, per_block, 0);
3989 while (size >= per_block)
3992 overhead += sizeof (void *) + per_block - storage_size;
3994 if (rand () % per_block < size)
3995 overhead += sizeof (void *) + per_block - storage_size;
3999 #endif /* MEMORY_USAGE_STATS */
4002 /* Initialization */
4004 reinit_alloc_once_early (void)
4006 gc_generation_number[0] = 0;
4007 breathing_space = 0;
4008 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
4009 XSETINT (Vgc_message, 0);
4012 all_older_lcrecords = 0;
4014 ignore_malloc_warnings = 1;
4015 #ifdef DOUG_LEA_MALLOC
4016 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
4017 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
4018 #if 0 /* Moved to emacs.c */
4019 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
4022 init_string_alloc ();
4023 init_string_chars_alloc ();
4025 init_symbol_alloc ();
4026 init_compiled_function_alloc ();
4027 #ifdef LISP_FLOAT_TYPE
4028 init_float_alloc ();
4029 #endif /* LISP_FLOAT_TYPE */
4030 init_marker_alloc ();
4031 init_extent_alloc ();
4032 init_event_alloc ();
4034 ignore_malloc_warnings = 0;
4036 staticidx_nodump = 0;
4040 consing_since_gc = 0;
4042 gc_cons_threshold = 500000; /* XEmacs change */
4044 gc_cons_threshold = 15000; /* debugging */
4046 #ifdef VIRT_ADDR_VARIES
4047 malloc_sbrk_unused = 1<<22; /* A large number */
4048 malloc_sbrk_used = 100000; /* as reasonable as any number */
4049 #endif /* VIRT_ADDR_VARIES */
4050 lrecord_uid_counter = 259;
4051 debug_string_purity = 0;
4054 gc_currently_forbidden = 0;
4055 gc_hooks_inhibited = 0;
4057 #ifdef ERROR_CHECK_TYPECHECK
4058 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4061 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
4063 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4065 #endif /* ERROR_CHECK_TYPECHECK */
4069 init_alloc_once_early (void)
4071 reinit_alloc_once_early ();
4075 for (i = 0; i < countof (lrecord_implementations_table); i++)
4076 lrecord_implementations_table[i] = 0;
4079 INIT_LRECORD_IMPLEMENTATION (cons);
4080 INIT_LRECORD_IMPLEMENTATION (vector);
4081 INIT_LRECORD_IMPLEMENTATION (string);
4082 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
4087 int pure_bytes_used = 0;
4096 syms_of_alloc (void)
4098 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
4099 defsymbol (&Qpost_gc_hook, "post-gc-hook");
4100 defsymbol (&Qgarbage_collecting, "garbage-collecting");
4105 DEFSUBR (Fbit_vector);
4106 DEFSUBR (Fmake_byte_code);
4107 DEFSUBR (Fmake_list);
4108 DEFSUBR (Fmake_vector);
4109 DEFSUBR (Fmake_bit_vector);
4110 DEFSUBR (Fmake_string);
4112 DEFSUBR (Fmake_symbol);
4113 DEFSUBR (Fmake_marker);
4114 DEFSUBR (Fpurecopy);
4115 DEFSUBR (Fgarbage_collect);
4117 DEFSUBR (Fmemory_limit);
4119 DEFSUBR (Fconsing_since_gc);
4123 vars_of_alloc (void)
4125 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
4126 *Number of bytes of consing between garbage collections.
4127 \"Consing\" is a misnomer in that this actually counts allocation
4128 of all different kinds of objects, not just conses.
4129 Garbage collection can happen automatically once this many bytes have been
4130 allocated since the last garbage collection. All data types count.
4132 Garbage collection happens automatically when `eval' or `funcall' are
4133 called. (Note that `funcall' is called implicitly as part of evaluation.)
4134 By binding this temporarily to a large number, you can effectively
4135 prevent garbage collection during a part of the program.
4137 See also `consing-since-gc'.
4140 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
4141 Number of bytes of sharable Lisp data allocated so far.
4145 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
4146 Number of bytes of unshared memory allocated in this session.
4149 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
4150 Number of bytes of unshared memory remaining available in this session.
4155 DEFVAR_INT ("debug-allocation", &debug_allocation /*
4156 If non-zero, print out information to stderr about all objects allocated.
4157 See also `debug-allocation-backtrace-length'.
4159 debug_allocation = 0;
4161 DEFVAR_INT ("debug-allocation-backtrace-length",
4162 &debug_allocation_backtrace_length /*
4163 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4165 debug_allocation_backtrace_length = 2;
4168 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4169 Non-nil means loading Lisp code in order to dump an executable.
4170 This means that certain objects should be allocated in readonly space.
4173 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4174 Function or functions to be run just before each garbage collection.
4175 Interrupts, garbage collection, and errors are inhibited while this hook
4176 runs, so be extremely careful in what you add here. In particular, avoid
4177 consing, and do not interact with the user.
4179 Vpre_gc_hook = Qnil;
4181 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4182 Function or functions to be run just after each garbage collection.
4183 Interrupts, garbage collection, and errors are inhibited while this hook
4184 runs, so be extremely careful in what you add here. In particular, avoid
4185 consing, and do not interact with the user.
4187 Vpost_gc_hook = Qnil;
4189 DEFVAR_LISP ("gc-message", &Vgc_message /*
4190 String to print to indicate that a garbage collection is in progress.
4191 This is printed in the echo area. If the selected frame is on a
4192 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4193 image instance) in the domain of the selected frame, the mouse pointer
4194 will change instead of this message being printed.
4196 Vgc_message = build_string (gc_default_message);
4198 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4199 Pointer glyph used to indicate that a garbage collection is in progress.
4200 If the selected window is on a window system and this glyph specifies a
4201 value (i.e. a pointer image instance) in the domain of the selected
4202 window, the pointer will be changed as specified during garbage collection.
4203 Otherwise, a message will be printed in the echo area, as controlled
4209 complex_vars_of_alloc (void)
4211 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);