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 /* Non-zero means we're in the process of doing the dump */
165 #ifdef ERROR_CHECK_TYPECHECK
167 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
172 c_readonly (Lisp_Object obj)
174 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
178 lisp_readonly (Lisp_Object obj)
180 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
184 /* Maximum amount of C stack to save when a GC happens. */
186 #ifndef MAX_SAVE_STACK
187 #define MAX_SAVE_STACK 0 /* 16000 */
190 /* Non-zero means ignore malloc warnings. Set during initialization. */
191 int ignore_malloc_warnings;
194 static void *breathing_space;
197 release_breathing_space (void)
201 void *tmp = breathing_space;
207 /* malloc calls this if it finds we are near exhausting storage */
209 malloc_warning (const char *str)
211 if (ignore_malloc_warnings)
217 "Killing some buffers may delay running out of memory.\n"
218 "However, certainly by the time you receive the 95%% warning,\n"
219 "you should clean up, kill this Emacs, and start a new one.",
223 /* Called if malloc returns zero */
227 /* Force a GC next time eval is called.
228 It's better to loop garbage-collecting (we might reclaim enough
229 to win) than to loop beeping and barfing "Memory exhausted"
231 consing_since_gc = gc_cons_threshold + 1;
232 release_breathing_space ();
234 /* Flush some histories which might conceivably contain garbalogical
236 if (!NILP (Fboundp (Qvalues)))
237 Fset (Qvalues, Qnil);
238 Vcommand_history = Qnil;
240 error ("Memory exhausted");
243 /* like malloc and realloc but check for no memory left, and block input. */
247 xmalloc (size_t size)
249 void *val = malloc (size);
251 if (!val && (size != 0)) memory_full ();
257 xcalloc (size_t nelem, size_t elsize)
259 void *val = calloc (nelem, elsize);
261 if (!val && (nelem != 0)) memory_full ();
266 xmalloc_and_zero (size_t size)
268 return xcalloc (size, sizeof (char));
273 xrealloc (void *block, size_t size)
275 /* We must call malloc explicitly when BLOCK is 0, since some
276 reallocs don't do this. */
277 void *val = block ? realloc (block, size) : malloc (size);
279 if (!val && (size != 0)) memory_full ();
284 #ifdef ERROR_CHECK_MALLOC
285 xfree_1 (void *block)
290 #ifdef ERROR_CHECK_MALLOC
291 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
292 error until much later on for many system mallocs, such as
293 the one that comes with Solaris 2.3. FMH!! */
294 assert (block != (void *) 0xDEADBEEF);
296 #endif /* ERROR_CHECK_MALLOC */
300 #ifdef ERROR_CHECK_GC
303 typedef unsigned int four_byte_t;
304 #elif SIZEOF_LONG == 4
305 typedef unsigned long four_byte_t;
306 #elif SIZEOF_SHORT == 4
307 typedef unsigned short four_byte_t;
309 What kind of strange-ass system are we running on?
313 deadbeef_memory (void *ptr, size_t size)
315 four_byte_t *ptr4 = (four_byte_t *) ptr;
316 size_t beefs = size >> 2;
318 /* In practice, size will always be a multiple of four. */
320 (*ptr4++) = 0xDEADBEEF;
323 #else /* !ERROR_CHECK_GC */
326 #define deadbeef_memory(ptr, size)
328 #endif /* !ERROR_CHECK_GC */
332 xstrdup (const char *str)
334 int len = strlen (str) + 1; /* for stupid terminating 0 */
336 void *val = xmalloc (len);
337 if (val == 0) return 0;
338 return (char *) memcpy (val, str, len);
343 strdup (const char *s)
347 #endif /* NEED_STRDUP */
351 allocate_lisp_storage (size_t size)
353 return xmalloc (size);
357 /* lcrecords are chained together through their "next" field.
358 After doing the mark phase, GC will walk this linked list
359 and free any lcrecord which hasn't been marked. */
360 static struct lcrecord_header *all_lcrecords;
362 static struct lcrecord_header *all_older_lcrecords;
366 alloc_lcrecord (size_t size, const struct lrecord_implementation *implementation)
368 struct lcrecord_header *lcheader;
371 ((implementation->static_size == 0 ?
372 implementation->size_in_bytes_method != NULL :
373 implementation->static_size == size)
375 (! implementation->basic_p)
377 (! (implementation->hash == NULL && implementation->equal != NULL)));
379 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
380 set_lheader_implementation (&lcheader->lheader, implementation);
381 lcheader->next = all_lcrecords;
382 #if 1 /* mly prefers to see small ID numbers */
383 lcheader->uid = lrecord_uid_counter++;
384 #else /* jwz prefers to see real addrs */
385 lcheader->uid = (int) &lcheader;
388 all_lcrecords = lcheader;
389 INCREMENT_CONS_COUNTER (size, implementation->name);
395 alloc_older_lcrecord (size_t size,
396 const struct lrecord_implementation *implementation)
398 struct lcrecord_header *lcheader;
401 ((implementation->static_size == 0 ?
402 implementation->size_in_bytes_method != NULL :
403 implementation->static_size == size)
405 (! implementation->basic_p)
407 (! (implementation->hash == NULL && implementation->equal != NULL)));
409 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
410 set_lheader_older_implementation (&lcheader->lheader, implementation);
411 lcheader->next = all_older_lcrecords;
412 #if 1 /* mly prefers to see small ID numbers */
413 lcheader->uid = lrecord_uid_counter++;
414 #else /* jwz prefers to see real addrs */
415 lcheader->uid = (int) &lcheader;
418 all_older_lcrecords = lcheader;
419 INCREMENT_CONS_COUNTER (size, implementation->name);
424 #if 0 /* Presently unused */
425 /* Very, very poor man's EGC?
426 * This may be slow and thrash pages all over the place.
427 * Only call it if you really feel you must (and if the
428 * lrecord was fairly recently allocated).
429 * Otherwise, just let the GC do its job -- that's what it's there for
432 free_lcrecord (struct lcrecord_header *lcrecord)
434 if (all_lcrecords == lcrecord)
436 all_lcrecords = lcrecord->next;
440 struct lrecord_header *header = all_lcrecords;
443 struct lrecord_header *next = header->next;
444 if (next == lcrecord)
446 header->next = lrecord->next;
455 if (lrecord->implementation->finalizer)
456 lrecord->implementation->finalizer (lrecord, 0);
464 disksave_object_finalization_1 (void)
466 struct lcrecord_header *header;
468 for (header = all_lcrecords; header; header = header->next)
470 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
472 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
475 for (header = all_older_lcrecords; header; header = header->next)
477 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
479 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
485 /************************************************************************/
486 /* Debugger support */
487 /************************************************************************/
488 /* Give gdb/dbx enough information to decode Lisp Objects. We make
489 sure certain symbols are always defined, so gdb doesn't complain
490 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
491 to see how this is used. */
493 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
494 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
496 #ifdef USE_UNION_TYPE
497 unsigned char dbg_USE_UNION_TYPE = 1;
499 unsigned char dbg_USE_UNION_TYPE = 0;
502 unsigned char dbg_valbits = VALBITS;
503 unsigned char dbg_gctypebits = GCTYPEBITS;
505 /* Macros turned into functions for ease of debugging.
506 Debuggers don't know about macros! */
507 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
509 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
511 return EQ (obj1, obj2);
515 /************************************************************************/
516 /* Fixed-size type macros */
517 /************************************************************************/
519 /* For fixed-size types that are commonly used, we malloc() large blocks
520 of memory at a time and subdivide them into chunks of the correct
521 size for an object of that type. This is more efficient than
522 malloc()ing each object separately because we save on malloc() time
523 and overhead due to the fewer number of malloc()ed blocks, and
524 also because we don't need any extra pointers within each object
525 to keep them threaded together for GC purposes. For less common
526 (and frequently large-size) types, we use lcrecords, which are
527 malloc()ed individually and chained together through a pointer
528 in the lcrecord header. lcrecords do not need to be fixed-size
529 (i.e. two objects of the same type need not have the same size;
530 however, the size of a particular object cannot vary dynamically).
531 It is also much easier to create a new lcrecord type because no
532 additional code needs to be added to alloc.c. Finally, lcrecords
533 may be more efficient when there are only a small number of them.
535 The types that are stored in these large blocks (or "frob blocks")
536 are cons, float, compiled-function, symbol, marker, extent, event,
539 Note that strings are special in that they are actually stored in
540 two parts: a structure containing information about the string, and
541 the actual data associated with the string. The former structure
542 (a struct Lisp_String) is a fixed-size structure and is managed the
543 same way as all the other such types. This structure contains a
544 pointer to the actual string data, which is stored in structures of
545 type struct string_chars_block. Each string_chars_block consists
546 of a pointer to a struct Lisp_String, followed by the data for that
547 string, followed by another pointer to a Lisp_String, followed by
548 the data for that string, etc. At GC time, the data in these
549 blocks is compacted by searching sequentially through all the
550 blocks and compressing out any holes created by unmarked strings.
551 Strings that are more than a certain size (bigger than the size of
552 a string_chars_block, although something like half as big might
553 make more sense) are malloc()ed separately and not stored in
554 string_chars_blocks. Furthermore, no one string stretches across
555 two string_chars_blocks.
557 Vectors are each malloc()ed separately, similar to lcrecords.
559 In the following discussion, we use conses, but it applies equally
560 well to the other fixed-size types.
562 We store cons cells inside of cons_blocks, allocating a new
563 cons_block with malloc() whenever necessary. Cons cells reclaimed
564 by GC are put on a free list to be reallocated before allocating
565 any new cons cells from the latest cons_block. Each cons_block is
566 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
567 the versions in malloc.c and gmalloc.c) really allocates in units
568 of powers of two and uses 4 bytes for its own overhead.
570 What GC actually does is to search through all the cons_blocks,
571 from the most recently allocated to the oldest, and put all
572 cons cells that are not marked (whether or not they're already
573 free) on a cons_free_list. The cons_free_list is a stack, and
574 so the cons cells in the oldest-allocated cons_block end up
575 at the head of the stack and are the first to be reallocated.
576 If any cons_block is entirely free, it is freed with free()
577 and its cons cells removed from the cons_free_list. Because
578 the cons_free_list ends up basically in memory order, we have
579 a high locality of reference (assuming a reasonable turnover
580 of allocating and freeing) and have a reasonable probability
581 of entirely freeing up cons_blocks that have been more recently
582 allocated. This stage is called the "sweep stage" of GC, and
583 is executed after the "mark stage", which involves starting
584 from all places that are known to point to in-use Lisp objects
585 (e.g. the obarray, where are all symbols are stored; the
586 current catches and condition-cases; the backtrace list of
587 currently executing functions; the gcpro list; etc.) and
588 recursively marking all objects that are accessible.
590 At the beginning of the sweep stage, the conses in the cons
591 blocks are in one of three states: in use and marked, in use
592 but not marked, and not in use (already freed). Any conses
593 that are marked have been marked in the mark stage just
594 executed, because as part of the sweep stage we unmark any
595 marked objects. The way we tell whether or not a cons cell
596 is in use is through the FREE_STRUCT_P macro. This basically
597 looks at the first 4 bytes (or however many bytes a pointer
598 fits in) to see if all the bits in those bytes are 1. The
599 resulting value (0xFFFFFFFF) is not a valid pointer and is
600 not a valid Lisp_Object. All current fixed-size types have
601 a pointer or Lisp_Object as their first element with the
602 exception of strings; they have a size value, which can
603 never be less than zero, and so 0xFFFFFFFF is invalid for
604 strings as well. Now assuming that a cons cell is in use,
605 the way we tell whether or not it is marked is to look at
606 the mark bit of its car (each Lisp_Object has one bit
607 reserved as a mark bit, in case it's needed). Note that
608 different types of objects use different fields to indicate
609 whether the object is marked, but the principle is the same.
611 Conses on the free_cons_list are threaded through a pointer
612 stored in the bytes directly after the bytes that are set
613 to 0xFFFFFFFF (we cannot overwrite these because the cons
614 is still in a cons_block and needs to remain marked as
615 not in use for the next time that GC happens). This
616 implies that all fixed-size types must be at least big
617 enough to store two pointers, which is indeed the case
618 for all current fixed-size types.
620 Some types of objects need additional "finalization" done
621 when an object is converted from in use to not in use;
622 this is the purpose of the ADDITIONAL_FREE_type macro.
623 For example, markers need to be removed from the chain
624 of markers that is kept in each buffer. This is because
625 markers in a buffer automatically disappear if the marker
626 is no longer referenced anywhere (the same does not
627 apply to extents, however).
629 WARNING: Things are in an extremely bizarre state when
630 the ADDITIONAL_FREE_type macros are called, so beware!
632 When ERROR_CHECK_GC is defined, we do things differently
633 so as to maximize our chances of catching places where
634 there is insufficient GCPROing. The thing we want to
635 avoid is having an object that we're using but didn't
636 GCPRO get freed by GC and then reallocated while we're
637 in the process of using it -- this will result in something
638 seemingly unrelated getting trashed, and is extremely
639 difficult to track down. If the object gets freed but
640 not reallocated, we can usually catch this because we
641 set all bytes of a freed object to 0xDEADBEEF. (The
642 first four bytes, however, are 0xFFFFFFFF, and the next
643 four are a pointer used to chain freed objects together;
644 we play some tricks with this pointer to make it more
645 bogus, so crashes are more likely to occur right away.)
647 We want freed objects to stay free as long as possible,
648 so instead of doing what we do above, we maintain the
649 free objects in a first-in first-out queue. We also
650 don't recompute the free list each GC, unlike above;
651 this ensures that the queue ordering is preserved.
652 [This means that we are likely to have worse locality
653 of reference, and that we can never free a frob block
654 once it's allocated. (Even if we know that all cells
655 in it are free, there's no easy way to remove all those
656 cells from the free list because the objects on the
657 free list are unlikely to be in memory order.)]
658 Furthermore, we never take objects off the free list
659 unless there's a large number (usually 1000, but
660 varies depending on type) of them already on the list.
661 This way, we ensure that an object that gets freed will
662 remain free for the next 1000 (or whatever) times that
663 an object of that type is allocated. */
665 #ifndef MALLOC_OVERHEAD
667 #define MALLOC_OVERHEAD 0
668 #elif defined (rcheck)
669 #define MALLOC_OVERHEAD 20
671 #define MALLOC_OVERHEAD 8
673 #endif /* MALLOC_OVERHEAD */
675 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
676 /* If we released our reserve (due to running out of memory),
677 and we have a fair amount free once again,
678 try to set aside another reserve in case we run out once more.
680 This is called when a relocatable block is freed in ralloc.c. */
681 void refill_memory_reserve (void);
683 refill_memory_reserve (void)
685 if (breathing_space == 0)
686 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
690 #ifdef ALLOC_NO_POOLS
691 # define TYPE_ALLOC_SIZE(type, structtype) 1
693 # define TYPE_ALLOC_SIZE(type, structtype) \
694 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
695 / sizeof (structtype))
696 #endif /* ALLOC_NO_POOLS */
698 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
700 struct type##_block \
702 struct type##_block *prev; \
703 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
706 static struct type##_block *current_##type##_block; \
707 static int current_##type##_block_index; \
709 static structtype *type##_free_list; \
710 static structtype *type##_free_list_tail; \
713 init_##type##_alloc (void) \
715 current_##type##_block = 0; \
716 current_##type##_block_index = \
717 countof (current_##type##_block->block); \
718 type##_free_list = 0; \
719 type##_free_list_tail = 0; \
722 static int gc_count_num_##type##_in_use; \
723 static int gc_count_num_##type##_freelist
725 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
726 if (current_##type##_block_index \
727 == countof (current_##type##_block->block)) \
729 struct type##_block *AFTFB_new = (struct type##_block *) \
730 allocate_lisp_storage (sizeof (struct type##_block)); \
731 AFTFB_new->prev = current_##type##_block; \
732 current_##type##_block = AFTFB_new; \
733 current_##type##_block_index = 0; \
736 &(current_##type##_block->block[current_##type##_block_index++]); \
739 /* Allocate an instance of a type that is stored in blocks.
740 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
743 #ifdef ERROR_CHECK_GC
745 /* Note: if you get crashes in this function, suspect incorrect calls
746 to free_cons() and friends. This happened once because the cons
747 cell was not GC-protected and was getting collected before
748 free_cons() was called. */
750 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
753 if (gc_count_num_##type##_freelist > \
754 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
756 result = type##_free_list; \
757 /* Before actually using the chain pointer, we complement all its \
758 bits; see FREE_FIXED_TYPE(). */ \
760 (structtype *) ~(unsigned long) \
761 (* (structtype **) ((char *) result + sizeof (void *))); \
762 gc_count_num_##type##_freelist--; \
765 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
766 MARK_STRUCT_AS_NOT_FREE (result); \
769 #else /* !ERROR_CHECK_GC */
771 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
774 if (type##_free_list) \
776 result = type##_free_list; \
778 * (structtype **) ((char *) result + sizeof (void *)); \
781 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
782 MARK_STRUCT_AS_NOT_FREE (result); \
785 #endif /* !ERROR_CHECK_GC */
787 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
790 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
791 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
794 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
797 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
798 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
801 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
802 to a Lisp object and invalid as an actual Lisp_Object value. We have
803 to make sure that this value cannot be an integer in Lisp_Object form.
804 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
805 On a 32-bit system, the type bits will be non-zero, making the value
806 be a pointer, and the pointer will be misaligned.
808 Even if Emacs is run on some weirdo system that allows and allocates
809 byte-aligned pointers, this pointer is at the very top of the address
810 space and so it's almost inconceivable that it could ever be valid. */
813 # define INVALID_POINTER_VALUE 0xFFFFFFFF
815 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
817 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
819 You have some weird system and need to supply a reasonable value here.
822 /* The construct (* (void **) (ptr)) would cause aliasing problems
823 with modern optimizing compilers like `gcc -O3 -fstrict-aliasing'.
824 But `char *' can legally alias any pointer. Hence this union trick. */
825 typedef union { char c; void *p; } *aliasing_voidpp;
826 #define ALIASING_VOIDPP_DEREFERENCE(ptr) \
827 (((aliasing_voidpp) (ptr))->p)
828 #define FREE_STRUCT_P(ptr) \
829 (ALIASING_VOIDPP_DEREFERENCE (ptr) == (void *) INVALID_POINTER_VALUE)
830 #define MARK_STRUCT_AS_FREE(ptr) \
831 (ALIASING_VOIDPP_DEREFERENCE (ptr) = (void *) INVALID_POINTER_VALUE)
832 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
833 (ALIASING_VOIDPP_DEREFERENCE (ptr) = 0)
835 #ifdef ERROR_CHECK_GC
837 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
838 do { if (type##_free_list_tail) \
840 /* When we store the chain pointer, we complement all \
841 its bits; this should significantly increase its \
842 bogosity in case someone tries to use the value, and \
843 should make us dump faster if someone stores something \
844 over the pointer because when it gets un-complemented in \
845 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
846 extremely bogus. */ \
848 ((char *) type##_free_list_tail + sizeof (void *)) = \
849 (structtype *) ~(unsigned long) ptr; \
852 type##_free_list = ptr; \
853 type##_free_list_tail = ptr; \
856 #else /* !ERROR_CHECK_GC */
858 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
859 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
861 type##_free_list = (ptr); \
864 #endif /* !ERROR_CHECK_GC */
866 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
868 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
869 structtype *FFT_ptr = (ptr); \
870 ADDITIONAL_FREE_##type (FFT_ptr); \
871 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
872 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
873 MARK_STRUCT_AS_FREE (FFT_ptr); \
876 /* Like FREE_FIXED_TYPE() but used when we are explicitly
877 freeing a structure through free_cons(), free_marker(), etc.
878 rather than through the normal process of sweeping.
879 We attempt to undo the changes made to the allocation counters
880 as a result of this structure being allocated. This is not
881 completely necessary but helps keep things saner: e.g. this way,
882 repeatedly allocating and freeing a cons will not result in
883 the consing-since-gc counter advancing, which would cause a GC
884 and somewhat defeat the purpose of explicitly freeing. */
886 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
887 do { FREE_FIXED_TYPE (type, structtype, ptr); \
888 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
889 gc_count_num_##type##_freelist++; \
894 /************************************************************************/
895 /* Cons allocation */
896 /************************************************************************/
898 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
899 /* conses are used and freed so often that we set this really high */
900 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
901 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
904 mark_cons (Lisp_Object obj)
906 if (NILP (XCDR (obj)))
909 mark_object (XCAR (obj));
914 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
917 while (internal_equal (XCAR (ob1), XCAR (ob2), depth))
921 if (! CONSP (ob1) || ! CONSP (ob2))
922 return internal_equal (ob1, ob2, depth);
927 static const struct lrecord_description cons_description[] = {
928 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
929 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
933 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
934 mark_cons, print_cons, 0,
937 * No `hash' method needed.
938 * internal_hash knows how to
945 DEFUN ("cons", Fcons, 2, 2, 0, /*
946 Create a new cons, give it CAR and CDR as components, and return it.
950 /* This cannot GC. */
954 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
955 set_lheader_implementation (&c->lheader, &lrecord_cons);
962 /* This is identical to Fcons() but it used for conses that we're
963 going to free later, and is useful when trying to track down
966 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
971 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
972 set_lheader_implementation (&c->lheader, &lrecord_cons);
979 DEFUN ("list", Flist, 0, MANY, 0, /*
980 Return a newly created list with specified arguments as elements.
981 Any number of arguments, even zero arguments, are allowed.
983 (int nargs, Lisp_Object *args))
985 Lisp_Object val = Qnil;
986 Lisp_Object *argp = args + nargs;
989 val = Fcons (*--argp, val);
994 list1 (Lisp_Object obj0)
996 /* This cannot GC. */
997 return Fcons (obj0, Qnil);
1001 list2 (Lisp_Object obj0, Lisp_Object obj1)
1003 /* This cannot GC. */
1004 return Fcons (obj0, Fcons (obj1, Qnil));
1008 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1010 /* This cannot GC. */
1011 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1015 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1017 /* This cannot GC. */
1018 return Fcons (obj0, Fcons (obj1, obj2));
1022 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1024 return Fcons (Fcons (key, value), alist);
1028 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1030 /* This cannot GC. */
1031 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1035 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1038 /* This cannot GC. */
1039 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1043 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1044 Lisp_Object obj4, Lisp_Object obj5)
1046 /* This cannot GC. */
1047 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1050 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1051 Return a new list of length LENGTH, with each element being INIT.
1055 CHECK_NATNUM (length);
1058 Lisp_Object val = Qnil;
1059 size_t size = XINT (length);
1062 val = Fcons (init, val);
1068 /************************************************************************/
1069 /* Float allocation */
1070 /************************************************************************/
1072 #ifdef LISP_FLOAT_TYPE
1074 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
1075 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1078 make_float (double float_value)
1083 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
1085 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1086 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1089 set_lheader_implementation (&f->lheader, &lrecord_float);
1090 float_data (f) = float_value;
1095 #endif /* LISP_FLOAT_TYPE */
1098 /************************************************************************/
1099 /* Vector allocation */
1100 /************************************************************************/
1103 mark_vector (Lisp_Object obj)
1105 Lisp_Vector *ptr = XVECTOR (obj);
1106 int len = vector_length (ptr);
1109 for (i = 0; i < len - 1; i++)
1110 mark_object (ptr->contents[i]);
1111 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1115 size_vector (const void *lheader)
1117 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, contents,
1118 ((Lisp_Vector *) lheader)->size);
1122 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1124 int len = XVECTOR_LENGTH (obj1);
1125 if (len != XVECTOR_LENGTH (obj2))
1129 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1130 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1132 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1139 vector_hash (Lisp_Object obj, int depth)
1141 return HASH2 (XVECTOR_LENGTH (obj),
1142 internal_array_hash (XVECTOR_DATA (obj),
1143 XVECTOR_LENGTH (obj),
1147 static const struct lrecord_description vector_description[] = {
1148 { XD_LONG, offsetof (Lisp_Vector, size) },
1149 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1153 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1154 mark_vector, print_vector, 0,
1158 size_vector, Lisp_Vector);
1160 /* #### should allocate `small' vectors from a frob-block */
1161 static Lisp_Vector *
1162 make_vector_internal (size_t sizei)
1164 /* no vector_next */
1165 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1166 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1173 make_vector (size_t length, Lisp_Object init)
1175 Lisp_Vector *vecp = make_vector_internal (length);
1176 Lisp_Object *p = vector_data (vecp);
1183 XSETVECTOR (vector, vecp);
1190 make_older_vector (size_t length, Lisp_Object init)
1192 struct lcrecord_header* orig_all_lcrecords = all_lcrecords;
1195 all_lcrecords = all_older_lcrecords;
1196 obj = make_vector (length, init);
1197 all_older_lcrecords = all_lcrecords;
1198 all_lcrecords = orig_all_lcrecords;
1202 void make_vector_newer_1 (Lisp_Object v);
1204 make_vector_newer_1 (Lisp_Object v)
1206 struct lcrecord_header* lcrecords = all_older_lcrecords;
1208 if (lcrecords != NULL)
1210 if (lcrecords == XPNTR (v))
1212 lcrecords->lheader.older = 0;
1213 all_older_lcrecords = all_older_lcrecords->next;
1214 lcrecords->next = all_lcrecords;
1215 all_lcrecords = lcrecords;
1220 struct lcrecord_header* plcrecords = lcrecords;
1222 lcrecords = lcrecords->next;
1223 while (lcrecords != NULL)
1225 if (lcrecords == XPNTR (v))
1227 lcrecords->lheader.older = 0;
1228 plcrecords->next = lcrecords->next;
1229 lcrecords->next = all_lcrecords;
1230 all_lcrecords = lcrecords;
1233 plcrecords = lcrecords;
1234 lcrecords = lcrecords->next;
1241 make_vector_newer (Lisp_Object v)
1245 for (i = 0; i < XVECTOR_LENGTH (v); i++)
1247 Lisp_Object obj = XVECTOR_DATA (v)[i];
1249 if (VECTORP (obj) && !EQ (obj, v))
1250 make_vector_newer (obj);
1252 make_vector_newer_1 (v);
1256 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1257 Return a new vector of length LENGTH, with each element being INIT.
1258 See also the function `vector'.
1262 CONCHECK_NATNUM (length);
1263 return make_vector (XINT (length), init);
1266 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1267 Return a newly created vector with specified arguments as elements.
1268 Any number of arguments, even zero arguments, are allowed.
1270 (int nargs, Lisp_Object *args))
1272 Lisp_Vector *vecp = make_vector_internal (nargs);
1273 Lisp_Object *p = vector_data (vecp);
1280 XSETVECTOR (vector, vecp);
1286 vector1 (Lisp_Object obj0)
1288 return Fvector (1, &obj0);
1292 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1294 Lisp_Object args[2];
1297 return Fvector (2, args);
1301 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1303 Lisp_Object args[3];
1307 return Fvector (3, args);
1310 #if 0 /* currently unused */
1313 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1316 Lisp_Object args[4];
1321 return Fvector (4, args);
1325 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1326 Lisp_Object obj3, Lisp_Object obj4)
1328 Lisp_Object args[5];
1334 return Fvector (5, args);
1338 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1339 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1341 Lisp_Object args[6];
1348 return Fvector (6, args);
1352 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1353 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1356 Lisp_Object args[7];
1364 return Fvector (7, args);
1368 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1369 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1370 Lisp_Object obj6, Lisp_Object obj7)
1372 Lisp_Object args[8];
1381 return Fvector (8, args);
1385 /************************************************************************/
1386 /* Bit Vector allocation */
1387 /************************************************************************/
1389 static Lisp_Object all_bit_vectors;
1391 /* #### should allocate `small' bit vectors from a frob-block */
1392 static Lisp_Bit_Vector *
1393 make_bit_vector_internal (size_t sizei)
1395 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1396 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1397 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1398 set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
1400 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1402 bit_vector_length (p) = sizei;
1403 bit_vector_next (p) = all_bit_vectors;
1404 /* make sure the extra bits in the last long are 0; the calling
1405 functions might not set them. */
1406 p->bits[num_longs - 1] = 0;
1407 XSETBIT_VECTOR (all_bit_vectors, p);
1412 make_bit_vector (size_t length, Lisp_Object init)
1414 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1415 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1420 memset (p->bits, 0, num_longs * sizeof (long));
1423 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1424 memset (p->bits, ~0, num_longs * sizeof (long));
1425 /* But we have to make sure that the unused bits in the
1426 last long are 0, so that equal/hash is easy. */
1428 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1432 Lisp_Object bit_vector;
1433 XSETBIT_VECTOR (bit_vector, p);
1439 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1442 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1444 for (i = 0; i < length; i++)
1445 set_bit_vector_bit (p, i, bytevec[i]);
1448 Lisp_Object bit_vector;
1449 XSETBIT_VECTOR (bit_vector, p);
1454 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1455 Return a new bit vector of length LENGTH. with each bit being INIT.
1456 Each element is set to INIT. See also the function `bit-vector'.
1460 CONCHECK_NATNUM (length);
1462 return make_bit_vector (XINT (length), init);
1465 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1466 Return a newly created bit vector with specified arguments as elements.
1467 Any number of arguments, even zero arguments, are allowed.
1469 (int nargs, Lisp_Object *args))
1472 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1474 for (i = 0; i < nargs; i++)
1476 CHECK_BIT (args[i]);
1477 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1481 Lisp_Object bit_vector;
1482 XSETBIT_VECTOR (bit_vector, p);
1488 /************************************************************************/
1489 /* Compiled-function allocation */
1490 /************************************************************************/
1492 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1493 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1496 make_compiled_function (void)
1498 Lisp_Compiled_Function *f;
1501 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1502 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
1505 f->specpdl_depth = 0;
1506 f->flags.documentationp = 0;
1507 f->flags.interactivep = 0;
1508 f->flags.domainp = 0; /* I18N3 */
1509 f->instructions = Qzero;
1510 f->constants = Qzero;
1512 f->doc_and_interactive = Qnil;
1513 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1514 f->annotated = Qnil;
1516 XSETCOMPILED_FUNCTION (fun, f);
1520 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1521 Return a new compiled-function object.
1522 Usage: (arglist instructions constants stack-depth
1523 &optional doc-string interactive)
1524 Note that, unlike all other emacs-lisp functions, calling this with five
1525 arguments is NOT the same as calling it with six arguments, the last of
1526 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1527 that this function was defined with `(interactive)'. If the arg is not
1528 specified, then that means the function is not interactive.
1529 This is terrible behavior which is retained for compatibility with old
1530 `.elc' files which expect these semantics.
1532 (int nargs, Lisp_Object *args))
1534 /* In a non-insane world this function would have this arglist...
1535 (arglist instructions constants stack_depth &optional doc_string interactive)
1537 Lisp_Object fun = make_compiled_function ();
1538 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1540 Lisp_Object arglist = args[0];
1541 Lisp_Object instructions = args[1];
1542 Lisp_Object constants = args[2];
1543 Lisp_Object stack_depth = args[3];
1544 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1545 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1547 if (nargs < 4 || nargs > 6)
1548 return Fsignal (Qwrong_number_of_arguments,
1549 list2 (intern ("make-byte-code"), make_int (nargs)));
1551 /* Check for valid formal parameter list now, to allow us to use
1552 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1554 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1556 CHECK_SYMBOL (symbol);
1557 if (EQ (symbol, Qt) ||
1558 EQ (symbol, Qnil) ||
1559 SYMBOL_IS_KEYWORD (symbol))
1560 signal_simple_error_2
1561 ("Invalid constant symbol in formal parameter list",
1565 f->arglist = arglist;
1567 /* `instructions' is a string or a cons (string . int) for a
1568 lazy-loaded function. */
1569 if (CONSP (instructions))
1571 CHECK_STRING (XCAR (instructions));
1572 CHECK_INT (XCDR (instructions));
1576 CHECK_STRING (instructions);
1578 f->instructions = instructions;
1580 if (!NILP (constants))
1581 CHECK_VECTOR (constants);
1582 f->constants = constants;
1584 CHECK_NATNUM (stack_depth);
1585 f->stack_depth = (unsigned short) XINT (stack_depth);
1587 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1588 if (!NILP (Vcurrent_compiled_function_annotation))
1589 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1590 else if (!NILP (Vload_file_name_internal_the_purecopy))
1591 f->annotated = Vload_file_name_internal_the_purecopy;
1592 else if (!NILP (Vload_file_name_internal))
1594 struct gcpro gcpro1;
1595 GCPRO1 (fun); /* don't let fun get reaped */
1596 Vload_file_name_internal_the_purecopy =
1597 Ffile_name_nondirectory (Vload_file_name_internal);
1598 f->annotated = Vload_file_name_internal_the_purecopy;
1601 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1603 /* doc_string may be nil, string, int, or a cons (string . int).
1604 interactive may be list or string (or unbound). */
1605 f->doc_and_interactive = Qunbound;
1607 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1608 f->doc_and_interactive = Vfile_domain;
1610 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1612 f->doc_and_interactive
1613 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1614 Fcons (interactive, f->doc_and_interactive));
1616 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1618 f->doc_and_interactive
1619 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1620 Fcons (doc_string, f->doc_and_interactive));
1622 if (UNBOUNDP (f->doc_and_interactive))
1623 f->doc_and_interactive = Qnil;
1629 /************************************************************************/
1630 /* Symbol allocation */
1631 /************************************************************************/
1633 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1634 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1636 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1637 Return a newly allocated uninterned symbol whose name is NAME.
1638 Its value and function definition are void, and its property list is nil.
1645 CHECK_STRING (name);
1647 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1648 set_lheader_implementation (&p->lheader, &lrecord_symbol);
1649 p->name = XSTRING (name);
1651 p->value = Qunbound;
1652 p->function = Qunbound;
1653 symbol_next (p) = 0;
1654 XSETSYMBOL (val, p);
1659 /************************************************************************/
1660 /* Extent allocation */
1661 /************************************************************************/
1663 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1664 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1667 allocate_extent (void)
1671 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1672 set_lheader_implementation (&e->lheader, &lrecord_extent);
1673 extent_object (e) = Qnil;
1674 set_extent_start (e, -1);
1675 set_extent_end (e, -1);
1680 extent_face (e) = Qnil;
1681 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1682 e->flags.detachable = 1;
1688 /************************************************************************/
1689 /* Event allocation */
1690 /************************************************************************/
1692 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1693 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1696 allocate_event (void)
1701 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1702 set_lheader_implementation (&e->lheader, &lrecord_event);
1709 /************************************************************************/
1710 /* Marker allocation */
1711 /************************************************************************/
1713 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1714 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1716 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1717 Return a new marker which does not point at any place.
1724 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1725 set_lheader_implementation (&p->lheader, &lrecord_marker);
1728 marker_next (p) = 0;
1729 marker_prev (p) = 0;
1730 p->insertion_type = 0;
1731 XSETMARKER (val, p);
1736 noseeum_make_marker (void)
1741 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1742 set_lheader_implementation (&p->lheader, &lrecord_marker);
1745 marker_next (p) = 0;
1746 marker_prev (p) = 0;
1747 p->insertion_type = 0;
1748 XSETMARKER (val, p);
1753 /************************************************************************/
1754 /* String allocation */
1755 /************************************************************************/
1757 /* The data for "short" strings generally resides inside of structs of type
1758 string_chars_block. The Lisp_String structure is allocated just like any
1759 other Lisp object (except for vectors), and these are freelisted when
1760 they get garbage collected. The data for short strings get compacted,
1761 but the data for large strings do not.
1763 Previously Lisp_String structures were relocated, but this caused a lot
1764 of bus-errors because the C code didn't include enough GCPRO's for
1765 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1766 that the reference would get relocated).
1768 This new method makes things somewhat bigger, but it is MUCH safer. */
1770 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1771 /* strings are used and freed quite often */
1772 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1773 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1776 mark_string (Lisp_Object obj)
1778 Lisp_String *ptr = XSTRING (obj);
1780 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1781 flush_cached_extent_info (XCAR (ptr->plist));
1786 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1789 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1790 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1793 static const struct lrecord_description string_description[] = {
1794 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1795 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1796 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1800 /* We store the string's extent info as the first element of the string's
1801 property list; and the string's MODIFF as the first or second element
1802 of the string's property list (depending on whether the extent info
1803 is present), but only if the string has been modified. This is ugly
1804 but it reduces the memory allocated for the string in the vast
1805 majority of cases, where the string is never modified and has no
1808 #### This means you can't use an int as a key in a string's plist. */
1810 static Lisp_Object *
1811 string_plist_ptr (Lisp_Object string)
1813 Lisp_Object *ptr = &XSTRING (string)->plist;
1815 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
1817 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
1823 string_getprop (Lisp_Object string, Lisp_Object property)
1825 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
1829 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
1831 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
1836 string_remprop (Lisp_Object string, Lisp_Object property)
1838 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
1842 string_plist (Lisp_Object string)
1844 return *string_plist_ptr (string);
1847 /* No `finalize', or `hash' methods.
1848 internal_hash() already knows how to hash strings and finalization
1849 is done with the ADDITIONAL_FREE_string macro, which is the
1850 standard way to do finalization when using
1851 SWEEP_FIXED_TYPE_BLOCK(). */
1852 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
1853 mark_string, print_string,
1862 /* String blocks contain this many useful bytes. */
1863 #define STRING_CHARS_BLOCK_SIZE \
1864 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1865 ((2 * sizeof (struct string_chars_block *)) \
1866 + sizeof (EMACS_INT))))
1867 /* Block header for small strings. */
1868 struct string_chars_block
1871 struct string_chars_block *next;
1872 struct string_chars_block *prev;
1873 /* Contents of string_chars_block->string_chars are interleaved
1874 string_chars structures (see below) and the actual string data */
1875 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1878 static struct string_chars_block *first_string_chars_block;
1879 static struct string_chars_block *current_string_chars_block;
1881 /* If SIZE is the length of a string, this returns how many bytes
1882 * the string occupies in string_chars_block->string_chars
1883 * (including alignment padding).
1885 #define STRING_FULLSIZE(size) \
1886 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1887 ALIGNOF (Lisp_String *))
1889 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1890 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1894 Lisp_String *string;
1895 unsigned char chars[1];
1898 struct unused_string_chars
1900 Lisp_String *string;
1905 init_string_chars_alloc (void)
1907 first_string_chars_block = xnew (struct string_chars_block);
1908 first_string_chars_block->prev = 0;
1909 first_string_chars_block->next = 0;
1910 first_string_chars_block->pos = 0;
1911 current_string_chars_block = first_string_chars_block;
1914 static struct string_chars *
1915 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1918 struct string_chars *s_chars;
1921 (countof (current_string_chars_block->string_chars)
1922 - current_string_chars_block->pos))
1924 /* This string can fit in the current string chars block */
1925 s_chars = (struct string_chars *)
1926 (current_string_chars_block->string_chars
1927 + current_string_chars_block->pos);
1928 current_string_chars_block->pos += fullsize;
1932 /* Make a new current string chars block */
1933 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1935 current_string_chars_block->next = new_scb;
1936 new_scb->prev = current_string_chars_block;
1938 current_string_chars_block = new_scb;
1939 new_scb->pos = fullsize;
1940 s_chars = (struct string_chars *)
1941 current_string_chars_block->string_chars;
1944 s_chars->string = string_it_goes_with;
1946 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1952 make_uninit_string (Bytecount length)
1955 EMACS_INT fullsize = STRING_FULLSIZE (length);
1958 assert (length >= 0 && fullsize > 0);
1960 /* Allocate the string header */
1961 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1962 set_lheader_implementation (&s->lheader, &lrecord_string);
1964 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1965 ? xnew_array (Bufbyte, length + 1)
1966 : allocate_string_chars_struct (s, fullsize)->chars);
1968 set_string_length (s, length);
1971 set_string_byte (s, length, 0);
1973 XSETSTRING (val, s);
1977 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1978 static void verify_string_chars_integrity (void);
1981 /* Resize the string S so that DELTA bytes can be inserted starting
1982 at POS. If DELTA < 0, it means deletion starting at POS. If
1983 POS < 0, resize the string but don't copy any characters. Use
1984 this if you're planning on completely overwriting the string.
1988 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
1990 Bytecount oldfullsize, newfullsize;
1991 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1992 verify_string_chars_integrity ();
1995 #ifdef ERROR_CHECK_BUFPOS
1998 assert (pos <= string_length (s));
2000 assert (pos + (-delta) <= string_length (s));
2005 assert ((-delta) <= string_length (s));
2007 #endif /* ERROR_CHECK_BUFPOS */
2010 /* simplest case: no size change. */
2013 if (pos >= 0 && delta < 0)
2014 /* If DELTA < 0, the functions below will delete the characters
2015 before POS. We want to delete characters *after* POS, however,
2016 so convert this to the appropriate form. */
2019 oldfullsize = STRING_FULLSIZE (string_length (s));
2020 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
2022 if (BIG_STRING_FULLSIZE_P (oldfullsize))
2024 if (BIG_STRING_FULLSIZE_P (newfullsize))
2026 /* Both strings are big. We can just realloc().
2027 But careful! If the string is shrinking, we have to
2028 memmove() _before_ realloc(), and if growing, we have to
2029 memmove() _after_ realloc() - otherwise the access is
2030 illegal, and we might crash. */
2031 Bytecount len = string_length (s) + 1 - pos;
2033 if (delta < 0 && pos >= 0)
2034 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
2035 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
2036 string_length (s) + delta + 1));
2037 if (delta > 0 && pos >= 0)
2038 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
2040 else /* String has been demoted from BIG_STRING. */
2043 allocate_string_chars_struct (s, newfullsize)->chars;
2044 Bufbyte *old_data = string_data (s);
2048 memcpy (new_data, old_data, pos);
2049 memcpy (new_data + pos + delta, old_data + pos,
2050 string_length (s) + 1 - pos);
2052 set_string_data (s, new_data);
2056 else /* old string is small */
2058 if (oldfullsize == newfullsize)
2060 /* special case; size change but the necessary
2061 allocation size won't change (up or down; code
2062 somewhere depends on there not being any unused
2063 allocation space, modulo any alignment
2067 Bufbyte *addroff = pos + string_data (s);
2069 memmove (addroff + delta, addroff,
2070 /* +1 due to zero-termination. */
2071 string_length (s) + 1 - pos);
2076 Bufbyte *old_data = string_data (s);
2078 BIG_STRING_FULLSIZE_P (newfullsize)
2079 ? xnew_array (Bufbyte, string_length (s) + delta + 1)
2080 : allocate_string_chars_struct (s, newfullsize)->chars;
2084 memcpy (new_data, old_data, pos);
2085 memcpy (new_data + pos + delta, old_data + pos,
2086 string_length (s) + 1 - pos);
2088 set_string_data (s, new_data);
2091 /* We need to mark this chunk of the string_chars_block
2092 as unused so that compact_string_chars() doesn't
2094 struct string_chars *old_s_chars = (struct string_chars *)
2095 ((char *) old_data - offsetof (struct string_chars, chars));
2096 /* Sanity check to make sure we aren't hosed by strange
2097 alignment/padding. */
2098 assert (old_s_chars->string == s);
2099 MARK_STRUCT_AS_FREE (old_s_chars);
2100 ((struct unused_string_chars *) old_s_chars)->fullsize =
2106 set_string_length (s, string_length (s) + delta);
2107 /* If pos < 0, the string won't be zero-terminated.
2108 Terminate now just to make sure. */
2109 string_data (s)[string_length (s)] = '\0';
2115 XSETSTRING (string, s);
2116 /* We also have to adjust all of the extent indices after the
2117 place we did the change. We say "pos - 1" because
2118 adjust_extents() is exclusive of the starting position
2120 adjust_extents (string, pos - 1, string_length (s),
2124 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2125 verify_string_chars_integrity ();
2132 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2134 Bufbyte newstr[MAX_EMCHAR_LEN];
2135 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2136 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2137 Bytecount newlen = set_charptr_emchar (newstr, c);
2139 if (oldlen != newlen)
2140 resize_string (s, bytoff, newlen - oldlen);
2141 /* Remember, string_data (s) might have changed so we can't cache it. */
2142 memcpy (string_data (s) + bytoff, newstr, newlen);
2147 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2148 Return a new string of length LENGTH, with each character being INIT.
2149 LENGTH must be an integer and INIT must be a character.
2153 CHECK_NATNUM (length);
2154 CHECK_CHAR_COERCE_INT (init);
2156 Bufbyte init_str[MAX_EMCHAR_LEN];
2157 int len = set_charptr_emchar (init_str, XCHAR (init));
2158 Lisp_Object val = make_uninit_string (len * XINT (length));
2161 /* Optimize the single-byte case */
2162 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2166 Bufbyte *ptr = XSTRING_DATA (val);
2168 for (i = XINT (length); i; i--)
2170 Bufbyte *init_ptr = init_str;
2174 case 6: *ptr++ = *init_ptr++;
2175 case 5: *ptr++ = *init_ptr++;
2177 case 4: *ptr++ = *init_ptr++;
2178 case 3: *ptr++ = *init_ptr++;
2179 case 2: *ptr++ = *init_ptr++;
2180 case 1: *ptr++ = *init_ptr++;
2188 DEFUN ("string", Fstring, 0, MANY, 0, /*
2189 Concatenate all the argument characters and make the result a string.
2191 (int nargs, Lisp_Object *args))
2193 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2194 Bufbyte *p = storage;
2196 for (; nargs; nargs--, args++)
2198 Lisp_Object lisp_char = *args;
2199 CHECK_CHAR_COERCE_INT (lisp_char);
2200 p += set_charptr_emchar (p, XCHAR (lisp_char));
2202 return make_string (storage, p - storage);
2206 /* Take some raw memory, which MUST already be in internal format,
2207 and package it up into a Lisp string. */
2209 make_string (const Bufbyte *contents, Bytecount length)
2213 /* Make sure we find out about bad make_string's when they happen */
2214 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2215 bytecount_to_charcount (contents, length); /* Just for the assertions */
2218 val = make_uninit_string (length);
2219 memcpy (XSTRING_DATA (val), contents, length);
2223 /* Take some raw memory, encoded in some external data format,
2224 and convert it into a Lisp string. */
2226 make_ext_string (const Extbyte *contents, EMACS_INT length,
2227 Lisp_Object coding_system)
2230 TO_INTERNAL_FORMAT (DATA, (contents, length),
2231 LISP_STRING, string,
2237 build_string (const char *str)
2239 /* Some strlen's crash and burn if passed null. */
2240 return make_string ((const Bufbyte *) str, (str ? strlen(str) : 0));
2244 build_ext_string (const char *str, Lisp_Object coding_system)
2246 /* Some strlen's crash and burn if passed null. */
2247 return make_ext_string ((const Extbyte *) str, (str ? strlen(str) : 0),
2252 build_translated_string (const char *str)
2254 return build_string (GETTEXT (str));
2258 make_string_nocopy (const Bufbyte *contents, Bytecount length)
2263 /* Make sure we find out about bad make_string_nocopy's when they happen */
2264 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2265 bytecount_to_charcount (contents, length); /* Just for the assertions */
2268 /* Allocate the string header */
2269 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2270 set_lheader_implementation (&s->lheader, &lrecord_string);
2271 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2273 set_string_data (s, (Bufbyte *)contents);
2274 set_string_length (s, length);
2276 XSETSTRING (val, s);
2281 /************************************************************************/
2282 /* lcrecord lists */
2283 /************************************************************************/
2285 /* Lcrecord lists are used to manage the allocation of particular
2286 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2287 malloc() and garbage-collection junk) as much as possible.
2288 It is similar to the Blocktype class.
2292 1) Create an lcrecord-list object using make_lcrecord_list().
2293 This is often done at initialization. Remember to staticpro_nodump
2294 this object! The arguments to make_lcrecord_list() are the
2295 same as would be passed to alloc_lcrecord().
2296 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2297 and pass the lcrecord-list earlier created.
2298 3) When done with the lcrecord, call free_managed_lcrecord().
2299 The standard freeing caveats apply: ** make sure there are no
2300 pointers to the object anywhere! **
2301 4) Calling free_managed_lcrecord() is just like kissing the
2302 lcrecord goodbye as if it were garbage-collected. This means:
2303 -- the contents of the freed lcrecord are undefined, and the
2304 contents of something produced by allocate_managed_lcrecord()
2305 are undefined, just like for alloc_lcrecord().
2306 -- the mark method for the lcrecord's type will *NEVER* be called
2308 -- the finalize method for the lcrecord's type will be called
2309 at the time that free_managed_lcrecord() is called.
2314 mark_lcrecord_list (Lisp_Object obj)
2316 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2317 Lisp_Object chain = list->free;
2319 while (!NILP (chain))
2321 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2322 struct free_lcrecord_header *free_header =
2323 (struct free_lcrecord_header *) lheader;
2326 (/* There should be no other pointers to the free list. */
2327 ! MARKED_RECORD_HEADER_P (lheader)
2329 /* Only lcrecords should be here. */
2330 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
2332 /* Only free lcrecords should be here. */
2333 free_header->lcheader.free
2335 /* The type of the lcrecord must be right. */
2336 LHEADER_IMPLEMENTATION (lheader) == list->implementation
2338 /* So must the size. */
2339 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2340 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
2343 MARK_RECORD_HEADER (lheader);
2344 chain = free_header->chain;
2350 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2351 mark_lcrecord_list, internal_object_printer,
2352 0, 0, 0, 0, struct lcrecord_list);
2354 make_lcrecord_list (size_t size,
2355 const struct lrecord_implementation *implementation)
2357 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2358 &lrecord_lcrecord_list);
2361 p->implementation = implementation;
2364 XSETLCRECORD_LIST (val, p);
2369 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2371 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2372 if (!NILP (list->free))
2374 Lisp_Object val = list->free;
2375 struct free_lcrecord_header *free_header =
2376 (struct free_lcrecord_header *) XPNTR (val);
2378 #ifdef ERROR_CHECK_GC
2379 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2381 /* There should be no other pointers to the free list. */
2382 assert (! MARKED_RECORD_HEADER_P (lheader));
2383 /* Only lcrecords should be here. */
2384 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
2385 /* Only free lcrecords should be here. */
2386 assert (free_header->lcheader.free);
2387 /* The type of the lcrecord must be right. */
2388 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
2389 /* So must the size. */
2390 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2391 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
2392 #endif /* ERROR_CHECK_GC */
2394 list->free = free_header->chain;
2395 free_header->lcheader.free = 0;
2402 XSETOBJ (val, alloc_lcrecord (list->size, list->implementation));
2408 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2410 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2411 struct free_lcrecord_header *free_header =
2412 (struct free_lcrecord_header *) XPNTR (lcrecord);
2413 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2414 const struct lrecord_implementation *implementation
2415 = LHEADER_IMPLEMENTATION (lheader);
2417 /* Make sure the size is correct. This will catch, for example,
2418 putting a window configuration on the wrong free list. */
2419 gc_checking_assert ((implementation->size_in_bytes_method ?
2420 implementation->size_in_bytes_method (lheader) :
2421 implementation->static_size)
2424 if (implementation->finalizer)
2425 implementation->finalizer (lheader, 0);
2426 free_header->chain = list->free;
2427 free_header->lcheader.free = 1;
2428 list->free = lcrecord;
2434 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2435 Kept for compatibility, returns its argument.
2437 Make a copy of OBJECT in pure storage.
2438 Recursively copies contents of vectors and cons cells.
2439 Does not copy symbols.
2447 /************************************************************************/
2448 /* Garbage Collection */
2449 /************************************************************************/
2451 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
2452 Additional ones may be defined by a module (none yet). We leave some
2453 room in `lrecord_implementations_table' for such new lisp object types. */
2454 const struct lrecord_implementation *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT];
2455 unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
2456 /* Object marker functions are in the lrecord_implementation structure.
2457 But copying them to a parallel array is much more cache-friendly.
2458 This hack speeds up (garbage-collect) by about 5%. */
2459 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
2461 struct gcpro *gcprolist;
2463 /* 415 used Mly 29-Jun-93 */
2464 /* 1327 used slb 28-Feb-98 */
2465 /* 1328 used og 03-Oct-99 (moving slowly, heh?) */
2467 #define NSTATICS 4000
2469 #define NSTATICS 2000
2472 /* Not "static" because used by dumper.c */
2473 Lisp_Object *staticvec[NSTATICS];
2476 /* Put an entry in staticvec, pointing at the variable whose address is given
2479 staticpro (Lisp_Object *varaddress)
2481 /* #### This is now a dubious assert() since this routine may be called */
2482 /* by Lisp attempting to load a DLL. */
2483 assert (staticidx < countof (staticvec));
2484 staticvec[staticidx++] = varaddress;
2488 Lisp_Object *staticvec_nodump[200];
2489 int staticidx_nodump;
2491 /* Put an entry in staticvec_nodump, pointing at the variable whose address is given
2494 staticpro_nodump (Lisp_Object *varaddress)
2496 /* #### This is now a dubious assert() since this routine may be called */
2497 /* by Lisp attempting to load a DLL. */
2498 assert (staticidx_nodump < countof (staticvec_nodump));
2499 staticvec_nodump[staticidx_nodump++] = varaddress;
2503 struct pdump_dumpstructinfo dumpstructvec[200];
2506 /* Put an entry in dumpstructvec, pointing at the variable whose address is given
2509 dumpstruct (void *varaddress, const struct struct_description *desc)
2511 assert (dumpstructidx < countof (dumpstructvec));
2512 dumpstructvec[dumpstructidx].data = varaddress;
2513 dumpstructvec[dumpstructidx].desc = desc;
2517 struct pdump_dumpopaqueinfo dumpopaquevec[250];
2520 /* Put an entry in dumpopaquevec, pointing at the variable whose address is given
2523 dumpopaque (void *varaddress, size_t size)
2525 assert (dumpopaqueidx < countof (dumpopaquevec));
2527 dumpopaquevec[dumpopaqueidx].data = varaddress;
2528 dumpopaquevec[dumpopaqueidx].size = size;
2532 Lisp_Object *pdump_wirevec[50];
2535 /* Put an entry in pdump_wirevec, pointing at the variable whose address is given
2538 pdump_wire (Lisp_Object *varaddress)
2540 assert (pdump_wireidx < countof (pdump_wirevec));
2541 pdump_wirevec[pdump_wireidx++] = varaddress;
2545 Lisp_Object *pdump_wirevec_list[50];
2546 int pdump_wireidx_list;
2548 /* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given
2551 pdump_wire_list (Lisp_Object *varaddress)
2553 assert (pdump_wireidx_list < countof (pdump_wirevec_list));
2554 pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
2557 #ifdef ERROR_CHECK_GC
2558 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
2559 struct lrecord_header * GCLI_lh = (lheader); \
2560 assert (GCLI_lh != 0); \
2561 assert (GCLI_lh->type < lrecord_type_count); \
2562 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
2563 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
2564 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
2567 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
2571 /* Mark reference to a Lisp_Object. If the object referred to has not been
2572 seen yet, recursively mark all the references contained in it. */
2575 mark_object (Lisp_Object obj)
2579 /* Checks we used to perform */
2580 /* if (EQ (obj, Qnull_pointer)) return; */
2581 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2582 /* if (PURIFIED (XPNTR (obj))) return; */
2584 if (XTYPE (obj) == Lisp_Type_Record)
2586 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2588 GC_CHECK_LHEADER_INVARIANTS (lheader);
2590 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
2591 ! ((struct lcrecord_header *) lheader)->free);
2593 /* All c_readonly objects have their mark bit set,
2594 so that we only need to check the mark bit here. */
2595 if ( (!MARKED_RECORD_HEADER_P (lheader))
2597 && (!OLDER_RECORD_HEADER_P (lheader))
2601 MARK_RECORD_HEADER (lheader);
2603 if (RECORD_MARKER (lheader))
2605 obj = RECORD_MARKER (lheader) (obj);
2606 if (!NILP (obj)) goto tail_recurse;
2612 /* mark all of the conses in a list and mark the final cdr; but
2613 DO NOT mark the cars.
2615 Use only for internal lists! There should never be other pointers
2616 to the cons cells, because if so, the cars will remain unmarked
2617 even when they maybe should be marked. */
2619 mark_conses_in_list (Lisp_Object obj)
2623 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2625 if (CONS_MARKED_P (XCONS (rest)))
2627 MARK_CONS (XCONS (rest));
2634 /* Find all structures not marked, and free them. */
2636 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2637 static int gc_count_bit_vector_storage;
2638 static int gc_count_num_short_string_in_use;
2639 static int gc_count_string_total_size;
2640 static int gc_count_short_string_total_size;
2642 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2645 /* stats on lcrecords in use - kinda kludgy */
2649 int instances_in_use;
2651 int instances_freed;
2653 int instances_on_free_list;
2654 } lcrecord_stats [countof (lrecord_implementations_table)];
2657 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
2659 unsigned int type_index = h->type;
2661 if (((struct lcrecord_header *) h)->free)
2663 gc_checking_assert (!free_p);
2664 lcrecord_stats[type_index].instances_on_free_list++;
2668 const struct lrecord_implementation *implementation =
2669 LHEADER_IMPLEMENTATION (h);
2671 size_t sz = (implementation->size_in_bytes_method ?
2672 implementation->size_in_bytes_method (h) :
2673 implementation->static_size);
2676 lcrecord_stats[type_index].instances_freed++;
2677 lcrecord_stats[type_index].bytes_freed += sz;
2681 lcrecord_stats[type_index].instances_in_use++;
2682 lcrecord_stats[type_index].bytes_in_use += sz;
2688 /* Free all unmarked records */
2690 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2692 struct lcrecord_header *header;
2694 /* int total_size = 0; */
2696 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2698 /* First go through and call all the finalize methods.
2699 Then go through and free the objects. There used to
2700 be only one loop here, with the call to the finalizer
2701 occurring directly before the xfree() below. That
2702 is marginally faster but much less safe -- if the
2703 finalize method for an object needs to reference any
2704 other objects contained within it (and many do),
2705 we could easily be screwed by having already freed that
2708 for (header = *prev; header; header = header->next)
2710 struct lrecord_header *h = &(header->lheader);
2712 GC_CHECK_LHEADER_INVARIANTS (h);
2714 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
2716 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2717 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2721 for (header = *prev; header; )
2723 struct lrecord_header *h = &(header->lheader);
2724 if (MARKED_RECORD_HEADER_P (h))
2726 if (! C_READONLY_RECORD_HEADER_P (h))
2727 UNMARK_RECORD_HEADER (h);
2729 /* total_size += n->implementation->size_in_bytes (h);*/
2730 /* #### May modify header->next on a C_READONLY lcrecord */
2731 prev = &(header->next);
2733 tick_lcrecord_stats (h, 0);
2737 struct lcrecord_header *next = header->next;
2739 tick_lcrecord_stats (h, 1);
2740 /* used to call finalizer right here. */
2746 /* *total = total_size; */
2751 sweep_bit_vectors_1 (Lisp_Object *prev,
2752 int *used, int *total, int *storage)
2754 Lisp_Object bit_vector;
2757 int total_storage = 0;
2759 /* BIT_VECTORP fails because the objects are marked, which changes
2760 their implementation */
2761 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2763 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2765 if (MARKED_RECORD_P (bit_vector))
2767 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
2768 UNMARK_RECORD_HEADER (&(v->lheader));
2772 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2773 BIT_VECTOR_LONG_STORAGE (len));
2775 /* #### May modify next on a C_READONLY bitvector */
2776 prev = &(bit_vector_next (v));
2781 Lisp_Object next = bit_vector_next (v);
2788 *total = total_size;
2789 *storage = total_storage;
2792 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2793 to make macros prettier. */
2795 #ifdef ERROR_CHECK_GC
2797 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2799 struct typename##_block *SFTB_current; \
2800 struct typename##_block **SFTB_prev; \
2802 int num_free = 0, num_used = 0; \
2804 for (SFTB_prev = ¤t_##typename##_block, \
2805 SFTB_current = current_##typename##_block, \
2806 SFTB_limit = current_##typename##_block_index; \
2812 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2814 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2816 if (FREE_STRUCT_P (SFTB_victim)) \
2820 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2824 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2827 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2832 UNMARK_##typename (SFTB_victim); \
2835 SFTB_prev = &(SFTB_current->prev); \
2836 SFTB_current = SFTB_current->prev; \
2837 SFTB_limit = countof (current_##typename##_block->block); \
2840 gc_count_num_##typename##_in_use = num_used; \
2841 gc_count_num_##typename##_freelist = num_free; \
2844 #else /* !ERROR_CHECK_GC */
2846 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2848 struct typename##_block *SFTB_current; \
2849 struct typename##_block **SFTB_prev; \
2851 int num_free = 0, num_used = 0; \
2853 typename##_free_list = 0; \
2855 for (SFTB_prev = ¤t_##typename##_block, \
2856 SFTB_current = current_##typename##_block, \
2857 SFTB_limit = current_##typename##_block_index; \
2862 int SFTB_empty = 1; \
2863 obj_type *SFTB_old_free_list = typename##_free_list; \
2865 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2867 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2869 if (FREE_STRUCT_P (SFTB_victim)) \
2872 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2874 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2879 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2882 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2888 UNMARK_##typename (SFTB_victim); \
2893 SFTB_prev = &(SFTB_current->prev); \
2894 SFTB_current = SFTB_current->prev; \
2896 else if (SFTB_current == current_##typename##_block \
2897 && !SFTB_current->prev) \
2899 /* No real point in freeing sole allocation block */ \
2904 struct typename##_block *SFTB_victim_block = SFTB_current; \
2905 if (SFTB_victim_block == current_##typename##_block) \
2906 current_##typename##_block_index \
2907 = countof (current_##typename##_block->block); \
2908 SFTB_current = SFTB_current->prev; \
2910 *SFTB_prev = SFTB_current; \
2911 xfree (SFTB_victim_block); \
2912 /* Restore free list to what it was before victim was swept */ \
2913 typename##_free_list = SFTB_old_free_list; \
2914 num_free -= SFTB_limit; \
2917 SFTB_limit = countof (current_##typename##_block->block); \
2920 gc_count_num_##typename##_in_use = num_used; \
2921 gc_count_num_##typename##_freelist = num_free; \
2924 #endif /* !ERROR_CHECK_GC */
2932 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2933 #define ADDITIONAL_FREE_cons(ptr)
2935 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2938 /* Explicitly free a cons cell. */
2940 free_cons (Lisp_Cons *ptr)
2942 #ifdef ERROR_CHECK_GC
2943 /* If the CAR is not an int, then it will be a pointer, which will
2944 always be four-byte aligned. If this cons cell has already been
2945 placed on the free list, however, its car will probably contain
2946 a chain pointer to the next cons on the list, which has cleverly
2947 had all its 0's and 1's inverted. This allows for a quick
2948 check to make sure we're not freeing something already freed. */
2949 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2950 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2951 #endif /* ERROR_CHECK_GC */
2953 #ifndef ALLOC_NO_POOLS
2954 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2955 #endif /* ALLOC_NO_POOLS */
2958 /* explicitly free a list. You **must make sure** that you have
2959 created all the cons cells that make up this list and that there
2960 are no pointers to any of these cons cells anywhere else. If there
2961 are, you will lose. */
2964 free_list (Lisp_Object list)
2966 Lisp_Object rest, next;
2968 for (rest = list; !NILP (rest); rest = next)
2971 free_cons (XCONS (rest));
2975 /* explicitly free an alist. You **must make sure** that you have
2976 created all the cons cells that make up this alist and that there
2977 are no pointers to any of these cons cells anywhere else. If there
2978 are, you will lose. */
2981 free_alist (Lisp_Object alist)
2983 Lisp_Object rest, next;
2985 for (rest = alist; !NILP (rest); rest = next)
2988 free_cons (XCONS (XCAR (rest)));
2989 free_cons (XCONS (rest));
2994 sweep_compiled_functions (void)
2996 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2997 #define ADDITIONAL_FREE_compiled_function(ptr)
2999 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
3003 #ifdef LISP_FLOAT_TYPE
3007 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3008 #define ADDITIONAL_FREE_float(ptr)
3010 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
3012 #endif /* LISP_FLOAT_TYPE */
3015 sweep_symbols (void)
3017 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3018 #define ADDITIONAL_FREE_symbol(ptr)
3020 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
3024 sweep_extents (void)
3026 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3027 #define ADDITIONAL_FREE_extent(ptr)
3029 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
3035 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3036 #define ADDITIONAL_FREE_event(ptr)
3038 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
3042 sweep_markers (void)
3044 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3045 #define ADDITIONAL_FREE_marker(ptr) \
3046 do { Lisp_Object tem; \
3047 XSETMARKER (tem, ptr); \
3048 unchain_marker (tem); \
3051 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
3054 /* Explicitly free a marker. */
3056 free_marker (Lisp_Marker *ptr)
3058 /* Perhaps this will catch freeing an already-freed marker. */
3059 gc_checking_assert (ptr->lheader.type = lrecord_type_marker);
3061 #ifndef ALLOC_NO_POOLS
3062 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
3063 #endif /* ALLOC_NO_POOLS */
3067 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
3070 verify_string_chars_integrity (void)
3072 struct string_chars_block *sb;
3074 /* Scan each existing string block sequentially, string by string. */
3075 for (sb = first_string_chars_block; sb; sb = sb->next)
3078 /* POS is the index of the next string in the block. */
3079 while (pos < sb->pos)
3081 struct string_chars *s_chars =
3082 (struct string_chars *) &(sb->string_chars[pos]);
3083 Lisp_String *string;
3087 /* If the string_chars struct is marked as free (i.e. the STRING
3088 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3089 storage. (See below.) */
3091 if (FREE_STRUCT_P (s_chars))
3093 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3098 string = s_chars->string;
3099 /* Must be 32-bit aligned. */
3100 assert ((((int) string) & 3) == 0);
3102 size = string_length (string);
3103 fullsize = STRING_FULLSIZE (size);
3105 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3106 assert (string_data (string) == s_chars->chars);
3109 assert (pos == sb->pos);
3113 #endif /* MULE && ERROR_CHECK_GC */
3115 /* Compactify string chars, relocating the reference to each --
3116 free any empty string_chars_block we see. */
3118 compact_string_chars (void)
3120 struct string_chars_block *to_sb = first_string_chars_block;
3122 struct string_chars_block *from_sb;
3124 /* Scan each existing string block sequentially, string by string. */
3125 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3128 /* FROM_POS is the index of the next string in the block. */
3129 while (from_pos < from_sb->pos)
3131 struct string_chars *from_s_chars =
3132 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3133 struct string_chars *to_s_chars;
3134 Lisp_String *string;
3138 /* If the string_chars struct is marked as free (i.e. the STRING
3139 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3140 storage. This happens under Mule when a string's size changes
3141 in such a way that its fullsize changes. (Strings can change
3142 size because a different-length character can be substituted
3143 for another character.) In this case, after the bogus string
3144 pointer is the "fullsize" of this entry, i.e. how many bytes
3147 if (FREE_STRUCT_P (from_s_chars))
3149 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3150 from_pos += fullsize;
3154 string = from_s_chars->string;
3155 assert (!(FREE_STRUCT_P (string)));
3157 size = string_length (string);
3158 fullsize = STRING_FULLSIZE (size);
3160 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
3162 /* Just skip it if it isn't marked. */
3163 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3165 from_pos += fullsize;
3169 /* If it won't fit in what's left of TO_SB, close TO_SB out
3170 and go on to the next string_chars_block. We know that TO_SB
3171 cannot advance past FROM_SB here since FROM_SB is large enough
3172 to currently contain this string. */
3173 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3175 to_sb->pos = to_pos;
3176 to_sb = to_sb->next;
3180 /* Compute new address of this string
3181 and update TO_POS for the space being used. */
3182 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3184 /* Copy the string_chars to the new place. */
3185 if (from_s_chars != to_s_chars)
3186 memmove (to_s_chars, from_s_chars, fullsize);
3188 /* Relocate FROM_S_CHARS's reference */
3189 set_string_data (string, &(to_s_chars->chars[0]));
3191 from_pos += fullsize;
3196 /* Set current to the last string chars block still used and
3197 free any that follow. */
3199 struct string_chars_block *victim;
3201 for (victim = to_sb->next; victim; )
3203 struct string_chars_block *next = victim->next;
3208 current_string_chars_block = to_sb;
3209 current_string_chars_block->pos = to_pos;
3210 current_string_chars_block->next = 0;
3214 #if 1 /* Hack to debug missing purecopy's */
3215 static int debug_string_purity;
3218 debug_string_purity_print (Lisp_String *p)
3221 Charcount s = string_char_length (p);
3223 for (i = 0; i < s; i++)
3225 Emchar ch = string_char (p, i);
3226 if (ch < 32 || ch >= 126)
3227 stderr_out ("\\%03o", ch);
3228 else if (ch == '\\' || ch == '\"')
3229 stderr_out ("\\%c", ch);
3231 stderr_out ("%c", ch);
3233 stderr_out ("\"\n");
3239 sweep_strings (void)
3241 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3242 int debug = debug_string_purity;
3244 #define UNMARK_string(ptr) do { \
3245 Lisp_String *p = (ptr); \
3246 size_t size = string_length (p); \
3247 UNMARK_RECORD_HEADER (&(p->lheader)); \
3248 num_bytes += size; \
3249 if (!BIG_STRING_SIZE_P (size)) \
3251 num_small_bytes += size; \
3255 debug_string_purity_print (p); \
3257 #define ADDITIONAL_FREE_string(ptr) do { \
3258 size_t size = string_length (ptr); \
3259 if (BIG_STRING_SIZE_P (size)) \
3260 xfree (ptr->data); \
3263 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3265 gc_count_num_short_string_in_use = num_small_used;
3266 gc_count_string_total_size = num_bytes;
3267 gc_count_short_string_total_size = num_small_bytes;
3271 /* I hate duplicating all this crap! */
3273 marked_p (Lisp_Object obj)
3275 /* Checks we used to perform. */
3276 /* if (EQ (obj, Qnull_pointer)) return 1; */
3277 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3278 /* if (PURIFIED (XPNTR (obj))) return 1; */
3280 if (XTYPE (obj) == Lisp_Type_Record)
3282 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3284 GC_CHECK_LHEADER_INVARIANTS (lheader);
3286 return MARKED_RECORD_HEADER_P (lheader);
3294 /* Free all unmarked records. Do this at the very beginning,
3295 before anything else, so that the finalize methods can safely
3296 examine items in the objects. sweep_lcrecords_1() makes
3297 sure to call all the finalize methods *before* freeing anything,
3298 to complete the safety. */
3301 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3304 compact_string_chars ();
3306 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3307 macros) must be *extremely* careful to make sure they're not
3308 referencing freed objects. The only two existing finalize
3309 methods (for strings and markers) pass muster -- the string
3310 finalizer doesn't look at anything but its own specially-
3311 created block, and the marker finalizer only looks at live
3312 buffers (which will never be freed) and at the markers before
3313 and after it in the chain (which, by induction, will never be
3314 freed because if so, they would have already removed themselves
3317 /* Put all unmarked strings on free list, free'ing the string chars
3318 of large unmarked strings */
3321 /* Put all unmarked conses on free list */
3324 /* Free all unmarked bit vectors */
3325 sweep_bit_vectors_1 (&all_bit_vectors,
3326 &gc_count_num_bit_vector_used,
3327 &gc_count_bit_vector_total_size,
3328 &gc_count_bit_vector_storage);
3330 /* Free all unmarked compiled-function objects */
3331 sweep_compiled_functions ();
3333 #ifdef LISP_FLOAT_TYPE
3334 /* Put all unmarked floats on free list */
3338 /* Put all unmarked symbols on free list */
3341 /* Put all unmarked extents on free list */
3344 /* Put all unmarked markers on free list.
3345 Dechain each one first from the buffer into which it points. */
3351 pdump_objects_unmark ();
3355 /* Clearing for disksave. */
3358 disksave_object_finalization (void)
3360 /* It's important that certain information from the environment not get
3361 dumped with the executable (pathnames, environment variables, etc.).
3362 To make it easier to tell when this has happened with strings(1) we
3363 clear some known-to-be-garbage blocks of memory, so that leftover
3364 results of old evaluation don't look like potential problems.
3365 But first we set some notable variables to nil and do one more GC,
3366 to turn those strings into garbage.
3369 /* Yeah, this list is pretty ad-hoc... */
3370 Vprocess_environment = Qnil;
3371 Vexec_directory = Qnil;
3372 Vdata_directory = Qnil;
3373 Vsite_directory = Qnil;
3374 Vdoc_directory = Qnil;
3375 Vconfigure_info_directory = Qnil;
3378 /* Vdump_load_path = Qnil; */
3379 /* Release hash tables for locate_file */
3380 Flocate_file_clear_hashing (Qt);
3381 uncache_home_directory();
3383 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3384 defined(LOADHIST_BUILTIN))
3385 Vload_history = Qnil;
3387 Vshell_file_name = Qnil;
3389 garbage_collect_1 ();
3391 /* Run the disksave finalization methods of all live objects. */
3392 disksave_object_finalization_1 ();
3394 /* Zero out the uninitialized (really, unused) part of the containers
3395 for the live strings. */
3397 struct string_chars_block *scb;
3398 for (scb = first_string_chars_block; scb; scb = scb->next)
3400 int count = sizeof (scb->string_chars) - scb->pos;
3402 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3405 /* from the block's fill ptr to the end */
3406 memset ((scb->string_chars + scb->pos), 0, count);
3411 /* There, that ought to be enough... */
3417 restore_gc_inhibit (Lisp_Object val)
3419 gc_currently_forbidden = XINT (val);
3423 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3424 static int gc_hooks_inhibited;
3428 garbage_collect_1 (void)
3430 #if MAX_SAVE_STACK > 0
3431 char stack_top_variable;
3432 extern char *stack_bottom;
3437 Lisp_Object pre_gc_cursor;
3438 struct gcpro gcpro1;
3441 || gc_currently_forbidden
3443 || preparing_for_armageddon)
3446 /* We used to call selected_frame() here.
3448 The following functions cannot be called inside GC
3449 so we move to after the above tests. */
3452 Lisp_Object device = Fselected_device (Qnil);
3453 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3455 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3457 signal_simple_error ("No frames exist on device", device);
3461 pre_gc_cursor = Qnil;
3464 GCPRO1 (pre_gc_cursor);
3466 /* Very important to prevent GC during any of the following
3467 stuff that might run Lisp code; otherwise, we'll likely
3468 have infinite GC recursion. */
3469 speccount = specpdl_depth ();
3470 record_unwind_protect (restore_gc_inhibit,
3471 make_int (gc_currently_forbidden));
3472 gc_currently_forbidden = 1;
3474 if (!gc_hooks_inhibited)
3475 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3477 /* Now show the GC cursor/message. */
3478 if (!noninteractive)
3480 if (FRAME_WIN_P (f))
3482 Lisp_Object frame = make_frame (f);
3483 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3484 FRAME_SELECTED_WINDOW (f),
3486 pre_gc_cursor = f->pointer;
3487 if (POINTER_IMAGE_INSTANCEP (cursor)
3488 /* don't change if we don't know how to change back. */
3489 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3492 Fset_frame_pointer (frame, cursor);
3496 /* Don't print messages to the stream device. */
3497 if (!cursor_changed && !FRAME_STREAM_P (f))
3499 char *msg = (STRINGP (Vgc_message)
3500 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3502 Lisp_Object args[2], whole_msg;
3503 args[0] = build_string (msg ? msg :
3504 GETTEXT ((const char *) gc_default_message));
3505 args[1] = build_string ("...");
3506 whole_msg = Fconcat (2, args);
3507 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3508 Qgarbage_collecting);
3512 /***** Now we actually start the garbage collection. */
3516 gc_generation_number[0]++;
3518 #if MAX_SAVE_STACK > 0
3520 /* Save a copy of the contents of the stack, for debugging. */
3523 /* Static buffer in which we save a copy of the C stack at each GC. */
3524 static char *stack_copy;
3525 static size_t stack_copy_size;
3527 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3528 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3529 if (stack_size < MAX_SAVE_STACK)
3531 if (stack_copy_size < stack_size)
3533 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3534 stack_copy_size = stack_size;
3538 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3542 #endif /* MAX_SAVE_STACK > 0 */
3544 /* Do some totally ad-hoc resource clearing. */
3545 /* #### generalize this? */
3546 clear_event_resource ();
3547 cleanup_specifiers ();
3549 /* Mark all the special slots that serve as the roots of accessibility. */
3553 for (i = 0; i < staticidx; i++)
3554 mark_object (*(staticvec[i]));
3555 for (i = 0; i < staticidx_nodump; i++)
3556 mark_object (*(staticvec_nodump[i]));
3562 for (tail = gcprolist; tail; tail = tail->next)
3563 for (i = 0; i < tail->nvars; i++)
3564 mark_object (tail->var[i]);
3568 struct specbinding *bind;
3569 for (bind = specpdl; bind != specpdl_ptr; bind++)
3571 mark_object (bind->symbol);
3572 mark_object (bind->old_value);
3577 struct catchtag *catch;
3578 for (catch = catchlist; catch; catch = catch->next)
3580 mark_object (catch->tag);
3581 mark_object (catch->val);
3586 struct backtrace *backlist;
3587 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3589 int nargs = backlist->nargs;
3592 mark_object (*backlist->function);
3593 if (nargs == UNEVALLED || nargs == MANY)
3594 mark_object (backlist->args[0]);
3596 for (i = 0; i < nargs; i++)
3597 mark_object (backlist->args[i]);
3602 mark_profiling_info ();
3604 /* OK, now do the after-mark stuff. This is for things that
3605 are only marked when something else is marked (e.g. weak hash tables).
3606 There may be complex dependencies between such objects -- e.g.
3607 a weak hash table might be unmarked, but after processing a later
3608 weak hash table, the former one might get marked. So we have to
3609 iterate until nothing more gets marked. */
3611 while (finish_marking_weak_hash_tables () > 0 ||
3612 finish_marking_weak_lists () > 0)
3615 /* And prune (this needs to be called after everything else has been
3616 marked and before we do any sweeping). */
3617 /* #### this is somewhat ad-hoc and should probably be an object
3619 prune_weak_hash_tables ();
3620 prune_weak_lists ();
3621 prune_specifiers ();
3622 prune_syntax_tables ();
3626 consing_since_gc = 0;
3627 #ifndef DEBUG_XEMACS
3628 /* Allow you to set it really fucking low if you really want ... */
3629 if (gc_cons_threshold < 10000)
3630 gc_cons_threshold = 10000;
3635 /******* End of garbage collection ********/
3637 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3639 /* Now remove the GC cursor/message */
3640 if (!noninteractive)
3643 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3644 else if (!FRAME_STREAM_P (f))
3646 char *msg = (STRINGP (Vgc_message)
3647 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3650 /* Show "...done" only if the echo area would otherwise be empty. */
3651 if (NILP (clear_echo_area (selected_frame (),
3652 Qgarbage_collecting, 0)))
3654 Lisp_Object args[2], whole_msg;
3655 args[0] = build_string (msg ? msg :
3656 GETTEXT ((const char *)
3657 gc_default_message));
3658 args[1] = build_string ("... done");
3659 whole_msg = Fconcat (2, args);
3660 echo_area_message (selected_frame (), (Bufbyte *) 0,
3662 Qgarbage_collecting);
3667 /* now stop inhibiting GC */
3668 unbind_to (speccount, Qnil);
3670 if (!breathing_space)
3672 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3679 /* Debugging aids. */
3682 gc_plist_hack (const char *name, int value, Lisp_Object tail)
3684 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3685 or portable numeric datatypes, or bit-vectors, or characters, or
3686 arrays, or exceptions, or ...) */
3687 return cons3 (intern (name), make_int (value), tail);
3690 #define HACK_O_MATIC(type, name, pl) do { \
3692 struct type##_block *x = current_##type##_block; \
3693 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3694 (pl) = gc_plist_hack ((name), s, (pl)); \
3697 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3698 Reclaim storage for Lisp objects no longer needed.
3699 Return info on amount of space in use:
3700 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3701 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3703 where `PLIST' is a list of alternating keyword/value pairs providing
3704 more detailed information.
3705 Garbage collection happens automatically if you cons more than
3706 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3710 Lisp_Object pl = Qnil;
3712 int gc_count_vector_total_size = 0;
3714 garbage_collect_1 ();
3716 for (i = 0; i < lrecord_type_count; i++)
3718 if (lcrecord_stats[i].bytes_in_use != 0
3719 || lcrecord_stats[i].bytes_freed != 0
3720 || lcrecord_stats[i].instances_on_free_list != 0)
3723 const char *name = lrecord_implementations_table[i]->name;
3724 int len = strlen (name);
3725 /* save this for the FSFmacs-compatible part of the summary */
3726 if (i == lrecord_vector.lrecord_type_index)
3727 gc_count_vector_total_size =
3728 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3730 sprintf (buf, "%s-storage", name);
3731 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3732 /* Okay, simple pluralization check for `symbol-value-varalias' */
3733 if (name[len-1] == 's')
3734 sprintf (buf, "%ses-freed", name);
3736 sprintf (buf, "%ss-freed", name);
3737 if (lcrecord_stats[i].instances_freed != 0)
3738 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3739 if (name[len-1] == 's')
3740 sprintf (buf, "%ses-on-free-list", name);
3742 sprintf (buf, "%ss-on-free-list", name);
3743 if (lcrecord_stats[i].instances_on_free_list != 0)
3744 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3746 if (name[len-1] == 's')
3747 sprintf (buf, "%ses-used", name);
3749 sprintf (buf, "%ss-used", name);
3750 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3754 HACK_O_MATIC (extent, "extent-storage", pl);
3755 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3756 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3757 HACK_O_MATIC (event, "event-storage", pl);
3758 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3759 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3760 HACK_O_MATIC (marker, "marker-storage", pl);
3761 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3762 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3763 #ifdef LISP_FLOAT_TYPE
3764 HACK_O_MATIC (float, "float-storage", pl);
3765 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3766 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3767 #endif /* LISP_FLOAT_TYPE */
3768 HACK_O_MATIC (string, "string-header-storage", pl);
3769 pl = gc_plist_hack ("long-strings-total-length",
3770 gc_count_string_total_size
3771 - gc_count_short_string_total_size, pl);
3772 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3773 pl = gc_plist_hack ("short-strings-total-length",
3774 gc_count_short_string_total_size, pl);
3775 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3776 pl = gc_plist_hack ("long-strings-used",
3777 gc_count_num_string_in_use
3778 - gc_count_num_short_string_in_use, pl);
3779 pl = gc_plist_hack ("short-strings-used",
3780 gc_count_num_short_string_in_use, pl);
3782 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3783 pl = gc_plist_hack ("compiled-functions-free",
3784 gc_count_num_compiled_function_freelist, pl);
3785 pl = gc_plist_hack ("compiled-functions-used",
3786 gc_count_num_compiled_function_in_use, pl);
3788 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3789 pl = gc_plist_hack ("bit-vectors-total-length",
3790 gc_count_bit_vector_total_size, pl);
3791 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3793 HACK_O_MATIC (symbol, "symbol-storage", pl);
3794 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3795 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3797 HACK_O_MATIC (cons, "cons-storage", pl);
3798 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3799 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3801 /* The things we do for backwards-compatibility */
3803 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3804 make_int (gc_count_num_cons_freelist)),
3805 Fcons (make_int (gc_count_num_symbol_in_use),
3806 make_int (gc_count_num_symbol_freelist)),
3807 Fcons (make_int (gc_count_num_marker_in_use),
3808 make_int (gc_count_num_marker_freelist)),
3809 make_int (gc_count_string_total_size),
3810 make_int (gc_count_vector_total_size),
3815 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3816 Return the number of bytes consed since the last garbage collection.
3817 \"Consed\" is a misnomer in that this actually counts allocation
3818 of all different kinds of objects, not just conses.
3820 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3824 return make_int (consing_since_gc);
3828 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
3829 Return the address of the last byte Emacs has allocated, divided by 1024.
3830 This may be helpful in debugging Emacs's memory usage.
3831 The value is divided by 1024 to make sure it will fit in a lisp integer.
3835 return make_int ((EMACS_INT) sbrk (0) / 1024);
3841 object_dead_p (Lisp_Object obj)
3843 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3844 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3845 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3846 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3847 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3848 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3849 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3852 #ifdef MEMORY_USAGE_STATS
3854 /* Attempt to determine the actual amount of space that is used for
3855 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3857 It seems that the following holds:
3859 1. When using the old allocator (malloc.c):
3861 -- blocks are always allocated in chunks of powers of two. For
3862 each block, there is an overhead of 8 bytes if rcheck is not
3863 defined, 20 bytes if it is defined. In other words, a
3864 one-byte allocation needs 8 bytes of overhead for a total of
3865 9 bytes, and needs to have 16 bytes of memory chunked out for
3868 2. When using the new allocator (gmalloc.c):
3870 -- blocks are always allocated in chunks of powers of two up
3871 to 4096 bytes. Larger blocks are allocated in chunks of
3872 an integral multiple of 4096 bytes. The minimum block
3873 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3874 is defined. There is no per-block overhead, but there
3875 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3878 3. When using the system malloc, anything goes, but they are
3879 generally slower and more space-efficient than the GNU
3880 allocators. One possibly reasonable assumption to make
3881 for want of better data is that sizeof (void *), or maybe
3882 2 * sizeof (void *), is required as overhead and that
3883 blocks are allocated in the minimum required size except
3884 that some minimum block size is imposed (e.g. 16 bytes). */
3887 malloced_storage_size (void *ptr, size_t claimed_size,
3888 struct overhead_stats *stats)
3890 size_t orig_claimed_size = claimed_size;
3894 if (claimed_size < 2 * sizeof (void *))
3895 claimed_size = 2 * sizeof (void *);
3896 # ifdef SUNOS_LOCALTIME_BUG
3897 if (claimed_size < 16)
3900 if (claimed_size < 4096)
3904 /* compute the log base two, more or less, then use it to compute
3905 the block size needed. */
3907 /* It's big, it's heavy, it's wood! */
3908 while ((claimed_size /= 2) != 0)
3911 /* It's better than bad, it's good! */
3917 /* We have to come up with some average about the amount of
3919 if ((size_t) (rand () & 4095) < claimed_size)
3920 claimed_size += 3 * sizeof (void *);
3924 claimed_size += 4095;
3925 claimed_size &= ~4095;
3926 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3929 #elif defined (SYSTEM_MALLOC)
3931 if (claimed_size < 16)
3933 claimed_size += 2 * sizeof (void *);
3935 #else /* old GNU allocator */
3937 # ifdef rcheck /* #### may not be defined here */
3945 /* compute the log base two, more or less, then use it to compute
3946 the block size needed. */
3948 /* It's big, it's heavy, it's wood! */
3949 while ((claimed_size /= 2) != 0)
3952 /* It's better than bad, it's good! */
3960 #endif /* old GNU allocator */
3964 stats->was_requested += orig_claimed_size;
3965 stats->malloc_overhead += claimed_size - orig_claimed_size;
3967 return claimed_size;
3971 fixed_type_block_overhead (size_t size)
3973 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3974 size_t overhead = 0;
3975 size_t storage_size = malloced_storage_size (0, per_block, 0);
3976 while (size >= per_block)
3979 overhead += sizeof (void *) + per_block - storage_size;
3981 if (rand () % per_block < size)
3982 overhead += sizeof (void *) + per_block - storage_size;
3986 #endif /* MEMORY_USAGE_STATS */
3989 /* Initialization */
3991 reinit_alloc_once_early (void)
3993 gc_generation_number[0] = 0;
3994 breathing_space = 0;
3995 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3996 XSETINT (Vgc_message, 0);
3999 all_older_lcrecords = 0;
4001 ignore_malloc_warnings = 1;
4002 #ifdef DOUG_LEA_MALLOC
4003 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
4004 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
4005 #if 0 /* Moved to emacs.c */
4006 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
4009 init_string_alloc ();
4010 init_string_chars_alloc ();
4012 init_symbol_alloc ();
4013 init_compiled_function_alloc ();
4014 #ifdef LISP_FLOAT_TYPE
4015 init_float_alloc ();
4016 #endif /* LISP_FLOAT_TYPE */
4017 init_marker_alloc ();
4018 init_extent_alloc ();
4019 init_event_alloc ();
4021 ignore_malloc_warnings = 0;
4023 staticidx_nodump = 0;
4027 consing_since_gc = 0;
4029 gc_cons_threshold = 500000; /* XEmacs change */
4031 gc_cons_threshold = 15000; /* debugging */
4033 lrecord_uid_counter = 259;
4034 debug_string_purity = 0;
4037 gc_currently_forbidden = 0;
4038 gc_hooks_inhibited = 0;
4040 #ifdef ERROR_CHECK_TYPECHECK
4041 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4044 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
4046 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4048 #endif /* ERROR_CHECK_TYPECHECK */
4052 init_alloc_once_early (void)
4054 reinit_alloc_once_early ();
4058 for (i = 0; i < countof (lrecord_implementations_table); i++)
4059 lrecord_implementations_table[i] = 0;
4062 INIT_LRECORD_IMPLEMENTATION (cons);
4063 INIT_LRECORD_IMPLEMENTATION (vector);
4064 INIT_LRECORD_IMPLEMENTATION (string);
4065 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
4070 int pure_bytes_used = 0;
4079 syms_of_alloc (void)
4081 DEFSYMBOL (Qpre_gc_hook);
4082 DEFSYMBOL (Qpost_gc_hook);
4083 DEFSYMBOL (Qgarbage_collecting);
4088 DEFSUBR (Fbit_vector);
4089 DEFSUBR (Fmake_byte_code);
4090 DEFSUBR (Fmake_list);
4091 DEFSUBR (Fmake_vector);
4092 DEFSUBR (Fmake_bit_vector);
4093 DEFSUBR (Fmake_string);
4095 DEFSUBR (Fmake_symbol);
4096 DEFSUBR (Fmake_marker);
4097 DEFSUBR (Fpurecopy);
4098 DEFSUBR (Fgarbage_collect);
4100 DEFSUBR (Fmemory_limit);
4102 DEFSUBR (Fconsing_since_gc);
4106 vars_of_alloc (void)
4108 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
4109 *Number of bytes of consing between garbage collections.
4110 \"Consing\" is a misnomer in that this actually counts allocation
4111 of all different kinds of objects, not just conses.
4112 Garbage collection can happen automatically once this many bytes have been
4113 allocated since the last garbage collection. All data types count.
4115 Garbage collection happens automatically when `eval' or `funcall' are
4116 called. (Note that `funcall' is called implicitly as part of evaluation.)
4117 By binding this temporarily to a large number, you can effectively
4118 prevent garbage collection during a part of the program.
4120 See also `consing-since-gc'.
4123 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
4124 Number of bytes of sharable Lisp data allocated so far.
4128 DEFVAR_INT ("debug-allocation", &debug_allocation /*
4129 If non-zero, print out information to stderr about all objects allocated.
4130 See also `debug-allocation-backtrace-length'.
4132 debug_allocation = 0;
4134 DEFVAR_INT ("debug-allocation-backtrace-length",
4135 &debug_allocation_backtrace_length /*
4136 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4138 debug_allocation_backtrace_length = 2;
4141 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4142 Non-nil means loading Lisp code in order to dump an executable.
4143 This means that certain objects should be allocated in readonly space.
4146 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4147 Function or functions to be run just before each garbage collection.
4148 Interrupts, garbage collection, and errors are inhibited while this hook
4149 runs, so be extremely careful in what you add here. In particular, avoid
4150 consing, and do not interact with the user.
4152 Vpre_gc_hook = Qnil;
4154 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4155 Function or functions to be run just after each garbage collection.
4156 Interrupts, garbage collection, and errors are inhibited while this hook
4157 runs, so be extremely careful in what you add here. In particular, avoid
4158 consing, and do not interact with the user.
4160 Vpost_gc_hook = Qnil;
4162 DEFVAR_LISP ("gc-message", &Vgc_message /*
4163 String to print to indicate that a garbage collection is in progress.
4164 This is printed in the echo area. If the selected frame is on a
4165 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4166 image instance) in the domain of the selected frame, the mouse pointer
4167 will change instead of this message being printed.
4169 Vgc_message = build_string (gc_default_message);
4171 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4172 Pointer glyph used to indicate that a garbage collection is in progress.
4173 If the selected window is on a window system and this glyph specifies a
4174 value (i.e. a pointer image instance) in the domain of the selected
4175 window, the pointer will be changed as specified during garbage collection.
4176 Otherwise, a message will be printed in the echo area, as controlled
4182 complex_vars_of_alloc (void)
4184 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);