1 /* Storage allocation and gc for XEmacs Lisp interpreter.
2 Copyright (C) 1985-1998 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
4 Copyright (C) 1995, 1996 Ben Wing.
6 This file is part of XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from
28 FSF: Original version; a long time ago.
29 Mly: Significantly rewritten to use new 3-bit tags and
30 nicely abstracted object definitions, for 19.8.
31 JWZ: Improved code to keep track of purespace usage and
32 issue nice purespace and GC stats.
33 Ben Wing: Cleaned up frob-block lrecord code, added error-checking
34 and various changes for Mule, for 19.12.
35 Added bit vectors for 19.13.
36 Added lcrecord lists for 19.14.
37 slb: Lots of work on the purification and dump time code.
38 Synched Doug Lea malloc support from Emacs 20.2.
39 og: Killed the purespace. Portable dumper (moved to dumper.c)
45 #include "backtrace.h"
56 #include "redisplay.h"
57 #include "specifier.h"
61 #include "console-stream.h"
63 #ifdef DOUG_LEA_MALLOC
71 EXFUN (Fgarbage_collect, 0);
73 #if 0 /* this is _way_ too slow to be part of the standard debug options */
74 #if defined(DEBUG_XEMACS) && defined(MULE)
75 #define VERIFY_STRING_CHARS_INTEGRITY
79 /* Define this to use malloc/free with no freelist for all datatypes,
80 the hope being that some debugging tools may help detect
81 freed memory references */
82 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
84 #define ALLOC_NO_POOLS
88 static int debug_allocation;
89 static int debug_allocation_backtrace_length;
92 /* Number of bytes of consing done since the last gc */
93 EMACS_INT consing_since_gc;
94 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
96 #define debug_allocation_backtrace() \
98 if (debug_allocation_backtrace_length > 0) \
99 debug_short_backtrace (debug_allocation_backtrace_length); \
103 #define INCREMENT_CONS_COUNTER(foosize, type) \
105 if (debug_allocation) \
107 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
108 debug_allocation_backtrace (); \
110 INCREMENT_CONS_COUNTER_1 (foosize); \
112 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
114 if (debug_allocation > 1) \
116 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
117 debug_allocation_backtrace (); \
119 INCREMENT_CONS_COUNTER_1 (foosize); \
122 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
123 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
124 INCREMENT_CONS_COUNTER_1 (size)
127 #define DECREMENT_CONS_COUNTER(size) do { \
128 consing_since_gc -= (size); \
129 if (consing_since_gc < 0) \
130 consing_since_gc = 0; \
133 /* Number of bytes of consing since gc before another gc should be done. */
134 EMACS_INT gc_cons_threshold;
136 /* Nonzero during gc */
139 /* Number of times GC has happened at this level or below.
140 * Level 0 is most volatile, contrary to usual convention.
141 * (Of course, there's only one level at present) */
142 EMACS_INT gc_generation_number[1];
144 /* This is just for use by the printer, to allow things to print uniquely */
145 static int lrecord_uid_counter;
147 /* Nonzero when calling certain hooks or doing other things where
149 int gc_currently_forbidden;
152 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
153 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
155 /* "Garbage collecting" */
156 Lisp_Object Vgc_message;
157 Lisp_Object Vgc_pointer_glyph;
158 static const char gc_default_message[] = "Garbage collecting";
159 Lisp_Object Qgarbage_collecting;
161 /* Non-zero means we're in the process of doing the dump */
164 #ifdef ERROR_CHECK_TYPECHECK
166 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
171 c_readonly (Lisp_Object obj)
173 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
177 lisp_readonly (Lisp_Object obj)
179 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
183 /* Maximum amount of C stack to save when a GC happens. */
185 #ifndef MAX_SAVE_STACK
186 #define MAX_SAVE_STACK 0 /* 16000 */
189 /* Non-zero means ignore malloc warnings. Set during initialization. */
190 int ignore_malloc_warnings;
193 static void *breathing_space;
196 release_breathing_space (void)
200 void *tmp = breathing_space;
206 /* malloc calls this if it finds we are near exhausting storage */
208 malloc_warning (const char *str)
210 if (ignore_malloc_warnings)
216 "Killing some buffers may delay running out of memory.\n"
217 "However, certainly by the time you receive the 95%% warning,\n"
218 "you should clean up, kill this Emacs, and start a new one.",
222 /* Called if malloc returns zero */
226 /* Force a GC next time eval is called.
227 It's better to loop garbage-collecting (we might reclaim enough
228 to win) than to loop beeping and barfing "Memory exhausted"
230 consing_since_gc = gc_cons_threshold + 1;
231 release_breathing_space ();
233 /* Flush some histories which might conceivably contain garbalogical
235 if (!NILP (Fboundp (Qvalues)))
236 Fset (Qvalues, Qnil);
237 Vcommand_history = Qnil;
239 error ("Memory exhausted");
242 /* like malloc and realloc but check for no memory left, and block input. */
246 xmalloc (size_t size)
248 void *val = malloc (size);
250 if (!val && (size != 0)) memory_full ();
256 xcalloc (size_t nelem, size_t elsize)
258 void *val = calloc (nelem, elsize);
260 if (!val && (nelem != 0)) memory_full ();
265 xmalloc_and_zero (size_t size)
267 return xcalloc (size, sizeof (char));
272 xrealloc (void *block, size_t size)
274 /* We must call malloc explicitly when BLOCK is 0, since some
275 reallocs don't do this. */
276 void *val = block ? realloc (block, size) : malloc (size);
278 if (!val && (size != 0)) memory_full ();
283 #ifdef ERROR_CHECK_MALLOC
284 xfree_1 (void *block)
289 #ifdef ERROR_CHECK_MALLOC
290 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
291 error until much later on for many system mallocs, such as
292 the one that comes with Solaris 2.3. FMH!! */
293 assert (block != (void *) 0xDEADBEEF);
295 #endif /* ERROR_CHECK_MALLOC */
299 #ifdef ERROR_CHECK_GC
302 typedef unsigned int four_byte_t;
303 #elif SIZEOF_LONG == 4
304 typedef unsigned long four_byte_t;
305 #elif SIZEOF_SHORT == 4
306 typedef unsigned short four_byte_t;
308 What kind of strange-ass system are we running on?
312 deadbeef_memory (void *ptr, size_t size)
314 four_byte_t *ptr4 = (four_byte_t *) ptr;
315 size_t beefs = size >> 2;
317 /* In practice, size will always be a multiple of four. */
319 (*ptr4++) = 0xDEADBEEF;
322 #else /* !ERROR_CHECK_GC */
325 #define deadbeef_memory(ptr, size)
327 #endif /* !ERROR_CHECK_GC */
331 xstrdup (const char *str)
333 int len = strlen (str) + 1; /* for stupid terminating 0 */
335 void *val = xmalloc (len);
336 if (val == 0) return 0;
337 return (char *) memcpy (val, str, len);
342 strdup (const char *s)
346 #endif /* NEED_STRDUP */
350 allocate_lisp_storage (size_t size)
352 return xmalloc (size);
356 /* lcrecords are chained together through their "next" field.
357 After doing the mark phase, GC will walk this linked list
358 and free any lcrecord which hasn't been marked. */
359 static struct lcrecord_header *all_lcrecords;
362 alloc_lcrecord (size_t size, const struct lrecord_implementation *implementation)
364 struct lcrecord_header *lcheader;
367 ((implementation->static_size == 0 ?
368 implementation->size_in_bytes_method != NULL :
369 implementation->static_size == size)
371 (! implementation->basic_p)
373 (! (implementation->hash == NULL && implementation->equal != NULL)));
375 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
376 set_lheader_implementation (&lcheader->lheader, implementation);
377 lcheader->next = all_lcrecords;
378 #if 1 /* mly prefers to see small ID numbers */
379 lcheader->uid = lrecord_uid_counter++;
380 #else /* jwz prefers to see real addrs */
381 lcheader->uid = (int) &lcheader;
384 all_lcrecords = lcheader;
385 INCREMENT_CONS_COUNTER (size, implementation->name);
389 #if 0 /* Presently unused */
390 /* Very, very poor man's EGC?
391 * This may be slow and thrash pages all over the place.
392 * Only call it if you really feel you must (and if the
393 * lrecord was fairly recently allocated).
394 * Otherwise, just let the GC do its job -- that's what it's there for
397 free_lcrecord (struct lcrecord_header *lcrecord)
399 if (all_lcrecords == lcrecord)
401 all_lcrecords = lcrecord->next;
405 struct lrecord_header *header = all_lcrecords;
408 struct lrecord_header *next = header->next;
409 if (next == lcrecord)
411 header->next = lrecord->next;
420 if (lrecord->implementation->finalizer)
421 lrecord->implementation->finalizer (lrecord, 0);
429 disksave_object_finalization_1 (void)
431 struct lcrecord_header *header;
433 for (header = all_lcrecords; header; header = header->next)
435 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
437 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
442 /************************************************************************/
443 /* Debugger support */
444 /************************************************************************/
445 /* Give gdb/dbx enough information to decode Lisp Objects. We make
446 sure certain symbols are always defined, so gdb doesn't complain
447 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
448 to see how this is used. */
450 const EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
451 const EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
453 #ifdef USE_UNION_TYPE
454 const unsigned char dbg_USE_UNION_TYPE = 1;
456 const unsigned char dbg_USE_UNION_TYPE = 0;
459 const unsigned char dbg_valbits = VALBITS;
460 const unsigned char dbg_gctypebits = GCTYPEBITS;
462 /* Macros turned into functions for ease of debugging.
463 Debuggers don't know about macros! */
464 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
466 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
468 return EQ (obj1, obj2);
472 /************************************************************************/
473 /* Fixed-size type macros */
474 /************************************************************************/
476 /* For fixed-size types that are commonly used, we malloc() large blocks
477 of memory at a time and subdivide them into chunks of the correct
478 size for an object of that type. This is more efficient than
479 malloc()ing each object separately because we save on malloc() time
480 and overhead due to the fewer number of malloc()ed blocks, and
481 also because we don't need any extra pointers within each object
482 to keep them threaded together for GC purposes. For less common
483 (and frequently large-size) types, we use lcrecords, which are
484 malloc()ed individually and chained together through a pointer
485 in the lcrecord header. lcrecords do not need to be fixed-size
486 (i.e. two objects of the same type need not have the same size;
487 however, the size of a particular object cannot vary dynamically).
488 It is also much easier to create a new lcrecord type because no
489 additional code needs to be added to alloc.c. Finally, lcrecords
490 may be more efficient when there are only a small number of them.
492 The types that are stored in these large blocks (or "frob blocks")
493 are cons, float, compiled-function, symbol, marker, extent, event,
496 Note that strings are special in that they are actually stored in
497 two parts: a structure containing information about the string, and
498 the actual data associated with the string. The former structure
499 (a struct Lisp_String) is a fixed-size structure and is managed the
500 same way as all the other such types. This structure contains a
501 pointer to the actual string data, which is stored in structures of
502 type struct string_chars_block. Each string_chars_block consists
503 of a pointer to a struct Lisp_String, followed by the data for that
504 string, followed by another pointer to a Lisp_String, followed by
505 the data for that string, etc. At GC time, the data in these
506 blocks is compacted by searching sequentially through all the
507 blocks and compressing out any holes created by unmarked strings.
508 Strings that are more than a certain size (bigger than the size of
509 a string_chars_block, although something like half as big might
510 make more sense) are malloc()ed separately and not stored in
511 string_chars_blocks. Furthermore, no one string stretches across
512 two string_chars_blocks.
514 Vectors are each malloc()ed separately, similar to lcrecords.
516 In the following discussion, we use conses, but it applies equally
517 well to the other fixed-size types.
519 We store cons cells inside of cons_blocks, allocating a new
520 cons_block with malloc() whenever necessary. Cons cells reclaimed
521 by GC are put on a free list to be reallocated before allocating
522 any new cons cells from the latest cons_block. Each cons_block is
523 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
524 the versions in malloc.c and gmalloc.c) really allocates in units
525 of powers of two and uses 4 bytes for its own overhead.
527 What GC actually does is to search through all the cons_blocks,
528 from the most recently allocated to the oldest, and put all
529 cons cells that are not marked (whether or not they're already
530 free) on a cons_free_list. The cons_free_list is a stack, and
531 so the cons cells in the oldest-allocated cons_block end up
532 at the head of the stack and are the first to be reallocated.
533 If any cons_block is entirely free, it is freed with free()
534 and its cons cells removed from the cons_free_list. Because
535 the cons_free_list ends up basically in memory order, we have
536 a high locality of reference (assuming a reasonable turnover
537 of allocating and freeing) and have a reasonable probability
538 of entirely freeing up cons_blocks that have been more recently
539 allocated. This stage is called the "sweep stage" of GC, and
540 is executed after the "mark stage", which involves starting
541 from all places that are known to point to in-use Lisp objects
542 (e.g. the obarray, where are all symbols are stored; the
543 current catches and condition-cases; the backtrace list of
544 currently executing functions; the gcpro list; etc.) and
545 recursively marking all objects that are accessible.
547 At the beginning of the sweep stage, the conses in the cons
548 blocks are in one of three states: in use and marked, in use
549 but not marked, and not in use (already freed). Any conses
550 that are marked have been marked in the mark stage just
551 executed, because as part of the sweep stage we unmark any
552 marked objects. The way we tell whether or not a cons cell
553 is in use is through the FREE_STRUCT_P macro. This basically
554 looks at the first 4 bytes (or however many bytes a pointer
555 fits in) to see if all the bits in those bytes are 1. The
556 resulting value (0xFFFFFFFF) is not a valid pointer and is
557 not a valid Lisp_Object. All current fixed-size types have
558 a pointer or Lisp_Object as their first element with the
559 exception of strings; they have a size value, which can
560 never be less than zero, and so 0xFFFFFFFF is invalid for
561 strings as well. Now assuming that a cons cell is in use,
562 the way we tell whether or not it is marked is to look at
563 the mark bit of its car (each Lisp_Object has one bit
564 reserved as a mark bit, in case it's needed). Note that
565 different types of objects use different fields to indicate
566 whether the object is marked, but the principle is the same.
568 Conses on the free_cons_list are threaded through a pointer
569 stored in the bytes directly after the bytes that are set
570 to 0xFFFFFFFF (we cannot overwrite these because the cons
571 is still in a cons_block and needs to remain marked as
572 not in use for the next time that GC happens). This
573 implies that all fixed-size types must be at least big
574 enough to store two pointers, which is indeed the case
575 for all current fixed-size types.
577 Some types of objects need additional "finalization" done
578 when an object is converted from in use to not in use;
579 this is the purpose of the ADDITIONAL_FREE_type macro.
580 For example, markers need to be removed from the chain
581 of markers that is kept in each buffer. This is because
582 markers in a buffer automatically disappear if the marker
583 is no longer referenced anywhere (the same does not
584 apply to extents, however).
586 WARNING: Things are in an extremely bizarre state when
587 the ADDITIONAL_FREE_type macros are called, so beware!
589 When ERROR_CHECK_GC is defined, we do things differently
590 so as to maximize our chances of catching places where
591 there is insufficient GCPROing. The thing we want to
592 avoid is having an object that we're using but didn't
593 GCPRO get freed by GC and then reallocated while we're
594 in the process of using it -- this will result in something
595 seemingly unrelated getting trashed, and is extremely
596 difficult to track down. If the object gets freed but
597 not reallocated, we can usually catch this because we
598 set all bytes of a freed object to 0xDEADBEEF. (The
599 first four bytes, however, are 0xFFFFFFFF, and the next
600 four are a pointer used to chain freed objects together;
601 we play some tricks with this pointer to make it more
602 bogus, so crashes are more likely to occur right away.)
604 We want freed objects to stay free as long as possible,
605 so instead of doing what we do above, we maintain the
606 free objects in a first-in first-out queue. We also
607 don't recompute the free list each GC, unlike above;
608 this ensures that the queue ordering is preserved.
609 [This means that we are likely to have worse locality
610 of reference, and that we can never free a frob block
611 once it's allocated. (Even if we know that all cells
612 in it are free, there's no easy way to remove all those
613 cells from the free list because the objects on the
614 free list are unlikely to be in memory order.)]
615 Furthermore, we never take objects off the free list
616 unless there's a large number (usually 1000, but
617 varies depending on type) of them already on the list.
618 This way, we ensure that an object that gets freed will
619 remain free for the next 1000 (or whatever) times that
620 an object of that type is allocated. */
622 #ifndef MALLOC_OVERHEAD
624 #define MALLOC_OVERHEAD 0
625 #elif defined (rcheck)
626 #define MALLOC_OVERHEAD 20
628 #define MALLOC_OVERHEAD 8
630 #endif /* MALLOC_OVERHEAD */
632 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
633 /* If we released our reserve (due to running out of memory),
634 and we have a fair amount free once again,
635 try to set aside another reserve in case we run out once more.
637 This is called when a relocatable block is freed in ralloc.c. */
638 void refill_memory_reserve (void);
640 refill_memory_reserve (void)
642 if (breathing_space == 0)
643 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
647 #ifdef ALLOC_NO_POOLS
648 # define TYPE_ALLOC_SIZE(type, structtype) 1
650 # define TYPE_ALLOC_SIZE(type, structtype) \
651 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
652 / sizeof (structtype))
653 #endif /* ALLOC_NO_POOLS */
655 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
657 struct type##_block \
659 struct type##_block *prev; \
660 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
663 static struct type##_block *current_##type##_block; \
664 static int current_##type##_block_index; \
666 static structtype *type##_free_list; \
667 static structtype *type##_free_list_tail; \
670 init_##type##_alloc (void) \
672 current_##type##_block = 0; \
673 current_##type##_block_index = \
674 countof (current_##type##_block->block); \
675 type##_free_list = 0; \
676 type##_free_list_tail = 0; \
679 static int gc_count_num_##type##_in_use; \
680 static int gc_count_num_##type##_freelist
682 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
683 if (current_##type##_block_index \
684 == countof (current_##type##_block->block)) \
686 struct type##_block *AFTFB_new = (struct type##_block *) \
687 allocate_lisp_storage (sizeof (struct type##_block)); \
688 AFTFB_new->prev = current_##type##_block; \
689 current_##type##_block = AFTFB_new; \
690 current_##type##_block_index = 0; \
693 &(current_##type##_block->block[current_##type##_block_index++]); \
696 /* Allocate an instance of a type that is stored in blocks.
697 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
700 #ifdef ERROR_CHECK_GC
702 /* Note: if you get crashes in this function, suspect incorrect calls
703 to free_cons() and friends. This happened once because the cons
704 cell was not GC-protected and was getting collected before
705 free_cons() was called. */
707 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
710 if (gc_count_num_##type##_freelist > \
711 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
713 result = type##_free_list; \
714 /* Before actually using the chain pointer, we complement all its \
715 bits; see FREE_FIXED_TYPE(). */ \
717 (structtype *) ~(unsigned long) \
718 (* (structtype **) ((char *) result + sizeof (void *))); \
719 gc_count_num_##type##_freelist--; \
722 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
723 MARK_STRUCT_AS_NOT_FREE (result); \
726 #else /* !ERROR_CHECK_GC */
728 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
731 if (type##_free_list) \
733 result = type##_free_list; \
735 * (structtype **) ((char *) result + sizeof (void *)); \
738 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
739 MARK_STRUCT_AS_NOT_FREE (result); \
742 #endif /* !ERROR_CHECK_GC */
744 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
747 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
748 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
751 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
754 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
755 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
758 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
759 to a Lisp object and invalid as an actual Lisp_Object value. We have
760 to make sure that this value cannot be an integer in Lisp_Object form.
761 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
762 On a 32-bit system, the type bits will be non-zero, making the value
763 be a pointer, and the pointer will be misaligned.
765 Even if Emacs is run on some weirdo system that allows and allocates
766 byte-aligned pointers, this pointer is at the very top of the address
767 space and so it's almost inconceivable that it could ever be valid. */
770 # define INVALID_POINTER_VALUE 0xFFFFFFFF
772 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
774 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
776 You have some weird system and need to supply a reasonable value here.
779 /* The construct (* (void **) (ptr)) would cause aliasing problems
780 with modern optimizing compilers like `gcc -O3 -fstrict-aliasing'.
781 But `char *' can legally alias any pointer. Hence this union trick...
783 It turned out that the union trick was not good enough for xlC -O3;
784 and it is questionable whether it really complies with the C standard.
785 so we use memset instead, which should be safe from optimizations. */
786 typedef union { char c; void *p; } *aliasing_voidpp;
787 #define ALIASING_VOIDPP_DEREFERENCE(ptr) \
788 (((aliasing_voidpp) (ptr))->p)
789 #define FREE_STRUCT_P(ptr) \
790 (ALIASING_VOIDPP_DEREFERENCE (ptr) == (void *) INVALID_POINTER_VALUE)
791 #define MARK_STRUCT_AS_FREE(ptr) memset (ptr, 0xff, sizeof (void *))
792 #define MARK_STRUCT_AS_NOT_FREE(ptr) memset (ptr, 0x00, sizeof (void *))
794 #ifdef ERROR_CHECK_GC
796 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
797 do { if (type##_free_list_tail) \
799 /* When we store the chain pointer, we complement all \
800 its bits; this should significantly increase its \
801 bogosity in case someone tries to use the value, and \
802 should make us dump faster if someone stores something \
803 over the pointer because when it gets un-complemented in \
804 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
805 extremely bogus. */ \
807 ((char *) type##_free_list_tail + sizeof (void *)) = \
808 (structtype *) ~(unsigned long) ptr; \
811 type##_free_list = ptr; \
812 type##_free_list_tail = ptr; \
815 #else /* !ERROR_CHECK_GC */
817 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
818 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
820 type##_free_list = (ptr); \
823 #endif /* !ERROR_CHECK_GC */
825 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
827 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
828 structtype *FFT_ptr = (ptr); \
829 ADDITIONAL_FREE_##type (FFT_ptr); \
830 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
831 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
832 MARK_STRUCT_AS_FREE (FFT_ptr); \
835 /* Like FREE_FIXED_TYPE() but used when we are explicitly
836 freeing a structure through free_cons(), free_marker(), etc.
837 rather than through the normal process of sweeping.
838 We attempt to undo the changes made to the allocation counters
839 as a result of this structure being allocated. This is not
840 completely necessary but helps keep things saner: e.g. this way,
841 repeatedly allocating and freeing a cons will not result in
842 the consing-since-gc counter advancing, which would cause a GC
843 and somewhat defeat the purpose of explicitly freeing. */
845 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
846 do { FREE_FIXED_TYPE (type, structtype, ptr); \
847 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
848 gc_count_num_##type##_freelist++; \
853 /************************************************************************/
854 /* Cons allocation */
855 /************************************************************************/
857 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
858 /* conses are used and freed so often that we set this really high */
859 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
860 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
863 mark_cons (Lisp_Object obj)
865 if (NILP (XCDR (obj)))
868 mark_object (XCAR (obj));
873 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
876 while (internal_equal (XCAR (ob1), XCAR (ob2), depth))
880 if (! CONSP (ob1) || ! CONSP (ob2))
881 return internal_equal (ob1, ob2, depth);
886 static const struct lrecord_description cons_description[] = {
887 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
888 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
892 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
893 mark_cons, print_cons, 0,
896 * No `hash' method needed.
897 * internal_hash knows how to
904 DEFUN ("cons", Fcons, 2, 2, 0, /*
905 Create a new cons, give it CAR and CDR as components, and return it.
909 /* This cannot GC. */
913 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
914 set_lheader_implementation (&c->lheader, &lrecord_cons);
921 /* This is identical to Fcons() but it used for conses that we're
922 going to free later, and is useful when trying to track down
925 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
930 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
931 set_lheader_implementation (&c->lheader, &lrecord_cons);
938 DEFUN ("list", Flist, 0, MANY, 0, /*
939 Return a newly created list with specified arguments as elements.
940 Any number of arguments, even zero arguments, are allowed.
942 (int nargs, Lisp_Object *args))
944 Lisp_Object val = Qnil;
945 Lisp_Object *argp = args + nargs;
948 val = Fcons (*--argp, val);
953 list1 (Lisp_Object obj0)
955 /* This cannot GC. */
956 return Fcons (obj0, Qnil);
960 list2 (Lisp_Object obj0, Lisp_Object obj1)
962 /* This cannot GC. */
963 return Fcons (obj0, Fcons (obj1, Qnil));
967 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
969 /* This cannot GC. */
970 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
974 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
976 /* This cannot GC. */
977 return Fcons (obj0, Fcons (obj1, obj2));
981 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
983 return Fcons (Fcons (key, value), alist);
987 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
989 /* This cannot GC. */
990 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
994 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
997 /* This cannot GC. */
998 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1002 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1003 Lisp_Object obj4, Lisp_Object obj5)
1005 /* This cannot GC. */
1006 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1009 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1010 Return a new list of length LENGTH, with each element being OBJECT.
1014 CHECK_NATNUM (length);
1017 Lisp_Object val = Qnil;
1018 size_t size = XINT (length);
1021 val = Fcons (object, val);
1027 /************************************************************************/
1028 /* Float allocation */
1029 /************************************************************************/
1031 #ifdef LISP_FLOAT_TYPE
1033 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
1034 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1037 make_float (double float_value)
1042 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
1044 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1045 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1048 set_lheader_implementation (&f->lheader, &lrecord_float);
1049 float_data (f) = float_value;
1054 #endif /* LISP_FLOAT_TYPE */
1057 /************************************************************************/
1058 /* Vector allocation */
1059 /************************************************************************/
1062 mark_vector (Lisp_Object obj)
1064 Lisp_Vector *ptr = XVECTOR (obj);
1065 int len = vector_length (ptr);
1068 for (i = 0; i < len - 1; i++)
1069 mark_object (ptr->contents[i]);
1070 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1074 size_vector (const void *lheader)
1076 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, contents,
1077 ((Lisp_Vector *) lheader)->size);
1081 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1083 int len = XVECTOR_LENGTH (obj1);
1084 if (len != XVECTOR_LENGTH (obj2))
1088 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1089 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1091 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1098 vector_hash (Lisp_Object obj, int depth)
1100 return HASH2 (XVECTOR_LENGTH (obj),
1101 internal_array_hash (XVECTOR_DATA (obj),
1102 XVECTOR_LENGTH (obj),
1106 static const struct lrecord_description vector_description[] = {
1107 { XD_LONG, offsetof (Lisp_Vector, size) },
1108 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1112 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1113 mark_vector, print_vector, 0,
1117 size_vector, Lisp_Vector);
1119 /* #### should allocate `small' vectors from a frob-block */
1120 static Lisp_Vector *
1121 make_vector_internal (size_t sizei)
1123 /* no vector_next */
1124 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1125 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1132 make_vector (size_t length, Lisp_Object object)
1134 Lisp_Vector *vecp = make_vector_internal (length);
1135 Lisp_Object *p = vector_data (vecp);
1142 XSETVECTOR (vector, vecp);
1147 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1148 Return a new vector of length LENGTH, with each element being OBJECT.
1149 See also the function `vector'.
1153 CONCHECK_NATNUM (length);
1154 return make_vector (XINT (length), object);
1157 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1158 Return a newly created vector with specified arguments as elements.
1159 Any number of arguments, even zero arguments, are allowed.
1161 (int nargs, Lisp_Object *args))
1163 Lisp_Vector *vecp = make_vector_internal (nargs);
1164 Lisp_Object *p = vector_data (vecp);
1171 XSETVECTOR (vector, vecp);
1177 vector1 (Lisp_Object obj0)
1179 return Fvector (1, &obj0);
1183 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1185 Lisp_Object args[2];
1188 return Fvector (2, args);
1192 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1194 Lisp_Object args[3];
1198 return Fvector (3, args);
1201 #if 0 /* currently unused */
1204 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1207 Lisp_Object args[4];
1212 return Fvector (4, args);
1216 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1217 Lisp_Object obj3, Lisp_Object obj4)
1219 Lisp_Object args[5];
1225 return Fvector (5, args);
1229 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1230 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1232 Lisp_Object args[6];
1239 return Fvector (6, args);
1243 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1244 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1247 Lisp_Object args[7];
1255 return Fvector (7, args);
1259 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1260 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1261 Lisp_Object obj6, Lisp_Object obj7)
1263 Lisp_Object args[8];
1272 return Fvector (8, args);
1276 /************************************************************************/
1277 /* Bit Vector allocation */
1278 /************************************************************************/
1280 static Lisp_Object all_bit_vectors;
1282 /* #### should allocate `small' bit vectors from a frob-block */
1283 static Lisp_Bit_Vector *
1284 make_bit_vector_internal (size_t sizei)
1286 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1287 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1288 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1289 set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
1291 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1293 bit_vector_length (p) = sizei;
1294 bit_vector_next (p) = all_bit_vectors;
1295 /* make sure the extra bits in the last long are 0; the calling
1296 functions might not set them. */
1297 p->bits[num_longs - 1] = 0;
1298 XSETBIT_VECTOR (all_bit_vectors, p);
1303 make_bit_vector (size_t length, Lisp_Object bit)
1305 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1306 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1311 memset (p->bits, 0, num_longs * sizeof (long));
1314 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1315 memset (p->bits, ~0, num_longs * sizeof (long));
1316 /* But we have to make sure that the unused bits in the
1317 last long are 0, so that equal/hash is easy. */
1319 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1323 Lisp_Object bit_vector;
1324 XSETBIT_VECTOR (bit_vector, p);
1330 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1333 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1335 for (i = 0; i < length; i++)
1336 set_bit_vector_bit (p, i, bytevec[i]);
1339 Lisp_Object bit_vector;
1340 XSETBIT_VECTOR (bit_vector, p);
1345 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1346 Return a new bit vector of length LENGTH. with each bit set to BIT.
1347 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
1351 CONCHECK_NATNUM (length);
1353 return make_bit_vector (XINT (length), bit);
1356 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1357 Return a newly created bit vector with specified arguments as elements.
1358 Any number of arguments, even zero arguments, are allowed.
1359 Each argument must be one of the integers 0 or 1.
1361 (int nargs, Lisp_Object *args))
1364 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1366 for (i = 0; i < nargs; i++)
1368 CHECK_BIT (args[i]);
1369 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1373 Lisp_Object bit_vector;
1374 XSETBIT_VECTOR (bit_vector, p);
1380 /************************************************************************/
1381 /* Compiled-function allocation */
1382 /************************************************************************/
1384 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1385 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1388 make_compiled_function (void)
1390 Lisp_Compiled_Function *f;
1393 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1394 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
1397 f->specpdl_depth = 0;
1398 f->flags.documentationp = 0;
1399 f->flags.interactivep = 0;
1400 f->flags.domainp = 0; /* I18N3 */
1401 f->instructions = Qzero;
1402 f->constants = Qzero;
1404 f->doc_and_interactive = Qnil;
1405 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1406 f->annotated = Qnil;
1408 XSETCOMPILED_FUNCTION (fun, f);
1412 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1413 Return a new compiled-function object.
1414 Usage: (arglist instructions constants stack-depth
1415 &optional doc-string interactive)
1416 Note that, unlike all other emacs-lisp functions, calling this with five
1417 arguments is NOT the same as calling it with six arguments, the last of
1418 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1419 that this function was defined with `(interactive)'. If the arg is not
1420 specified, then that means the function is not interactive.
1421 This is terrible behavior which is retained for compatibility with old
1422 `.elc' files which expect these semantics.
1424 (int nargs, Lisp_Object *args))
1426 /* In a non-insane world this function would have this arglist...
1427 (arglist instructions constants stack_depth &optional doc_string interactive)
1429 Lisp_Object fun = make_compiled_function ();
1430 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1432 Lisp_Object arglist = args[0];
1433 Lisp_Object instructions = args[1];
1434 Lisp_Object constants = args[2];
1435 Lisp_Object stack_depth = args[3];
1436 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1437 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1439 if (nargs < 4 || nargs > 6)
1440 return Fsignal (Qwrong_number_of_arguments,
1441 list2 (intern ("make-byte-code"), make_int (nargs)));
1443 /* Check for valid formal parameter list now, to allow us to use
1444 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1446 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1448 CHECK_SYMBOL (symbol);
1449 if (EQ (symbol, Qt) ||
1450 EQ (symbol, Qnil) ||
1451 SYMBOL_IS_KEYWORD (symbol))
1452 signal_simple_error_2
1453 ("Invalid constant symbol in formal parameter list",
1457 f->arglist = arglist;
1459 /* `instructions' is a string or a cons (string . int) for a
1460 lazy-loaded function. */
1461 if (CONSP (instructions))
1463 CHECK_STRING (XCAR (instructions));
1464 CHECK_INT (XCDR (instructions));
1468 CHECK_STRING (instructions);
1470 f->instructions = instructions;
1472 if (!NILP (constants))
1473 CHECK_VECTOR (constants);
1474 f->constants = constants;
1476 CHECK_NATNUM (stack_depth);
1477 f->stack_depth = (unsigned short) XINT (stack_depth);
1479 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1480 if (!NILP (Vcurrent_compiled_function_annotation))
1481 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1482 else if (!NILP (Vload_file_name_internal_the_purecopy))
1483 f->annotated = Vload_file_name_internal_the_purecopy;
1484 else if (!NILP (Vload_file_name_internal))
1486 struct gcpro gcpro1;
1487 GCPRO1 (fun); /* don't let fun get reaped */
1488 Vload_file_name_internal_the_purecopy =
1489 Ffile_name_nondirectory (Vload_file_name_internal);
1490 f->annotated = Vload_file_name_internal_the_purecopy;
1493 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1495 /* doc_string may be nil, string, int, or a cons (string . int).
1496 interactive may be list or string (or unbound). */
1497 f->doc_and_interactive = Qunbound;
1499 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1500 f->doc_and_interactive = Vfile_domain;
1502 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1504 f->doc_and_interactive
1505 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1506 Fcons (interactive, f->doc_and_interactive));
1508 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1510 f->doc_and_interactive
1511 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1512 Fcons (doc_string, f->doc_and_interactive));
1514 if (UNBOUNDP (f->doc_and_interactive))
1515 f->doc_and_interactive = Qnil;
1521 /************************************************************************/
1522 /* Symbol allocation */
1523 /************************************************************************/
1525 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1526 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1528 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1529 Return a newly allocated uninterned symbol whose name is NAME.
1530 Its value and function definition are void, and its property list is nil.
1537 CHECK_STRING (name);
1539 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1540 set_lheader_implementation (&p->lheader, &lrecord_symbol);
1541 p->name = XSTRING (name);
1543 p->value = Qunbound;
1544 p->function = Qunbound;
1545 symbol_next (p) = 0;
1546 XSETSYMBOL (val, p);
1551 /************************************************************************/
1552 /* Extent allocation */
1553 /************************************************************************/
1555 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1556 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1559 allocate_extent (void)
1563 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1564 set_lheader_implementation (&e->lheader, &lrecord_extent);
1565 extent_object (e) = Qnil;
1566 set_extent_start (e, -1);
1567 set_extent_end (e, -1);
1572 extent_face (e) = Qnil;
1573 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1574 e->flags.detachable = 1;
1580 /************************************************************************/
1581 /* Event allocation */
1582 /************************************************************************/
1584 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1585 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1588 allocate_event (void)
1593 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1594 set_lheader_implementation (&e->lheader, &lrecord_event);
1601 /************************************************************************/
1602 /* Marker allocation */
1603 /************************************************************************/
1605 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1606 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1608 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1609 Return a new marker which does not point at any place.
1616 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1617 set_lheader_implementation (&p->lheader, &lrecord_marker);
1620 marker_next (p) = 0;
1621 marker_prev (p) = 0;
1622 p->insertion_type = 0;
1623 XSETMARKER (val, p);
1628 noseeum_make_marker (void)
1633 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1634 set_lheader_implementation (&p->lheader, &lrecord_marker);
1637 marker_next (p) = 0;
1638 marker_prev (p) = 0;
1639 p->insertion_type = 0;
1640 XSETMARKER (val, p);
1645 /************************************************************************/
1646 /* String allocation */
1647 /************************************************************************/
1649 /* The data for "short" strings generally resides inside of structs of type
1650 string_chars_block. The Lisp_String structure is allocated just like any
1651 other Lisp object (except for vectors), and these are freelisted when
1652 they get garbage collected. The data for short strings get compacted,
1653 but the data for large strings do not.
1655 Previously Lisp_String structures were relocated, but this caused a lot
1656 of bus-errors because the C code didn't include enough GCPRO's for
1657 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1658 that the reference would get relocated).
1660 This new method makes things somewhat bigger, but it is MUCH safer. */
1662 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1663 /* strings are used and freed quite often */
1664 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1665 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1668 mark_string (Lisp_Object obj)
1670 Lisp_String *ptr = XSTRING (obj);
1672 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1673 flush_cached_extent_info (XCAR (ptr->plist));
1678 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1681 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1682 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1685 static const struct lrecord_description string_description[] = {
1686 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1687 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1688 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1692 /* We store the string's extent info as the first element of the string's
1693 property list; and the string's MODIFF as the first or second element
1694 of the string's property list (depending on whether the extent info
1695 is present), but only if the string has been modified. This is ugly
1696 but it reduces the memory allocated for the string in the vast
1697 majority of cases, where the string is never modified and has no
1700 #### This means you can't use an int as a key in a string's plist. */
1702 static Lisp_Object *
1703 string_plist_ptr (Lisp_Object string)
1705 Lisp_Object *ptr = &XSTRING (string)->plist;
1707 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
1709 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
1715 string_getprop (Lisp_Object string, Lisp_Object property)
1717 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
1721 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
1723 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
1728 string_remprop (Lisp_Object string, Lisp_Object property)
1730 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
1734 string_plist (Lisp_Object string)
1736 return *string_plist_ptr (string);
1739 /* No `finalize', or `hash' methods.
1740 internal_hash() already knows how to hash strings and finalization
1741 is done with the ADDITIONAL_FREE_string macro, which is the
1742 standard way to do finalization when using
1743 SWEEP_FIXED_TYPE_BLOCK(). */
1744 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
1745 mark_string, print_string,
1754 /* String blocks contain this many useful bytes. */
1755 #define STRING_CHARS_BLOCK_SIZE \
1756 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1757 ((2 * sizeof (struct string_chars_block *)) \
1758 + sizeof (EMACS_INT))))
1759 /* Block header for small strings. */
1760 struct string_chars_block
1763 struct string_chars_block *next;
1764 struct string_chars_block *prev;
1765 /* Contents of string_chars_block->string_chars are interleaved
1766 string_chars structures (see below) and the actual string data */
1767 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1770 static struct string_chars_block *first_string_chars_block;
1771 static struct string_chars_block *current_string_chars_block;
1773 /* If SIZE is the length of a string, this returns how many bytes
1774 * the string occupies in string_chars_block->string_chars
1775 * (including alignment padding).
1777 #define STRING_FULLSIZE(size) \
1778 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1779 ALIGNOF (Lisp_String *))
1781 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1782 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1786 Lisp_String *string;
1787 unsigned char chars[1];
1790 struct unused_string_chars
1792 Lisp_String *string;
1797 init_string_chars_alloc (void)
1799 first_string_chars_block = xnew (struct string_chars_block);
1800 first_string_chars_block->prev = 0;
1801 first_string_chars_block->next = 0;
1802 first_string_chars_block->pos = 0;
1803 current_string_chars_block = first_string_chars_block;
1806 static struct string_chars *
1807 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1810 struct string_chars *s_chars;
1813 (countof (current_string_chars_block->string_chars)
1814 - current_string_chars_block->pos))
1816 /* This string can fit in the current string chars block */
1817 s_chars = (struct string_chars *)
1818 (current_string_chars_block->string_chars
1819 + current_string_chars_block->pos);
1820 current_string_chars_block->pos += fullsize;
1824 /* Make a new current string chars block */
1825 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1827 current_string_chars_block->next = new_scb;
1828 new_scb->prev = current_string_chars_block;
1830 current_string_chars_block = new_scb;
1831 new_scb->pos = fullsize;
1832 s_chars = (struct string_chars *)
1833 current_string_chars_block->string_chars;
1836 s_chars->string = string_it_goes_with;
1838 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1844 make_uninit_string (Bytecount length)
1847 EMACS_INT fullsize = STRING_FULLSIZE (length);
1850 assert (length >= 0 && fullsize > 0);
1852 /* Allocate the string header */
1853 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1854 set_lheader_implementation (&s->lheader, &lrecord_string);
1856 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1857 ? xnew_array (Bufbyte, length + 1)
1858 : allocate_string_chars_struct (s, fullsize)->chars);
1860 set_string_length (s, length);
1863 set_string_byte (s, length, 0);
1865 XSETSTRING (val, s);
1869 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1870 static void verify_string_chars_integrity (void);
1873 /* Resize the string S so that DELTA bytes can be inserted starting
1874 at POS. If DELTA < 0, it means deletion starting at POS. If
1875 POS < 0, resize the string but don't copy any characters. Use
1876 this if you're planning on completely overwriting the string.
1880 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
1882 Bytecount oldfullsize, newfullsize;
1883 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1884 verify_string_chars_integrity ();
1887 #ifdef ERROR_CHECK_BUFPOS
1890 assert (pos <= string_length (s));
1892 assert (pos + (-delta) <= string_length (s));
1897 assert ((-delta) <= string_length (s));
1899 #endif /* ERROR_CHECK_BUFPOS */
1902 /* simplest case: no size change. */
1905 if (pos >= 0 && delta < 0)
1906 /* If DELTA < 0, the functions below will delete the characters
1907 before POS. We want to delete characters *after* POS, however,
1908 so convert this to the appropriate form. */
1911 oldfullsize = STRING_FULLSIZE (string_length (s));
1912 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1914 if (BIG_STRING_FULLSIZE_P (oldfullsize))
1916 if (BIG_STRING_FULLSIZE_P (newfullsize))
1918 /* Both strings are big. We can just realloc().
1919 But careful! If the string is shrinking, we have to
1920 memmove() _before_ realloc(), and if growing, we have to
1921 memmove() _after_ realloc() - otherwise the access is
1922 illegal, and we might crash. */
1923 Bytecount len = string_length (s) + 1 - pos;
1925 if (delta < 0 && pos >= 0)
1926 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1927 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1928 string_length (s) + delta + 1));
1929 if (delta > 0 && pos >= 0)
1930 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1932 else /* String has been demoted from BIG_STRING. */
1935 allocate_string_chars_struct (s, newfullsize)->chars;
1936 Bufbyte *old_data = string_data (s);
1940 memcpy (new_data, old_data, pos);
1941 memcpy (new_data + pos + delta, old_data + pos,
1942 string_length (s) + 1 - pos);
1944 set_string_data (s, new_data);
1948 else /* old string is small */
1950 if (oldfullsize == newfullsize)
1952 /* special case; size change but the necessary
1953 allocation size won't change (up or down; code
1954 somewhere depends on there not being any unused
1955 allocation space, modulo any alignment
1959 Bufbyte *addroff = pos + string_data (s);
1961 memmove (addroff + delta, addroff,
1962 /* +1 due to zero-termination. */
1963 string_length (s) + 1 - pos);
1968 Bufbyte *old_data = string_data (s);
1970 BIG_STRING_FULLSIZE_P (newfullsize)
1971 ? xnew_array (Bufbyte, string_length (s) + delta + 1)
1972 : allocate_string_chars_struct (s, newfullsize)->chars;
1976 memcpy (new_data, old_data, pos);
1977 memcpy (new_data + pos + delta, old_data + pos,
1978 string_length (s) + 1 - pos);
1980 set_string_data (s, new_data);
1983 /* We need to mark this chunk of the string_chars_block
1984 as unused so that compact_string_chars() doesn't
1986 struct string_chars *old_s_chars = (struct string_chars *)
1987 ((char *) old_data - offsetof (struct string_chars, chars));
1988 /* Sanity check to make sure we aren't hosed by strange
1989 alignment/padding. */
1990 assert (old_s_chars->string == s);
1991 MARK_STRUCT_AS_FREE (old_s_chars);
1992 ((struct unused_string_chars *) old_s_chars)->fullsize =
1998 set_string_length (s, string_length (s) + delta);
1999 /* If pos < 0, the string won't be zero-terminated.
2000 Terminate now just to make sure. */
2001 string_data (s)[string_length (s)] = '\0';
2007 XSETSTRING (string, s);
2008 /* We also have to adjust all of the extent indices after the
2009 place we did the change. We say "pos - 1" because
2010 adjust_extents() is exclusive of the starting position
2012 adjust_extents (string, pos - 1, string_length (s),
2016 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2017 verify_string_chars_integrity ();
2024 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2026 Bufbyte newstr[MAX_EMCHAR_LEN];
2027 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2028 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2029 Bytecount newlen = set_charptr_emchar (newstr, c);
2031 if (oldlen != newlen)
2032 resize_string (s, bytoff, newlen - oldlen);
2033 /* Remember, string_data (s) might have changed so we can't cache it. */
2034 memcpy (string_data (s) + bytoff, newstr, newlen);
2039 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2040 Return a new string consisting of LENGTH copies of CHARACTER.
2041 LENGTH must be a non-negative integer.
2043 (length, character))
2045 CHECK_NATNUM (length);
2046 CHECK_CHAR_COERCE_INT (character);
2048 Bufbyte init_str[MAX_EMCHAR_LEN];
2049 int len = set_charptr_emchar (init_str, XCHAR (character));
2050 Lisp_Object val = make_uninit_string (len * XINT (length));
2053 /* Optimize the single-byte case */
2054 memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val));
2058 Bufbyte *ptr = XSTRING_DATA (val);
2060 for (i = XINT (length); i; i--)
2062 Bufbyte *init_ptr = init_str;
2065 case 4: *ptr++ = *init_ptr++;
2066 case 3: *ptr++ = *init_ptr++;
2067 case 2: *ptr++ = *init_ptr++;
2068 case 1: *ptr++ = *init_ptr++;
2076 DEFUN ("string", Fstring, 0, MANY, 0, /*
2077 Concatenate all the argument characters and make the result a string.
2079 (int nargs, Lisp_Object *args))
2081 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2082 Bufbyte *p = storage;
2084 for (; nargs; nargs--, args++)
2086 Lisp_Object lisp_char = *args;
2087 CHECK_CHAR_COERCE_INT (lisp_char);
2088 p += set_charptr_emchar (p, XCHAR (lisp_char));
2090 return make_string (storage, p - storage);
2094 /* Take some raw memory, which MUST already be in internal format,
2095 and package it up into a Lisp string. */
2097 make_string (const Bufbyte *contents, Bytecount length)
2101 /* Make sure we find out about bad make_string's when they happen */
2102 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2103 bytecount_to_charcount (contents, length); /* Just for the assertions */
2106 val = make_uninit_string (length);
2107 memcpy (XSTRING_DATA (val), contents, length);
2111 /* Take some raw memory, encoded in some external data format,
2112 and convert it into a Lisp string. */
2114 make_ext_string (const Extbyte *contents, EMACS_INT length,
2115 Lisp_Object coding_system)
2118 TO_INTERNAL_FORMAT (DATA, (contents, length),
2119 LISP_STRING, string,
2125 build_string (const char *str)
2127 /* Some strlen's crash and burn if passed null. */
2128 return make_string ((const Bufbyte *) str, (str ? strlen(str) : 0));
2132 build_ext_string (const char *str, Lisp_Object coding_system)
2134 /* Some strlen's crash and burn if passed null. */
2135 return make_ext_string ((const Extbyte *) str, (str ? strlen(str) : 0),
2140 build_translated_string (const char *str)
2142 return build_string (GETTEXT (str));
2146 make_string_nocopy (const Bufbyte *contents, Bytecount length)
2151 /* Make sure we find out about bad make_string_nocopy's when they happen */
2152 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2153 bytecount_to_charcount (contents, length); /* Just for the assertions */
2156 /* Allocate the string header */
2157 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2158 set_lheader_implementation (&s->lheader, &lrecord_string);
2159 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2161 set_string_data (s, (Bufbyte *)contents);
2162 set_string_length (s, length);
2164 XSETSTRING (val, s);
2169 /************************************************************************/
2170 /* lcrecord lists */
2171 /************************************************************************/
2173 /* Lcrecord lists are used to manage the allocation of particular
2174 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2175 malloc() and garbage-collection junk) as much as possible.
2176 It is similar to the Blocktype class.
2180 1) Create an lcrecord-list object using make_lcrecord_list().
2181 This is often done at initialization. Remember to staticpro_nodump
2182 this object! The arguments to make_lcrecord_list() are the
2183 same as would be passed to alloc_lcrecord().
2184 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2185 and pass the lcrecord-list earlier created.
2186 3) When done with the lcrecord, call free_managed_lcrecord().
2187 The standard freeing caveats apply: ** make sure there are no
2188 pointers to the object anywhere! **
2189 4) Calling free_managed_lcrecord() is just like kissing the
2190 lcrecord goodbye as if it were garbage-collected. This means:
2191 -- the contents of the freed lcrecord are undefined, and the
2192 contents of something produced by allocate_managed_lcrecord()
2193 are undefined, just like for alloc_lcrecord().
2194 -- the mark method for the lcrecord's type will *NEVER* be called
2196 -- the finalize method for the lcrecord's type will be called
2197 at the time that free_managed_lcrecord() is called.
2202 mark_lcrecord_list (Lisp_Object obj)
2204 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2205 Lisp_Object chain = list->free;
2207 while (!NILP (chain))
2209 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2210 struct free_lcrecord_header *free_header =
2211 (struct free_lcrecord_header *) lheader;
2214 (/* There should be no other pointers to the free list. */
2215 ! MARKED_RECORD_HEADER_P (lheader)
2217 /* Only lcrecords should be here. */
2218 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
2220 /* Only free lcrecords should be here. */
2221 free_header->lcheader.free
2223 /* The type of the lcrecord must be right. */
2224 LHEADER_IMPLEMENTATION (lheader) == list->implementation
2226 /* So must the size. */
2227 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2228 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
2231 MARK_RECORD_HEADER (lheader);
2232 chain = free_header->chain;
2238 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2239 mark_lcrecord_list, internal_object_printer,
2240 0, 0, 0, 0, struct lcrecord_list);
2242 make_lcrecord_list (size_t size,
2243 const struct lrecord_implementation *implementation)
2245 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2246 &lrecord_lcrecord_list);
2249 p->implementation = implementation;
2252 XSETLCRECORD_LIST (val, p);
2257 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2259 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2260 if (!NILP (list->free))
2262 Lisp_Object val = list->free;
2263 struct free_lcrecord_header *free_header =
2264 (struct free_lcrecord_header *) XPNTR (val);
2266 #ifdef ERROR_CHECK_GC
2267 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2269 /* There should be no other pointers to the free list. */
2270 assert (! MARKED_RECORD_HEADER_P (lheader));
2271 /* Only lcrecords should be here. */
2272 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
2273 /* Only free lcrecords should be here. */
2274 assert (free_header->lcheader.free);
2275 /* The type of the lcrecord must be right. */
2276 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
2277 /* So must the size. */
2278 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2279 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
2280 #endif /* ERROR_CHECK_GC */
2282 list->free = free_header->chain;
2283 free_header->lcheader.free = 0;
2290 XSETOBJ (val, alloc_lcrecord (list->size, list->implementation));
2296 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2298 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2299 struct free_lcrecord_header *free_header =
2300 (struct free_lcrecord_header *) XPNTR (lcrecord);
2301 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2302 const struct lrecord_implementation *implementation
2303 = LHEADER_IMPLEMENTATION (lheader);
2305 /* Make sure the size is correct. This will catch, for example,
2306 putting a window configuration on the wrong free list. */
2307 gc_checking_assert ((implementation->size_in_bytes_method ?
2308 implementation->size_in_bytes_method (lheader) :
2309 implementation->static_size)
2312 if (implementation->finalizer)
2313 implementation->finalizer (lheader, 0);
2314 free_header->chain = list->free;
2315 free_header->lcheader.free = 1;
2316 list->free = lcrecord;
2322 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2323 Kept for compatibility, returns its argument.
2325 Make a copy of OBJECT in pure storage.
2326 Recursively copies contents of vectors and cons cells.
2327 Does not copy symbols.
2335 /************************************************************************/
2336 /* Garbage Collection */
2337 /************************************************************************/
2339 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
2340 Additional ones may be defined by a module (none yet). We leave some
2341 room in `lrecord_implementations_table' for such new lisp object types. */
2342 const struct lrecord_implementation *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT];
2343 unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
2344 /* Object marker functions are in the lrecord_implementation structure.
2345 But copying them to a parallel array is much more cache-friendly.
2346 This hack speeds up (garbage-collect) by about 5%. */
2347 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
2349 struct gcpro *gcprolist;
2351 /* We want the staticpros relocated, but not the pointers found therein.
2352 Hence we use a trivial description, as for pointerless objects. */
2353 static const struct lrecord_description staticpro_description_1[] = {
2357 static const struct struct_description staticpro_description = {
2358 sizeof (Lisp_Object *),
2359 staticpro_description_1
2362 static const struct lrecord_description staticpros_description_1[] = {
2363 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description),
2367 static const struct struct_description staticpros_description = {
2368 sizeof (Lisp_Object_ptr_dynarr),
2369 staticpros_description_1
2372 Lisp_Object_ptr_dynarr *staticpros;
2374 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
2375 garbage collection, and for dumping. */
2377 staticpro (Lisp_Object *varaddress)
2379 Dynarr_add (staticpros, varaddress);
2380 dump_add_root_object (varaddress);
2384 Lisp_Object_ptr_dynarr *staticpros_nodump;
2386 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
2387 garbage collection, but not for dumping. */
2389 staticpro_nodump (Lisp_Object *varaddress)
2391 Dynarr_add (staticpros_nodump, varaddress);
2394 #ifdef ERROR_CHECK_GC
2395 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
2396 struct lrecord_header * GCLI_lh = (lheader); \
2397 assert (GCLI_lh != 0); \
2398 assert (GCLI_lh->type < lrecord_type_count); \
2399 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
2400 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
2401 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
2404 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
2408 /* Mark reference to a Lisp_Object. If the object referred to has not been
2409 seen yet, recursively mark all the references contained in it. */
2412 mark_object (Lisp_Object obj)
2416 /* Checks we used to perform */
2417 /* if (EQ (obj, Qnull_pointer)) return; */
2418 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2419 /* if (PURIFIED (XPNTR (obj))) return; */
2421 if (XTYPE (obj) == Lisp_Type_Record)
2423 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2425 GC_CHECK_LHEADER_INVARIANTS (lheader);
2427 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
2428 ! ((struct lcrecord_header *) lheader)->free);
2430 /* All c_readonly objects have their mark bit set,
2431 so that we only need to check the mark bit here. */
2432 if (! MARKED_RECORD_HEADER_P (lheader))
2434 MARK_RECORD_HEADER (lheader);
2436 if (RECORD_MARKER (lheader))
2438 obj = RECORD_MARKER (lheader) (obj);
2439 if (!NILP (obj)) goto tail_recurse;
2445 /* mark all of the conses in a list and mark the final cdr; but
2446 DO NOT mark the cars.
2448 Use only for internal lists! There should never be other pointers
2449 to the cons cells, because if so, the cars will remain unmarked
2450 even when they maybe should be marked. */
2452 mark_conses_in_list (Lisp_Object obj)
2456 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2458 if (CONS_MARKED_P (XCONS (rest)))
2460 MARK_CONS (XCONS (rest));
2467 /* Find all structures not marked, and free them. */
2469 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2470 static int gc_count_bit_vector_storage;
2471 static int gc_count_num_short_string_in_use;
2472 static int gc_count_string_total_size;
2473 static int gc_count_short_string_total_size;
2475 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2478 /* stats on lcrecords in use - kinda kludgy */
2482 int instances_in_use;
2484 int instances_freed;
2486 int instances_on_free_list;
2487 } lcrecord_stats [countof (lrecord_implementations_table)];
2490 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
2492 unsigned int type_index = h->type;
2494 if (((struct lcrecord_header *) h)->free)
2496 gc_checking_assert (!free_p);
2497 lcrecord_stats[type_index].instances_on_free_list++;
2501 const struct lrecord_implementation *implementation =
2502 LHEADER_IMPLEMENTATION (h);
2504 size_t sz = (implementation->size_in_bytes_method ?
2505 implementation->size_in_bytes_method (h) :
2506 implementation->static_size);
2509 lcrecord_stats[type_index].instances_freed++;
2510 lcrecord_stats[type_index].bytes_freed += sz;
2514 lcrecord_stats[type_index].instances_in_use++;
2515 lcrecord_stats[type_index].bytes_in_use += sz;
2521 /* Free all unmarked records */
2523 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2525 struct lcrecord_header *header;
2527 /* int total_size = 0; */
2529 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2531 /* First go through and call all the finalize methods.
2532 Then go through and free the objects. There used to
2533 be only one loop here, with the call to the finalizer
2534 occurring directly before the xfree() below. That
2535 is marginally faster but much less safe -- if the
2536 finalize method for an object needs to reference any
2537 other objects contained within it (and many do),
2538 we could easily be screwed by having already freed that
2541 for (header = *prev; header; header = header->next)
2543 struct lrecord_header *h = &(header->lheader);
2545 GC_CHECK_LHEADER_INVARIANTS (h);
2547 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
2549 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2550 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2554 for (header = *prev; header; )
2556 struct lrecord_header *h = &(header->lheader);
2557 if (MARKED_RECORD_HEADER_P (h))
2559 if (! C_READONLY_RECORD_HEADER_P (h))
2560 UNMARK_RECORD_HEADER (h);
2562 /* total_size += n->implementation->size_in_bytes (h);*/
2563 /* #### May modify header->next on a C_READONLY lcrecord */
2564 prev = &(header->next);
2566 tick_lcrecord_stats (h, 0);
2570 struct lcrecord_header *next = header->next;
2572 tick_lcrecord_stats (h, 1);
2573 /* used to call finalizer right here. */
2579 /* *total = total_size; */
2584 sweep_bit_vectors_1 (Lisp_Object *prev,
2585 int *used, int *total, int *storage)
2587 Lisp_Object bit_vector;
2590 int total_storage = 0;
2592 /* BIT_VECTORP fails because the objects are marked, which changes
2593 their implementation */
2594 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2596 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2598 if (MARKED_RECORD_P (bit_vector))
2600 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
2601 UNMARK_RECORD_HEADER (&(v->lheader));
2605 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2606 BIT_VECTOR_LONG_STORAGE (len));
2608 /* #### May modify next on a C_READONLY bitvector */
2609 prev = &(bit_vector_next (v));
2614 Lisp_Object next = bit_vector_next (v);
2621 *total = total_size;
2622 *storage = total_storage;
2625 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2626 to make macros prettier. */
2628 #ifdef ERROR_CHECK_GC
2630 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2632 struct typename##_block *SFTB_current; \
2634 int num_free = 0, num_used = 0; \
2636 for (SFTB_current = current_##typename##_block, \
2637 SFTB_limit = current_##typename##_block_index; \
2643 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2645 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2647 if (FREE_STRUCT_P (SFTB_victim)) \
2651 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2655 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2658 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2663 UNMARK_##typename (SFTB_victim); \
2666 SFTB_current = SFTB_current->prev; \
2667 SFTB_limit = countof (current_##typename##_block->block); \
2670 gc_count_num_##typename##_in_use = num_used; \
2671 gc_count_num_##typename##_freelist = num_free; \
2674 #else /* !ERROR_CHECK_GC */
2676 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2678 struct typename##_block *SFTB_current; \
2679 struct typename##_block **SFTB_prev; \
2681 int num_free = 0, num_used = 0; \
2683 typename##_free_list = 0; \
2685 for (SFTB_prev = ¤t_##typename##_block, \
2686 SFTB_current = current_##typename##_block, \
2687 SFTB_limit = current_##typename##_block_index; \
2692 int SFTB_empty = 1; \
2693 obj_type *SFTB_old_free_list = typename##_free_list; \
2695 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2697 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2699 if (FREE_STRUCT_P (SFTB_victim)) \
2702 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2704 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2709 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2712 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2718 UNMARK_##typename (SFTB_victim); \
2723 SFTB_prev = &(SFTB_current->prev); \
2724 SFTB_current = SFTB_current->prev; \
2726 else if (SFTB_current == current_##typename##_block \
2727 && !SFTB_current->prev) \
2729 /* No real point in freeing sole allocation block */ \
2734 struct typename##_block *SFTB_victim_block = SFTB_current; \
2735 if (SFTB_victim_block == current_##typename##_block) \
2736 current_##typename##_block_index \
2737 = countof (current_##typename##_block->block); \
2738 SFTB_current = SFTB_current->prev; \
2740 *SFTB_prev = SFTB_current; \
2741 xfree (SFTB_victim_block); \
2742 /* Restore free list to what it was before victim was swept */ \
2743 typename##_free_list = SFTB_old_free_list; \
2744 num_free -= SFTB_limit; \
2747 SFTB_limit = countof (current_##typename##_block->block); \
2750 gc_count_num_##typename##_in_use = num_used; \
2751 gc_count_num_##typename##_freelist = num_free; \
2754 #endif /* !ERROR_CHECK_GC */
2762 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2763 #define ADDITIONAL_FREE_cons(ptr)
2765 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2768 /* Explicitly free a cons cell. */
2770 free_cons (Lisp_Cons *ptr)
2772 #ifdef ERROR_CHECK_GC
2773 /* If the CAR is not an int, then it will be a pointer, which will
2774 always be four-byte aligned. If this cons cell has already been
2775 placed on the free list, however, its car will probably contain
2776 a chain pointer to the next cons on the list, which has cleverly
2777 had all its 0's and 1's inverted. This allows for a quick
2778 check to make sure we're not freeing something already freed. */
2779 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2780 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2781 #endif /* ERROR_CHECK_GC */
2783 #ifndef ALLOC_NO_POOLS
2784 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2785 #endif /* ALLOC_NO_POOLS */
2788 /* explicitly free a list. You **must make sure** that you have
2789 created all the cons cells that make up this list and that there
2790 are no pointers to any of these cons cells anywhere else. If there
2791 are, you will lose. */
2794 free_list (Lisp_Object list)
2796 Lisp_Object rest, next;
2798 for (rest = list; !NILP (rest); rest = next)
2801 free_cons (XCONS (rest));
2805 /* explicitly free an alist. You **must make sure** that you have
2806 created all the cons cells that make up this alist and that there
2807 are no pointers to any of these cons cells anywhere else. If there
2808 are, you will lose. */
2811 free_alist (Lisp_Object alist)
2813 Lisp_Object rest, next;
2815 for (rest = alist; !NILP (rest); rest = next)
2818 free_cons (XCONS (XCAR (rest)));
2819 free_cons (XCONS (rest));
2824 sweep_compiled_functions (void)
2826 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2827 #define ADDITIONAL_FREE_compiled_function(ptr)
2829 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2833 #ifdef LISP_FLOAT_TYPE
2837 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2838 #define ADDITIONAL_FREE_float(ptr)
2840 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
2842 #endif /* LISP_FLOAT_TYPE */
2845 sweep_symbols (void)
2847 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2848 #define ADDITIONAL_FREE_symbol(ptr)
2850 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
2854 sweep_extents (void)
2856 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2857 #define ADDITIONAL_FREE_extent(ptr)
2859 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2865 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2866 #define ADDITIONAL_FREE_event(ptr)
2868 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
2872 sweep_markers (void)
2874 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2875 #define ADDITIONAL_FREE_marker(ptr) \
2876 do { Lisp_Object tem; \
2877 XSETMARKER (tem, ptr); \
2878 unchain_marker (tem); \
2881 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
2884 /* Explicitly free a marker. */
2886 free_marker (Lisp_Marker *ptr)
2888 /* Perhaps this will catch freeing an already-freed marker. */
2889 gc_checking_assert (ptr->lheader.type == lrecord_type_marker);
2891 #ifndef ALLOC_NO_POOLS
2892 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
2893 #endif /* ALLOC_NO_POOLS */
2897 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2900 verify_string_chars_integrity (void)
2902 struct string_chars_block *sb;
2904 /* Scan each existing string block sequentially, string by string. */
2905 for (sb = first_string_chars_block; sb; sb = sb->next)
2908 /* POS is the index of the next string in the block. */
2909 while (pos < sb->pos)
2911 struct string_chars *s_chars =
2912 (struct string_chars *) &(sb->string_chars[pos]);
2913 Lisp_String *string;
2917 /* If the string_chars struct is marked as free (i.e. the STRING
2918 pointer is 0xFFFFFFFF) then this is an unused chunk of string
2919 storage. (See below.) */
2921 if (FREE_STRUCT_P (s_chars))
2923 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
2928 string = s_chars->string;
2929 /* Must be 32-bit aligned. */
2930 assert ((((int) string) & 3) == 0);
2932 size = string_length (string);
2933 fullsize = STRING_FULLSIZE (size);
2935 assert (!BIG_STRING_FULLSIZE_P (fullsize));
2936 assert (string_data (string) == s_chars->chars);
2939 assert (pos == sb->pos);
2943 #endif /* MULE && ERROR_CHECK_GC */
2945 /* Compactify string chars, relocating the reference to each --
2946 free any empty string_chars_block we see. */
2948 compact_string_chars (void)
2950 struct string_chars_block *to_sb = first_string_chars_block;
2952 struct string_chars_block *from_sb;
2954 /* Scan each existing string block sequentially, string by string. */
2955 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
2958 /* FROM_POS is the index of the next string in the block. */
2959 while (from_pos < from_sb->pos)
2961 struct string_chars *from_s_chars =
2962 (struct string_chars *) &(from_sb->string_chars[from_pos]);
2963 struct string_chars *to_s_chars;
2964 Lisp_String *string;
2968 /* If the string_chars struct is marked as free (i.e. the STRING
2969 pointer is 0xFFFFFFFF) then this is an unused chunk of string
2970 storage. This happens under Mule when a string's size changes
2971 in such a way that its fullsize changes. (Strings can change
2972 size because a different-length character can be substituted
2973 for another character.) In this case, after the bogus string
2974 pointer is the "fullsize" of this entry, i.e. how many bytes
2977 if (FREE_STRUCT_P (from_s_chars))
2979 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
2980 from_pos += fullsize;
2984 string = from_s_chars->string;
2985 assert (!(FREE_STRUCT_P (string)));
2987 size = string_length (string);
2988 fullsize = STRING_FULLSIZE (size);
2990 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
2992 /* Just skip it if it isn't marked. */
2993 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
2995 from_pos += fullsize;
2999 /* If it won't fit in what's left of TO_SB, close TO_SB out
3000 and go on to the next string_chars_block. We know that TO_SB
3001 cannot advance past FROM_SB here since FROM_SB is large enough
3002 to currently contain this string. */
3003 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3005 to_sb->pos = to_pos;
3006 to_sb = to_sb->next;
3010 /* Compute new address of this string
3011 and update TO_POS for the space being used. */
3012 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3014 /* Copy the string_chars to the new place. */
3015 if (from_s_chars != to_s_chars)
3016 memmove (to_s_chars, from_s_chars, fullsize);
3018 /* Relocate FROM_S_CHARS's reference */
3019 set_string_data (string, &(to_s_chars->chars[0]));
3021 from_pos += fullsize;
3026 /* Set current to the last string chars block still used and
3027 free any that follow. */
3029 struct string_chars_block *victim;
3031 for (victim = to_sb->next; victim; )
3033 struct string_chars_block *next = victim->next;
3038 current_string_chars_block = to_sb;
3039 current_string_chars_block->pos = to_pos;
3040 current_string_chars_block->next = 0;
3044 #if 1 /* Hack to debug missing purecopy's */
3045 static int debug_string_purity;
3048 debug_string_purity_print (Lisp_String *p)
3051 Charcount s = string_char_length (p);
3053 for (i = 0; i < s; i++)
3055 Emchar ch = string_char (p, i);
3056 if (ch < 32 || ch >= 126)
3057 stderr_out ("\\%03o", ch);
3058 else if (ch == '\\' || ch == '\"')
3059 stderr_out ("\\%c", ch);
3061 stderr_out ("%c", ch);
3063 stderr_out ("\"\n");
3069 sweep_strings (void)
3071 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3072 int debug = debug_string_purity;
3074 #define UNMARK_string(ptr) do { \
3075 Lisp_String *p = (ptr); \
3076 size_t size = string_length (p); \
3077 UNMARK_RECORD_HEADER (&(p->lheader)); \
3078 num_bytes += size; \
3079 if (!BIG_STRING_SIZE_P (size)) \
3081 num_small_bytes += size; \
3085 debug_string_purity_print (p); \
3087 #define ADDITIONAL_FREE_string(ptr) do { \
3088 size_t size = string_length (ptr); \
3089 if (BIG_STRING_SIZE_P (size)) \
3090 xfree (ptr->data); \
3093 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3095 gc_count_num_short_string_in_use = num_small_used;
3096 gc_count_string_total_size = num_bytes;
3097 gc_count_short_string_total_size = num_small_bytes;
3101 /* I hate duplicating all this crap! */
3103 marked_p (Lisp_Object obj)
3105 /* Checks we used to perform. */
3106 /* if (EQ (obj, Qnull_pointer)) return 1; */
3107 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3108 /* if (PURIFIED (XPNTR (obj))) return 1; */
3110 if (XTYPE (obj) == Lisp_Type_Record)
3112 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3114 GC_CHECK_LHEADER_INVARIANTS (lheader);
3116 return MARKED_RECORD_HEADER_P (lheader);
3124 /* Free all unmarked records. Do this at the very beginning,
3125 before anything else, so that the finalize methods can safely
3126 examine items in the objects. sweep_lcrecords_1() makes
3127 sure to call all the finalize methods *before* freeing anything,
3128 to complete the safety. */
3131 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3134 compact_string_chars ();
3136 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3137 macros) must be *extremely* careful to make sure they're not
3138 referencing freed objects. The only two existing finalize
3139 methods (for strings and markers) pass muster -- the string
3140 finalizer doesn't look at anything but its own specially-
3141 created block, and the marker finalizer only looks at live
3142 buffers (which will never be freed) and at the markers before
3143 and after it in the chain (which, by induction, will never be
3144 freed because if so, they would have already removed themselves
3147 /* Put all unmarked strings on free list, free'ing the string chars
3148 of large unmarked strings */
3151 /* Put all unmarked conses on free list */
3154 /* Free all unmarked bit vectors */
3155 sweep_bit_vectors_1 (&all_bit_vectors,
3156 &gc_count_num_bit_vector_used,
3157 &gc_count_bit_vector_total_size,
3158 &gc_count_bit_vector_storage);
3160 /* Free all unmarked compiled-function objects */
3161 sweep_compiled_functions ();
3163 #ifdef LISP_FLOAT_TYPE
3164 /* Put all unmarked floats on free list */
3168 /* Put all unmarked symbols on free list */
3171 /* Put all unmarked extents on free list */
3174 /* Put all unmarked markers on free list.
3175 Dechain each one first from the buffer into which it points. */
3181 pdump_objects_unmark ();
3185 /* Clearing for disksave. */
3188 disksave_object_finalization (void)
3190 /* It's important that certain information from the environment not get
3191 dumped with the executable (pathnames, environment variables, etc.).
3192 To make it easier to tell when this has happened with strings(1) we
3193 clear some known-to-be-garbage blocks of memory, so that leftover
3194 results of old evaluation don't look like potential problems.
3195 But first we set some notable variables to nil and do one more GC,
3196 to turn those strings into garbage.
3199 /* Yeah, this list is pretty ad-hoc... */
3200 Vprocess_environment = Qnil;
3201 Vexec_directory = Qnil;
3202 Vdata_directory = Qnil;
3203 Vsite_directory = Qnil;
3204 Vdoc_directory = Qnil;
3205 Vconfigure_info_directory = Qnil;
3208 /* Vdump_load_path = Qnil; */
3209 /* Release hash tables for locate_file */
3210 Flocate_file_clear_hashing (Qt);
3211 uncache_home_directory();
3213 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3214 defined(LOADHIST_BUILTIN))
3215 Vload_history = Qnil;
3217 Vshell_file_name = Qnil;
3219 garbage_collect_1 ();
3221 /* Run the disksave finalization methods of all live objects. */
3222 disksave_object_finalization_1 ();
3224 /* Zero out the uninitialized (really, unused) part of the containers
3225 for the live strings. */
3227 struct string_chars_block *scb;
3228 for (scb = first_string_chars_block; scb; scb = scb->next)
3230 int count = sizeof (scb->string_chars) - scb->pos;
3232 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3235 /* from the block's fill ptr to the end */
3236 memset ((scb->string_chars + scb->pos), 0, count);
3241 /* There, that ought to be enough... */
3247 restore_gc_inhibit (Lisp_Object val)
3249 gc_currently_forbidden = XINT (val);
3253 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3254 static int gc_hooks_inhibited;
3258 garbage_collect_1 (void)
3260 #if MAX_SAVE_STACK > 0
3261 char stack_top_variable;
3262 extern char *stack_bottom;
3267 Lisp_Object pre_gc_cursor;
3268 struct gcpro gcpro1;
3271 || gc_currently_forbidden
3273 || preparing_for_armageddon)
3276 /* We used to call selected_frame() here.
3278 The following functions cannot be called inside GC
3279 so we move to after the above tests. */
3282 Lisp_Object device = Fselected_device (Qnil);
3283 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3285 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3287 signal_simple_error ("No frames exist on device", device);
3291 pre_gc_cursor = Qnil;
3294 GCPRO1 (pre_gc_cursor);
3296 /* Very important to prevent GC during any of the following
3297 stuff that might run Lisp code; otherwise, we'll likely
3298 have infinite GC recursion. */
3299 speccount = specpdl_depth ();
3300 record_unwind_protect (restore_gc_inhibit,
3301 make_int (gc_currently_forbidden));
3302 gc_currently_forbidden = 1;
3304 if (!gc_hooks_inhibited)
3305 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3307 /* Now show the GC cursor/message. */
3308 if (!noninteractive)
3310 if (FRAME_WIN_P (f))
3312 Lisp_Object frame = make_frame (f);
3313 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3314 FRAME_SELECTED_WINDOW (f),
3316 pre_gc_cursor = f->pointer;
3317 if (POINTER_IMAGE_INSTANCEP (cursor)
3318 /* don't change if we don't know how to change back. */
3319 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3322 Fset_frame_pointer (frame, cursor);
3326 /* Don't print messages to the stream device. */
3327 if (!cursor_changed && !FRAME_STREAM_P (f))
3329 char *msg = (STRINGP (Vgc_message)
3330 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3332 Lisp_Object args[2], whole_msg;
3333 args[0] = build_string (msg ? msg :
3334 GETTEXT ((const char *) gc_default_message));
3335 args[1] = build_string ("...");
3336 whole_msg = Fconcat (2, args);
3337 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3338 Qgarbage_collecting);
3342 /***** Now we actually start the garbage collection. */
3346 gc_generation_number[0]++;
3348 #if MAX_SAVE_STACK > 0
3350 /* Save a copy of the contents of the stack, for debugging. */
3353 /* Static buffer in which we save a copy of the C stack at each GC. */
3354 static char *stack_copy;
3355 static size_t stack_copy_size;
3357 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3358 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3359 if (stack_size < MAX_SAVE_STACK)
3361 if (stack_copy_size < stack_size)
3363 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3364 stack_copy_size = stack_size;
3368 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3372 #endif /* MAX_SAVE_STACK > 0 */
3374 /* Do some totally ad-hoc resource clearing. */
3375 /* #### generalize this? */
3376 clear_event_resource ();
3377 cleanup_specifiers ();
3379 /* Mark all the special slots that serve as the roots of accessibility. */
3382 Lisp_Object **p = Dynarr_begin (staticpros);
3384 for (count = Dynarr_length (staticpros); count; count--)
3385 mark_object (**p++);
3388 { /* staticpro_nodump() */
3389 Lisp_Object **p = Dynarr_begin (staticpros_nodump);
3391 for (count = Dynarr_length (staticpros_nodump); count; count--)
3392 mark_object (**p++);
3398 for (tail = gcprolist; tail; tail = tail->next)
3399 for (i = 0; i < tail->nvars; i++)
3400 mark_object (tail->var[i]);
3404 struct specbinding *bind;
3405 for (bind = specpdl; bind != specpdl_ptr; bind++)
3407 mark_object (bind->symbol);
3408 mark_object (bind->old_value);
3413 struct catchtag *catch;
3414 for (catch = catchlist; catch; catch = catch->next)
3416 mark_object (catch->tag);
3417 mark_object (catch->val);
3422 struct backtrace *backlist;
3423 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3425 int nargs = backlist->nargs;
3428 mark_object (*backlist->function);
3429 if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */)
3430 mark_object (backlist->args[0]);
3432 for (i = 0; i < nargs; i++)
3433 mark_object (backlist->args[i]);
3438 mark_profiling_info ();
3440 /* OK, now do the after-mark stuff. This is for things that
3441 are only marked when something else is marked (e.g. weak hash tables).
3442 There may be complex dependencies between such objects -- e.g.
3443 a weak hash table might be unmarked, but after processing a later
3444 weak hash table, the former one might get marked. So we have to
3445 iterate until nothing more gets marked. */
3447 while (finish_marking_weak_hash_tables () > 0 ||
3448 finish_marking_weak_lists () > 0)
3451 /* And prune (this needs to be called after everything else has been
3452 marked and before we do any sweeping). */
3453 /* #### this is somewhat ad-hoc and should probably be an object
3455 prune_weak_hash_tables ();
3456 prune_weak_lists ();
3457 prune_specifiers ();
3458 prune_syntax_tables ();
3462 consing_since_gc = 0;
3463 #ifndef DEBUG_XEMACS
3464 /* Allow you to set it really fucking low if you really want ... */
3465 if (gc_cons_threshold < 10000)
3466 gc_cons_threshold = 10000;
3471 /******* End of garbage collection ********/
3473 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3475 /* Now remove the GC cursor/message */
3476 if (!noninteractive)
3479 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3480 else if (!FRAME_STREAM_P (f))
3482 char *msg = (STRINGP (Vgc_message)
3483 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3486 /* Show "...done" only if the echo area would otherwise be empty. */
3487 if (NILP (clear_echo_area (selected_frame (),
3488 Qgarbage_collecting, 0)))
3490 Lisp_Object args[2], whole_msg;
3491 args[0] = build_string (msg ? msg :
3492 GETTEXT ((const char *)
3493 gc_default_message));
3494 args[1] = build_string ("... done");
3495 whole_msg = Fconcat (2, args);
3496 echo_area_message (selected_frame (), (Bufbyte *) 0,
3498 Qgarbage_collecting);
3503 /* now stop inhibiting GC */
3504 unbind_to (speccount, Qnil);
3506 if (!breathing_space)
3508 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3515 /* Debugging aids. */
3518 gc_plist_hack (const char *name, int value, Lisp_Object tail)
3520 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3521 or portable numeric datatypes, or bit-vectors, or characters, or
3522 arrays, or exceptions, or ...) */
3523 return cons3 (intern (name), make_int (value), tail);
3526 #define HACK_O_MATIC(type, name, pl) do { \
3528 struct type##_block *x = current_##type##_block; \
3529 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3530 (pl) = gc_plist_hack ((name), s, (pl)); \
3533 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3534 Reclaim storage for Lisp objects no longer needed.
3535 Return info on amount of space in use:
3536 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3537 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3539 where `PLIST' is a list of alternating keyword/value pairs providing
3540 more detailed information.
3541 Garbage collection happens automatically if you cons more than
3542 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3546 Lisp_Object pl = Qnil;
3548 int gc_count_vector_total_size = 0;
3550 garbage_collect_1 ();
3552 for (i = 0; i < lrecord_type_count; i++)
3554 if (lcrecord_stats[i].bytes_in_use != 0
3555 || lcrecord_stats[i].bytes_freed != 0
3556 || lcrecord_stats[i].instances_on_free_list != 0)
3559 const char *name = lrecord_implementations_table[i]->name;
3560 int len = strlen (name);
3561 /* save this for the FSFmacs-compatible part of the summary */
3562 if (i == lrecord_vector.lrecord_type_index)
3563 gc_count_vector_total_size =
3564 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3566 sprintf (buf, "%s-storage", name);
3567 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3568 /* Okay, simple pluralization check for `symbol-value-varalias' */
3569 if (name[len-1] == 's')
3570 sprintf (buf, "%ses-freed", name);
3572 sprintf (buf, "%ss-freed", name);
3573 if (lcrecord_stats[i].instances_freed != 0)
3574 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3575 if (name[len-1] == 's')
3576 sprintf (buf, "%ses-on-free-list", name);
3578 sprintf (buf, "%ss-on-free-list", name);
3579 if (lcrecord_stats[i].instances_on_free_list != 0)
3580 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3582 if (name[len-1] == 's')
3583 sprintf (buf, "%ses-used", name);
3585 sprintf (buf, "%ss-used", name);
3586 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3590 HACK_O_MATIC (extent, "extent-storage", pl);
3591 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3592 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3593 HACK_O_MATIC (event, "event-storage", pl);
3594 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3595 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3596 HACK_O_MATIC (marker, "marker-storage", pl);
3597 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3598 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3599 #ifdef LISP_FLOAT_TYPE
3600 HACK_O_MATIC (float, "float-storage", pl);
3601 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3602 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3603 #endif /* LISP_FLOAT_TYPE */
3604 HACK_O_MATIC (string, "string-header-storage", pl);
3605 pl = gc_plist_hack ("long-strings-total-length",
3606 gc_count_string_total_size
3607 - gc_count_short_string_total_size, pl);
3608 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3609 pl = gc_plist_hack ("short-strings-total-length",
3610 gc_count_short_string_total_size, pl);
3611 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3612 pl = gc_plist_hack ("long-strings-used",
3613 gc_count_num_string_in_use
3614 - gc_count_num_short_string_in_use, pl);
3615 pl = gc_plist_hack ("short-strings-used",
3616 gc_count_num_short_string_in_use, pl);
3618 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3619 pl = gc_plist_hack ("compiled-functions-free",
3620 gc_count_num_compiled_function_freelist, pl);
3621 pl = gc_plist_hack ("compiled-functions-used",
3622 gc_count_num_compiled_function_in_use, pl);
3624 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3625 pl = gc_plist_hack ("bit-vectors-total-length",
3626 gc_count_bit_vector_total_size, pl);
3627 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3629 HACK_O_MATIC (symbol, "symbol-storage", pl);
3630 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3631 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3633 HACK_O_MATIC (cons, "cons-storage", pl);
3634 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3635 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3637 /* The things we do for backwards-compatibility */
3639 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3640 make_int (gc_count_num_cons_freelist)),
3641 Fcons (make_int (gc_count_num_symbol_in_use),
3642 make_int (gc_count_num_symbol_freelist)),
3643 Fcons (make_int (gc_count_num_marker_in_use),
3644 make_int (gc_count_num_marker_freelist)),
3645 make_int (gc_count_string_total_size),
3646 make_int (gc_count_vector_total_size),
3651 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3652 Return the number of bytes consed since the last garbage collection.
3653 \"Consed\" is a misnomer in that this actually counts allocation
3654 of all different kinds of objects, not just conses.
3656 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3660 return make_int (consing_since_gc);
3664 DEFUN ("memory-limit", Fmemory_limit, 0, 0, 0, /*
3665 Return the address of the last byte Emacs has allocated, divided by 1024.
3666 This may be helpful in debugging Emacs's memory usage.
3667 The value is divided by 1024 to make sure it will fit in a lisp integer.
3671 return make_int ((EMACS_INT) sbrk (0) / 1024);
3677 object_dead_p (Lisp_Object obj)
3679 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3680 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3681 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3682 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3683 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3684 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3685 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3688 #ifdef MEMORY_USAGE_STATS
3690 /* Attempt to determine the actual amount of space that is used for
3691 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3693 It seems that the following holds:
3695 1. When using the old allocator (malloc.c):
3697 -- blocks are always allocated in chunks of powers of two. For
3698 each block, there is an overhead of 8 bytes if rcheck is not
3699 defined, 20 bytes if it is defined. In other words, a
3700 one-byte allocation needs 8 bytes of overhead for a total of
3701 9 bytes, and needs to have 16 bytes of memory chunked out for
3704 2. When using the new allocator (gmalloc.c):
3706 -- blocks are always allocated in chunks of powers of two up
3707 to 4096 bytes. Larger blocks are allocated in chunks of
3708 an integral multiple of 4096 bytes. The minimum block
3709 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3710 is defined. There is no per-block overhead, but there
3711 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3714 3. When using the system malloc, anything goes, but they are
3715 generally slower and more space-efficient than the GNU
3716 allocators. One possibly reasonable assumption to make
3717 for want of better data is that sizeof (void *), or maybe
3718 2 * sizeof (void *), is required as overhead and that
3719 blocks are allocated in the minimum required size except
3720 that some minimum block size is imposed (e.g. 16 bytes). */
3723 malloced_storage_size (void *ptr, size_t claimed_size,
3724 struct overhead_stats *stats)
3726 size_t orig_claimed_size = claimed_size;
3730 if (claimed_size < 2 * sizeof (void *))
3731 claimed_size = 2 * sizeof (void *);
3732 # ifdef SUNOS_LOCALTIME_BUG
3733 if (claimed_size < 16)
3736 if (claimed_size < 4096)
3740 /* compute the log base two, more or less, then use it to compute
3741 the block size needed. */
3743 /* It's big, it's heavy, it's wood! */
3744 while ((claimed_size /= 2) != 0)
3747 /* It's better than bad, it's good! */
3753 /* We have to come up with some average about the amount of
3755 if ((size_t) (rand () & 4095) < claimed_size)
3756 claimed_size += 3 * sizeof (void *);
3760 claimed_size += 4095;
3761 claimed_size &= ~4095;
3762 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3765 #elif defined (SYSTEM_MALLOC)
3767 if (claimed_size < 16)
3769 claimed_size += 2 * sizeof (void *);
3771 #else /* old GNU allocator */
3773 # ifdef rcheck /* #### may not be defined here */
3781 /* compute the log base two, more or less, then use it to compute
3782 the block size needed. */
3784 /* It's big, it's heavy, it's wood! */
3785 while ((claimed_size /= 2) != 0)
3788 /* It's better than bad, it's good! */
3796 #endif /* old GNU allocator */
3800 stats->was_requested += orig_claimed_size;
3801 stats->malloc_overhead += claimed_size - orig_claimed_size;
3803 return claimed_size;
3807 fixed_type_block_overhead (size_t size)
3809 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3810 size_t overhead = 0;
3811 size_t storage_size = malloced_storage_size (0, per_block, 0);
3812 while (size >= per_block)
3815 overhead += sizeof (void *) + per_block - storage_size;
3817 if (rand () % per_block < size)
3818 overhead += sizeof (void *) + per_block - storage_size;
3822 #endif /* MEMORY_USAGE_STATS */
3825 /* Initialization */
3827 reinit_alloc_once_early (void)
3829 gc_generation_number[0] = 0;
3830 breathing_space = 0;
3831 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3832 XSETINT (Vgc_message, 0);
3834 ignore_malloc_warnings = 1;
3835 #ifdef DOUG_LEA_MALLOC
3836 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3837 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3838 #if 0 /* Moved to emacs.c */
3839 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3842 init_string_alloc ();
3843 init_string_chars_alloc ();
3845 init_symbol_alloc ();
3846 init_compiled_function_alloc ();
3847 #ifdef LISP_FLOAT_TYPE
3848 init_float_alloc ();
3849 #endif /* LISP_FLOAT_TYPE */
3850 init_marker_alloc ();
3851 init_extent_alloc ();
3852 init_event_alloc ();
3854 ignore_malloc_warnings = 0;
3856 if (staticpros_nodump)
3857 Dynarr_free (staticpros_nodump);
3858 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3859 Dynarr_resize (staticpros_nodump, 100); /* merely a small optimization */
3861 consing_since_gc = 0;
3863 gc_cons_threshold = 500000; /* XEmacs change */
3865 gc_cons_threshold = 15000; /* debugging */
3867 lrecord_uid_counter = 259;
3868 debug_string_purity = 0;
3871 gc_currently_forbidden = 0;
3872 gc_hooks_inhibited = 0;
3874 #ifdef ERROR_CHECK_TYPECHECK
3875 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3878 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3880 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3882 #endif /* ERROR_CHECK_TYPECHECK */
3886 init_alloc_once_early (void)
3888 reinit_alloc_once_early ();
3892 for (i = 0; i < countof (lrecord_implementations_table); i++)
3893 lrecord_implementations_table[i] = 0;
3896 INIT_LRECORD_IMPLEMENTATION (cons);
3897 INIT_LRECORD_IMPLEMENTATION (vector);
3898 INIT_LRECORD_IMPLEMENTATION (string);
3899 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
3901 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3902 Dynarr_resize (staticpros, 1410); /* merely a small optimization */
3903 dump_add_root_struct_ptr (&staticpros, &staticpros_description);
3913 syms_of_alloc (void)
3915 DEFSYMBOL (Qpre_gc_hook);
3916 DEFSYMBOL (Qpost_gc_hook);
3917 DEFSYMBOL (Qgarbage_collecting);
3922 DEFSUBR (Fbit_vector);
3923 DEFSUBR (Fmake_byte_code);
3924 DEFSUBR (Fmake_list);
3925 DEFSUBR (Fmake_vector);
3926 DEFSUBR (Fmake_bit_vector);
3927 DEFSUBR (Fmake_string);
3929 DEFSUBR (Fmake_symbol);
3930 DEFSUBR (Fmake_marker);
3931 DEFSUBR (Fpurecopy);
3932 DEFSUBR (Fgarbage_collect);
3934 DEFSUBR (Fmemory_limit);
3936 DEFSUBR (Fconsing_since_gc);
3940 vars_of_alloc (void)
3942 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
3943 *Number of bytes of consing between garbage collections.
3944 \"Consing\" is a misnomer in that this actually counts allocation
3945 of all different kinds of objects, not just conses.
3946 Garbage collection can happen automatically once this many bytes have been
3947 allocated since the last garbage collection. All data types count.
3949 Garbage collection happens automatically when `eval' or `funcall' are
3950 called. (Note that `funcall' is called implicitly as part of evaluation.)
3951 By binding this temporarily to a large number, you can effectively
3952 prevent garbage collection during a part of the program.
3954 See also `consing-since-gc'.
3958 DEFVAR_INT ("debug-allocation", &debug_allocation /*
3959 If non-zero, print out information to stderr about all objects allocated.
3960 See also `debug-allocation-backtrace-length'.
3962 debug_allocation = 0;
3964 DEFVAR_INT ("debug-allocation-backtrace-length",
3965 &debug_allocation_backtrace_length /*
3966 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
3968 debug_allocation_backtrace_length = 2;
3971 DEFVAR_BOOL ("purify-flag", &purify_flag /*
3972 Non-nil means loading Lisp code in order to dump an executable.
3973 This means that certain objects should be allocated in readonly space.
3976 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
3977 Function or functions to be run just before each garbage collection.
3978 Interrupts, garbage collection, and errors are inhibited while this hook
3979 runs, so be extremely careful in what you add here. In particular, avoid
3980 consing, and do not interact with the user.
3982 Vpre_gc_hook = Qnil;
3984 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
3985 Function or functions to be run just after each garbage collection.
3986 Interrupts, garbage collection, and errors are inhibited while this hook
3987 runs, so be extremely careful in what you add here. In particular, avoid
3988 consing, and do not interact with the user.
3990 Vpost_gc_hook = Qnil;
3992 DEFVAR_LISP ("gc-message", &Vgc_message /*
3993 String to print to indicate that a garbage collection is in progress.
3994 This is printed in the echo area. If the selected frame is on a
3995 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
3996 image instance) in the domain of the selected frame, the mouse pointer
3997 will change instead of this message being printed.
3999 Vgc_message = build_string (gc_default_message);
4001 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4002 Pointer glyph used to indicate that a garbage collection is in progress.
4003 If the selected window is on a window system and this glyph specifies a
4004 value (i.e. a pointer image instance) in the domain of the selected
4005 window, the pointer will be changed as specified during garbage collection.
4006 Otherwise, a message will be printed in the echo area, as controlled
4012 complex_vars_of_alloc (void)
4014 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);