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 Fixnum debug_allocation;
89 static Fixnum 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 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
451 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
453 #ifdef USE_UNION_TYPE
454 unsigned char dbg_USE_UNION_TYPE = 1;
456 unsigned char dbg_USE_UNION_TYPE = 0;
459 unsigned char dbg_valbits = VALBITS;
460 unsigned char dbg_gctypebits = GCTYPEBITS;
462 /* On some systems, the above definitions will be optimized away by
463 the compiler or linker unless they are referenced in some function. */
464 long dbg_inhibit_dbg_symbol_deletion (void);
466 dbg_inhibit_dbg_symbol_deletion (void)
476 /* Macros turned into functions for ease of debugging.
477 Debuggers don't know about macros! */
478 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
480 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
482 return EQ (obj1, obj2);
486 /************************************************************************/
487 /* Fixed-size type macros */
488 /************************************************************************/
490 /* For fixed-size types that are commonly used, we malloc() large blocks
491 of memory at a time and subdivide them into chunks of the correct
492 size for an object of that type. This is more efficient than
493 malloc()ing each object separately because we save on malloc() time
494 and overhead due to the fewer number of malloc()ed blocks, and
495 also because we don't need any extra pointers within each object
496 to keep them threaded together for GC purposes. For less common
497 (and frequently large-size) types, we use lcrecords, which are
498 malloc()ed individually and chained together through a pointer
499 in the lcrecord header. lcrecords do not need to be fixed-size
500 (i.e. two objects of the same type need not have the same size;
501 however, the size of a particular object cannot vary dynamically).
502 It is also much easier to create a new lcrecord type because no
503 additional code needs to be added to alloc.c. Finally, lcrecords
504 may be more efficient when there are only a small number of them.
506 The types that are stored in these large blocks (or "frob blocks")
507 are cons, float, compiled-function, symbol, marker, extent, event,
510 Note that strings are special in that they are actually stored in
511 two parts: a structure containing information about the string, and
512 the actual data associated with the string. The former structure
513 (a struct Lisp_String) is a fixed-size structure and is managed the
514 same way as all the other such types. This structure contains a
515 pointer to the actual string data, which is stored in structures of
516 type struct string_chars_block. Each string_chars_block consists
517 of a pointer to a struct Lisp_String, followed by the data for that
518 string, followed by another pointer to a Lisp_String, followed by
519 the data for that string, etc. At GC time, the data in these
520 blocks is compacted by searching sequentially through all the
521 blocks and compressing out any holes created by unmarked strings.
522 Strings that are more than a certain size (bigger than the size of
523 a string_chars_block, although something like half as big might
524 make more sense) are malloc()ed separately and not stored in
525 string_chars_blocks. Furthermore, no one string stretches across
526 two string_chars_blocks.
528 Vectors are each malloc()ed separately, similar to lcrecords.
530 In the following discussion, we use conses, but it applies equally
531 well to the other fixed-size types.
533 We store cons cells inside of cons_blocks, allocating a new
534 cons_block with malloc() whenever necessary. Cons cells reclaimed
535 by GC are put on a free list to be reallocated before allocating
536 any new cons cells from the latest cons_block. Each cons_block is
537 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
538 the versions in malloc.c and gmalloc.c) really allocates in units
539 of powers of two and uses 4 bytes for its own overhead.
541 What GC actually does is to search through all the cons_blocks,
542 from the most recently allocated to the oldest, and put all
543 cons cells that are not marked (whether or not they're already
544 free) on a cons_free_list. The cons_free_list is a stack, and
545 so the cons cells in the oldest-allocated cons_block end up
546 at the head of the stack and are the first to be reallocated.
547 If any cons_block is entirely free, it is freed with free()
548 and its cons cells removed from the cons_free_list. Because
549 the cons_free_list ends up basically in memory order, we have
550 a high locality of reference (assuming a reasonable turnover
551 of allocating and freeing) and have a reasonable probability
552 of entirely freeing up cons_blocks that have been more recently
553 allocated. This stage is called the "sweep stage" of GC, and
554 is executed after the "mark stage", which involves starting
555 from all places that are known to point to in-use Lisp objects
556 (e.g. the obarray, where are all symbols are stored; the
557 current catches and condition-cases; the backtrace list of
558 currently executing functions; the gcpro list; etc.) and
559 recursively marking all objects that are accessible.
561 At the beginning of the sweep stage, the conses in the cons blocks
562 are in one of three states: in use and marked, in use but not
563 marked, and not in use (already freed). Any conses that are marked
564 have been marked in the mark stage just executed, because as part
565 of the sweep stage we unmark any marked objects. The way we tell
566 whether or not a cons cell is in use is through the LRECORD_FREE_P
567 macro. This uses a special lrecord type `lrecord_type_free',
568 which is never associated with any valid object.
570 Conses on the free_cons_list are threaded through a pointer stored
571 in the conses themselves. Because the cons is still in a
572 cons_block and needs to remain marked as not in use for the next
573 time that GC happens, we need room to store both the "free"
574 indicator and the chaining pointer. So this pointer is stored
575 after the lrecord header (actually where C places a pointer after
576 the lrecord header; they are not necessarily contiguous). This
577 implies that all fixed-size types must be big enough to contain at
578 least one pointer. This is true for all current fixed-size types,
579 with the possible exception of Lisp_Floats, for which we define the
580 meat of the struct using a union of a pointer and a double to
581 ensure adequate space for the free list chain pointer.
583 Some types of objects need additional "finalization" done
584 when an object is converted from in use to not in use;
585 this is the purpose of the ADDITIONAL_FREE_type macro.
586 For example, markers need to be removed from the chain
587 of markers that is kept in each buffer. This is because
588 markers in a buffer automatically disappear if the marker
589 is no longer referenced anywhere (the same does not
590 apply to extents, however).
592 WARNING: Things are in an extremely bizarre state when
593 the ADDITIONAL_FREE_type macros are called, so beware!
595 When ERROR_CHECK_GC is defined, we do things differently so as to
596 maximize our chances of catching places where there is insufficient
597 GCPROing. The thing we want to avoid is having an object that
598 we're using but didn't GCPRO get freed by GC and then reallocated
599 while we're in the process of using it -- this will result in
600 something seemingly unrelated getting trashed, and is extremely
601 difficult to track down. If the object gets freed but not
602 reallocated, we can usually catch this because we set most of the
603 bytes of a freed object to 0xDEADBEEF. (The lisp object type is set
604 to the invalid type `lrecord_type_free', however, and a pointer
605 used to chain freed objects together is stored after the lrecord
606 header; we play some tricks with this pointer to make it more
607 bogus, so crashes are more likely to occur right away.)
609 We want freed objects to stay free as long as possible,
610 so instead of doing what we do above, we maintain the
611 free objects in a first-in first-out queue. We also
612 don't recompute the free list each GC, unlike above;
613 this ensures that the queue ordering is preserved.
614 [This means that we are likely to have worse locality
615 of reference, and that we can never free a frob block
616 once it's allocated. (Even if we know that all cells
617 in it are free, there's no easy way to remove all those
618 cells from the free list because the objects on the
619 free list are unlikely to be in memory order.)]
620 Furthermore, we never take objects off the free list
621 unless there's a large number (usually 1000, but
622 varies depending on type) of them already on the list.
623 This way, we ensure that an object that gets freed will
624 remain free for the next 1000 (or whatever) times that
625 an object of that type is allocated. */
627 #ifndef MALLOC_OVERHEAD
629 #define MALLOC_OVERHEAD 0
630 #elif defined (rcheck)
631 #define MALLOC_OVERHEAD 20
633 #define MALLOC_OVERHEAD 8
635 #endif /* MALLOC_OVERHEAD */
637 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
638 /* If we released our reserve (due to running out of memory),
639 and we have a fair amount free once again,
640 try to set aside another reserve in case we run out once more.
642 This is called when a relocatable block is freed in ralloc.c. */
643 void refill_memory_reserve (void);
645 refill_memory_reserve (void)
647 if (breathing_space == 0)
648 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
652 #ifdef ALLOC_NO_POOLS
653 # define TYPE_ALLOC_SIZE(type, structtype) 1
655 # define TYPE_ALLOC_SIZE(type, structtype) \
656 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
657 / sizeof (structtype))
658 #endif /* ALLOC_NO_POOLS */
660 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
662 struct type##_block \
664 struct type##_block *prev; \
665 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
668 static struct type##_block *current_##type##_block; \
669 static int current_##type##_block_index; \
671 static Lisp_Free *type##_free_list; \
672 static Lisp_Free *type##_free_list_tail; \
675 init_##type##_alloc (void) \
677 current_##type##_block = 0; \
678 current_##type##_block_index = \
679 countof (current_##type##_block->block); \
680 type##_free_list = 0; \
681 type##_free_list_tail = 0; \
684 static int gc_count_num_##type##_in_use; \
685 static int gc_count_num_##type##_freelist
687 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
688 if (current_##type##_block_index \
689 == countof (current_##type##_block->block)) \
691 struct type##_block *AFTFB_new = (struct type##_block *) \
692 allocate_lisp_storage (sizeof (struct type##_block)); \
693 AFTFB_new->prev = current_##type##_block; \
694 current_##type##_block = AFTFB_new; \
695 current_##type##_block_index = 0; \
698 &(current_##type##_block->block[current_##type##_block_index++]); \
701 /* Allocate an instance of a type that is stored in blocks.
702 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
705 #ifdef ERROR_CHECK_GC
707 /* Note: if you get crashes in this function, suspect incorrect calls
708 to free_cons() and friends. This happened once because the cons
709 cell was not GC-protected and was getting collected before
710 free_cons() was called. */
712 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
713 if (gc_count_num_##type##_freelist > \
714 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
716 result = (structtype *) type##_free_list; \
717 /* Before actually using the chain pointer, \
718 we complement all its bits; see FREE_FIXED_TYPE(). */ \
719 type##_free_list = (Lisp_Free *) \
720 (~ (EMACS_UINT) (type##_free_list->chain)); \
721 gc_count_num_##type##_freelist--; \
724 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
725 MARK_LRECORD_AS_NOT_FREE (result); \
728 #else /* !ERROR_CHECK_GC */
730 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
731 if (type##_free_list) \
733 result = (structtype *) type##_free_list; \
734 type##_free_list = type##_free_list->chain; \
737 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
738 MARK_LRECORD_AS_NOT_FREE (result); \
741 #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); \
759 /* Lisp_Free is the type to represent a free list member inside a frob
760 block of any lisp object type. */
761 typedef struct Lisp_Free
763 struct lrecord_header lheader;
764 struct Lisp_Free *chain;
767 #define LRECORD_FREE_P(ptr) \
768 ((ptr)->lheader.type == lrecord_type_free)
770 #define MARK_LRECORD_AS_FREE(ptr) \
771 ((void) ((ptr)->lheader.type = lrecord_type_free))
773 #ifdef ERROR_CHECK_GC
774 #define MARK_LRECORD_AS_NOT_FREE(ptr) \
775 ((void) ((ptr)->lheader.type = lrecord_type_undefined))
777 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING
780 #ifdef ERROR_CHECK_GC
782 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
783 if (type##_free_list_tail) \
785 /* When we store the chain pointer, we complement all \
786 its bits; this should significantly increase its \
787 bogosity in case someone tries to use the value, and \
788 should make us crash faster if someone overwrites the \
789 pointer because when it gets un-complemented in \
790 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
791 extremely bogus. */ \
792 type##_free_list_tail->chain = \
793 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \
796 type##_free_list = (Lisp_Free *) (ptr); \
797 type##_free_list_tail = (Lisp_Free *) (ptr); \
800 #else /* !ERROR_CHECK_GC */
802 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
803 ((Lisp_Free *) (ptr))->chain = type##_free_list; \
804 type##_free_list = (Lisp_Free *) (ptr); \
807 #endif /* !ERROR_CHECK_GC */
809 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
811 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
812 structtype *FFT_ptr = (ptr); \
813 ADDITIONAL_FREE_##type (FFT_ptr); \
814 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
815 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
816 MARK_LRECORD_AS_FREE (FFT_ptr); \
819 /* Like FREE_FIXED_TYPE() but used when we are explicitly
820 freeing a structure through free_cons(), free_marker(), etc.
821 rather than through the normal process of sweeping.
822 We attempt to undo the changes made to the allocation counters
823 as a result of this structure being allocated. This is not
824 completely necessary but helps keep things saner: e.g. this way,
825 repeatedly allocating and freeing a cons will not result in
826 the consing-since-gc counter advancing, which would cause a GC
827 and somewhat defeat the purpose of explicitly freeing. */
829 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
830 do { FREE_FIXED_TYPE (type, structtype, ptr); \
831 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
832 gc_count_num_##type##_freelist++; \
837 /************************************************************************/
838 /* Cons allocation */
839 /************************************************************************/
841 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
842 /* conses are used and freed so often that we set this really high */
843 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
844 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
847 mark_cons (Lisp_Object obj)
849 if (NILP (XCDR (obj)))
852 mark_object (XCAR (obj));
857 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
860 while (internal_equal (XCAR (ob1), XCAR (ob2), depth))
864 if (! CONSP (ob1) || ! CONSP (ob2))
865 return internal_equal (ob1, ob2, depth);
870 static const struct lrecord_description cons_description[] = {
871 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
872 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
876 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
877 mark_cons, print_cons, 0,
880 * No `hash' method needed.
881 * internal_hash knows how to
888 DEFUN ("cons", Fcons, 2, 2, 0, /*
889 Create a new cons, give it CAR and CDR as components, and return it.
893 /* This cannot GC. */
897 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
898 set_lheader_implementation (&c->lheader, &lrecord_cons);
905 /* This is identical to Fcons() but it used for conses that we're
906 going to free later, and is useful when trying to track down
909 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
914 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
915 set_lheader_implementation (&c->lheader, &lrecord_cons);
922 DEFUN ("list", Flist, 0, MANY, 0, /*
923 Return a newly created list with specified arguments as elements.
924 Any number of arguments, even zero arguments, are allowed.
926 (int nargs, Lisp_Object *args))
928 Lisp_Object val = Qnil;
929 Lisp_Object *argp = args + nargs;
932 val = Fcons (*--argp, val);
937 list1 (Lisp_Object obj0)
939 /* This cannot GC. */
940 return Fcons (obj0, Qnil);
944 list2 (Lisp_Object obj0, Lisp_Object obj1)
946 /* This cannot GC. */
947 return Fcons (obj0, Fcons (obj1, Qnil));
951 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
953 /* This cannot GC. */
954 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
958 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
960 /* This cannot GC. */
961 return Fcons (obj0, Fcons (obj1, obj2));
965 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
967 return Fcons (Fcons (key, value), alist);
971 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
973 /* This cannot GC. */
974 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
978 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
981 /* This cannot GC. */
982 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
986 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
987 Lisp_Object obj4, Lisp_Object obj5)
989 /* This cannot GC. */
990 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
993 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
994 Return a new list of length LENGTH, with each element being OBJECT.
998 CHECK_NATNUM (length);
1001 Lisp_Object val = Qnil;
1002 size_t size = XINT (length);
1005 val = Fcons (object, val);
1011 /************************************************************************/
1012 /* Float allocation */
1013 /************************************************************************/
1015 #ifdef LISP_FLOAT_TYPE
1017 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
1018 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1021 make_float (double float_value)
1026 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
1028 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1029 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1032 set_lheader_implementation (&f->lheader, &lrecord_float);
1033 float_data (f) = float_value;
1038 #endif /* LISP_FLOAT_TYPE */
1041 /************************************************************************/
1042 /* Vector allocation */
1043 /************************************************************************/
1046 mark_vector (Lisp_Object obj)
1048 Lisp_Vector *ptr = XVECTOR (obj);
1049 int len = vector_length (ptr);
1052 for (i = 0; i < len - 1; i++)
1053 mark_object (ptr->contents[i]);
1054 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1058 size_vector (const void *lheader)
1060 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, contents,
1061 ((Lisp_Vector *) lheader)->size);
1065 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1067 int len = XVECTOR_LENGTH (obj1);
1068 if (len != XVECTOR_LENGTH (obj2))
1072 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1073 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1075 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1082 vector_hash (Lisp_Object obj, int depth)
1084 return HASH2 (XVECTOR_LENGTH (obj),
1085 internal_array_hash (XVECTOR_DATA (obj),
1086 XVECTOR_LENGTH (obj),
1090 static const struct lrecord_description vector_description[] = {
1091 { XD_LONG, offsetof (Lisp_Vector, size) },
1092 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1096 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1097 mark_vector, print_vector, 0,
1101 size_vector, Lisp_Vector);
1103 /* #### should allocate `small' vectors from a frob-block */
1104 static Lisp_Vector *
1105 make_vector_internal (size_t sizei)
1107 /* no vector_next */
1108 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object,
1110 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1117 make_vector (size_t length, Lisp_Object object)
1119 Lisp_Vector *vecp = make_vector_internal (length);
1120 Lisp_Object *p = vector_data (vecp);
1127 XSETVECTOR (vector, vecp);
1132 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1133 Return a new vector of length LENGTH, with each element being OBJECT.
1134 See also the function `vector'.
1138 CONCHECK_NATNUM (length);
1139 return make_vector (XINT (length), object);
1142 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1143 Return a newly created vector with specified arguments as elements.
1144 Any number of arguments, even zero arguments, are allowed.
1146 (int nargs, Lisp_Object *args))
1148 Lisp_Vector *vecp = make_vector_internal (nargs);
1149 Lisp_Object *p = vector_data (vecp);
1156 XSETVECTOR (vector, vecp);
1162 vector1 (Lisp_Object obj0)
1164 return Fvector (1, &obj0);
1168 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1170 Lisp_Object args[2];
1173 return Fvector (2, args);
1177 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1179 Lisp_Object args[3];
1183 return Fvector (3, args);
1186 #if 0 /* currently unused */
1189 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1192 Lisp_Object args[4];
1197 return Fvector (4, args);
1201 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1202 Lisp_Object obj3, Lisp_Object obj4)
1204 Lisp_Object args[5];
1210 return Fvector (5, args);
1214 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1215 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1217 Lisp_Object args[6];
1224 return Fvector (6, args);
1228 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1229 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1232 Lisp_Object args[7];
1240 return Fvector (7, args);
1244 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1245 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1246 Lisp_Object obj6, Lisp_Object obj7)
1248 Lisp_Object args[8];
1257 return Fvector (8, args);
1261 /************************************************************************/
1262 /* Bit Vector allocation */
1263 /************************************************************************/
1265 static Lisp_Object all_bit_vectors;
1267 /* #### should allocate `small' bit vectors from a frob-block */
1268 static Lisp_Bit_Vector *
1269 make_bit_vector_internal (size_t sizei)
1271 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1272 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long,
1274 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1275 set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
1277 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1279 bit_vector_length (p) = sizei;
1280 bit_vector_next (p) = all_bit_vectors;
1281 /* make sure the extra bits in the last long are 0; the calling
1282 functions might not set them. */
1283 p->bits[num_longs - 1] = 0;
1284 XSETBIT_VECTOR (all_bit_vectors, p);
1289 make_bit_vector (size_t length, Lisp_Object bit)
1291 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1292 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1297 memset (p->bits, 0, num_longs * sizeof (long));
1300 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1301 memset (p->bits, ~0, num_longs * sizeof (long));
1302 /* But we have to make sure that the unused bits in the
1303 last long are 0, so that equal/hash is easy. */
1305 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1309 Lisp_Object bit_vector;
1310 XSETBIT_VECTOR (bit_vector, p);
1316 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1319 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1321 for (i = 0; i < length; i++)
1322 set_bit_vector_bit (p, i, bytevec[i]);
1325 Lisp_Object bit_vector;
1326 XSETBIT_VECTOR (bit_vector, p);
1331 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1332 Return a new bit vector of length LENGTH. with each bit set to BIT.
1333 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
1337 CONCHECK_NATNUM (length);
1339 return make_bit_vector (XINT (length), bit);
1342 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1343 Return a newly created bit vector with specified arguments as elements.
1344 Any number of arguments, even zero arguments, are allowed.
1345 Each argument must be one of the integers 0 or 1.
1347 (int nargs, Lisp_Object *args))
1350 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1352 for (i = 0; i < nargs; i++)
1354 CHECK_BIT (args[i]);
1355 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1359 Lisp_Object bit_vector;
1360 XSETBIT_VECTOR (bit_vector, p);
1366 /************************************************************************/
1367 /* Compiled-function allocation */
1368 /************************************************************************/
1370 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1371 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1374 make_compiled_function (void)
1376 Lisp_Compiled_Function *f;
1379 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1380 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
1383 f->specpdl_depth = 0;
1384 f->flags.documentationp = 0;
1385 f->flags.interactivep = 0;
1386 f->flags.domainp = 0; /* I18N3 */
1387 f->instructions = Qzero;
1388 f->constants = Qzero;
1390 f->doc_and_interactive = Qnil;
1391 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1392 f->annotated = Qnil;
1394 XSETCOMPILED_FUNCTION (fun, f);
1398 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1399 Return a new compiled-function object.
1400 Usage: (arglist instructions constants stack-depth
1401 &optional doc-string interactive)
1402 Note that, unlike all other emacs-lisp functions, calling this with five
1403 arguments is NOT the same as calling it with six arguments, the last of
1404 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1405 that this function was defined with `(interactive)'. If the arg is not
1406 specified, then that means the function is not interactive.
1407 This is terrible behavior which is retained for compatibility with old
1408 `.elc' files which expect these semantics.
1410 (int nargs, Lisp_Object *args))
1412 /* In a non-insane world this function would have this arglist...
1413 (arglist instructions constants stack_depth &optional doc_string interactive)
1415 Lisp_Object fun = make_compiled_function ();
1416 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1418 Lisp_Object arglist = args[0];
1419 Lisp_Object instructions = args[1];
1420 Lisp_Object constants = args[2];
1421 Lisp_Object stack_depth = args[3];
1422 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1423 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1425 if (nargs < 4 || nargs > 6)
1426 return Fsignal (Qwrong_number_of_arguments,
1427 list2 (intern ("make-byte-code"), make_int (nargs)));
1429 /* Check for valid formal parameter list now, to allow us to use
1430 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1432 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1434 CHECK_SYMBOL (symbol);
1435 if (EQ (symbol, Qt) ||
1436 EQ (symbol, Qnil) ||
1437 SYMBOL_IS_KEYWORD (symbol))
1438 signal_simple_error_2
1439 ("Invalid constant symbol in formal parameter list",
1443 f->arglist = arglist;
1445 /* `instructions' is a string or a cons (string . int) for a
1446 lazy-loaded function. */
1447 if (CONSP (instructions))
1449 CHECK_STRING (XCAR (instructions));
1450 CHECK_INT (XCDR (instructions));
1454 CHECK_STRING (instructions);
1456 f->instructions = instructions;
1458 if (!NILP (constants))
1459 CHECK_VECTOR (constants);
1460 f->constants = constants;
1462 CHECK_NATNUM (stack_depth);
1463 f->stack_depth = (unsigned short) XINT (stack_depth);
1465 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1466 if (!NILP (Vcurrent_compiled_function_annotation))
1467 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1468 else if (!NILP (Vload_file_name_internal_the_purecopy))
1469 f->annotated = Vload_file_name_internal_the_purecopy;
1470 else if (!NILP (Vload_file_name_internal))
1472 struct gcpro gcpro1;
1473 GCPRO1 (fun); /* don't let fun get reaped */
1474 Vload_file_name_internal_the_purecopy =
1475 Ffile_name_nondirectory (Vload_file_name_internal);
1476 f->annotated = Vload_file_name_internal_the_purecopy;
1479 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1481 /* doc_string may be nil, string, int, or a cons (string . int).
1482 interactive may be list or string (or unbound). */
1483 f->doc_and_interactive = Qunbound;
1485 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1486 f->doc_and_interactive = Vfile_domain;
1488 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1490 f->doc_and_interactive
1491 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1492 Fcons (interactive, f->doc_and_interactive));
1494 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1496 f->doc_and_interactive
1497 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1498 Fcons (doc_string, f->doc_and_interactive));
1500 if (UNBOUNDP (f->doc_and_interactive))
1501 f->doc_and_interactive = Qnil;
1507 /************************************************************************/
1508 /* Symbol allocation */
1509 /************************************************************************/
1511 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1512 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1514 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1515 Return a newly allocated uninterned symbol whose name is NAME.
1516 Its value and function definition are void, and its property list is nil.
1523 CHECK_STRING (name);
1525 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1526 set_lheader_implementation (&p->lheader, &lrecord_symbol);
1527 p->name = XSTRING (name);
1529 p->value = Qunbound;
1530 p->function = Qunbound;
1531 symbol_next (p) = 0;
1532 XSETSYMBOL (val, p);
1537 /************************************************************************/
1538 /* Extent allocation */
1539 /************************************************************************/
1541 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1542 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1545 allocate_extent (void)
1549 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1550 set_lheader_implementation (&e->lheader, &lrecord_extent);
1551 extent_object (e) = Qnil;
1552 set_extent_start (e, -1);
1553 set_extent_end (e, -1);
1558 extent_face (e) = Qnil;
1559 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1560 e->flags.detachable = 1;
1566 /************************************************************************/
1567 /* Event allocation */
1568 /************************************************************************/
1570 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1571 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1574 allocate_event (void)
1579 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1580 set_lheader_implementation (&e->lheader, &lrecord_event);
1587 /************************************************************************/
1588 /* Marker allocation */
1589 /************************************************************************/
1591 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1592 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1594 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1595 Return a new marker which does not point at any place.
1602 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1603 set_lheader_implementation (&p->lheader, &lrecord_marker);
1606 marker_next (p) = 0;
1607 marker_prev (p) = 0;
1608 p->insertion_type = 0;
1609 XSETMARKER (val, p);
1614 noseeum_make_marker (void)
1619 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1620 set_lheader_implementation (&p->lheader, &lrecord_marker);
1623 marker_next (p) = 0;
1624 marker_prev (p) = 0;
1625 p->insertion_type = 0;
1626 XSETMARKER (val, p);
1631 /************************************************************************/
1632 /* String allocation */
1633 /************************************************************************/
1635 /* The data for "short" strings generally resides inside of structs of type
1636 string_chars_block. The Lisp_String structure is allocated just like any
1637 other Lisp object (except for vectors), and these are freelisted when
1638 they get garbage collected. The data for short strings get compacted,
1639 but the data for large strings do not.
1641 Previously Lisp_String structures were relocated, but this caused a lot
1642 of bus-errors because the C code didn't include enough GCPRO's for
1643 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1644 that the reference would get relocated).
1646 This new method makes things somewhat bigger, but it is MUCH safer. */
1648 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1649 /* strings are used and freed quite often */
1650 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1651 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1654 mark_string (Lisp_Object obj)
1656 Lisp_String *ptr = XSTRING (obj);
1658 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1659 flush_cached_extent_info (XCAR (ptr->plist));
1664 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1667 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1668 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1671 static const struct lrecord_description string_description[] = {
1672 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1673 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1674 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1678 /* We store the string's extent info as the first element of the string's
1679 property list; and the string's MODIFF as the first or second element
1680 of the string's property list (depending on whether the extent info
1681 is present), but only if the string has been modified. This is ugly
1682 but it reduces the memory allocated for the string in the vast
1683 majority of cases, where the string is never modified and has no
1686 #### This means you can't use an int as a key in a string's plist. */
1688 static Lisp_Object *
1689 string_plist_ptr (Lisp_Object string)
1691 Lisp_Object *ptr = &XSTRING (string)->plist;
1693 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
1695 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
1701 string_getprop (Lisp_Object string, Lisp_Object property)
1703 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
1707 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
1709 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
1714 string_remprop (Lisp_Object string, Lisp_Object property)
1716 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
1720 string_plist (Lisp_Object string)
1722 return *string_plist_ptr (string);
1725 /* No `finalize', or `hash' methods.
1726 internal_hash() already knows how to hash strings and finalization
1727 is done with the ADDITIONAL_FREE_string macro, which is the
1728 standard way to do finalization when using
1729 SWEEP_FIXED_TYPE_BLOCK(). */
1730 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
1731 mark_string, print_string,
1740 /* String blocks contain this many useful bytes. */
1741 #define STRING_CHARS_BLOCK_SIZE \
1742 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1743 ((2 * sizeof (struct string_chars_block *)) \
1744 + sizeof (EMACS_INT))))
1745 /* Block header for small strings. */
1746 struct string_chars_block
1749 struct string_chars_block *next;
1750 struct string_chars_block *prev;
1751 /* Contents of string_chars_block->string_chars are interleaved
1752 string_chars structures (see below) and the actual string data */
1753 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1756 static struct string_chars_block *first_string_chars_block;
1757 static struct string_chars_block *current_string_chars_block;
1759 /* If SIZE is the length of a string, this returns how many bytes
1760 * the string occupies in string_chars_block->string_chars
1761 * (including alignment padding).
1763 #define STRING_FULLSIZE(size) \
1764 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1765 ALIGNOF (Lisp_String *))
1767 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1768 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1770 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
1771 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
1775 Lisp_String *string;
1776 unsigned char chars[1];
1779 struct unused_string_chars
1781 Lisp_String *string;
1786 init_string_chars_alloc (void)
1788 first_string_chars_block = xnew (struct string_chars_block);
1789 first_string_chars_block->prev = 0;
1790 first_string_chars_block->next = 0;
1791 first_string_chars_block->pos = 0;
1792 current_string_chars_block = first_string_chars_block;
1795 static struct string_chars *
1796 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1799 struct string_chars *s_chars;
1802 (countof (current_string_chars_block->string_chars)
1803 - current_string_chars_block->pos))
1805 /* This string can fit in the current string chars block */
1806 s_chars = (struct string_chars *)
1807 (current_string_chars_block->string_chars
1808 + current_string_chars_block->pos);
1809 current_string_chars_block->pos += fullsize;
1813 /* Make a new current string chars block */
1814 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1816 current_string_chars_block->next = new_scb;
1817 new_scb->prev = current_string_chars_block;
1819 current_string_chars_block = new_scb;
1820 new_scb->pos = fullsize;
1821 s_chars = (struct string_chars *)
1822 current_string_chars_block->string_chars;
1825 s_chars->string = string_it_goes_with;
1827 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1833 make_uninit_string (Bytecount length)
1836 EMACS_INT fullsize = STRING_FULLSIZE (length);
1839 assert (length >= 0 && fullsize > 0);
1841 /* Allocate the string header */
1842 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1843 set_lheader_implementation (&s->lheader, &lrecord_string);
1845 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1846 ? xnew_array (Bufbyte, length + 1)
1847 : allocate_string_chars_struct (s, fullsize)->chars);
1849 set_string_length (s, length);
1852 set_string_byte (s, length, 0);
1854 XSETSTRING (val, s);
1858 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1859 static void verify_string_chars_integrity (void);
1862 /* Resize the string S so that DELTA bytes can be inserted starting
1863 at POS. If DELTA < 0, it means deletion starting at POS. If
1864 POS < 0, resize the string but don't copy any characters. Use
1865 this if you're planning on completely overwriting the string.
1869 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
1871 Bytecount oldfullsize, newfullsize;
1872 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1873 verify_string_chars_integrity ();
1876 #ifdef ERROR_CHECK_BUFPOS
1879 assert (pos <= string_length (s));
1881 assert (pos + (-delta) <= string_length (s));
1886 assert ((-delta) <= string_length (s));
1888 #endif /* ERROR_CHECK_BUFPOS */
1891 /* simplest case: no size change. */
1894 if (pos >= 0 && delta < 0)
1895 /* If DELTA < 0, the functions below will delete the characters
1896 before POS. We want to delete characters *after* POS, however,
1897 so convert this to the appropriate form. */
1900 oldfullsize = STRING_FULLSIZE (string_length (s));
1901 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1903 if (BIG_STRING_FULLSIZE_P (oldfullsize))
1905 if (BIG_STRING_FULLSIZE_P (newfullsize))
1907 /* Both strings are big. We can just realloc().
1908 But careful! If the string is shrinking, we have to
1909 memmove() _before_ realloc(), and if growing, we have to
1910 memmove() _after_ realloc() - otherwise the access is
1911 illegal, and we might crash. */
1912 Bytecount len = string_length (s) + 1 - pos;
1914 if (delta < 0 && pos >= 0)
1915 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1916 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1917 string_length (s) + delta + 1));
1918 if (delta > 0 && pos >= 0)
1919 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1921 else /* String has been demoted from BIG_STRING. */
1924 allocate_string_chars_struct (s, newfullsize)->chars;
1925 Bufbyte *old_data = string_data (s);
1929 memcpy (new_data, old_data, pos);
1930 memcpy (new_data + pos + delta, old_data + pos,
1931 string_length (s) + 1 - pos);
1933 set_string_data (s, new_data);
1937 else /* old string is small */
1939 if (oldfullsize == newfullsize)
1941 /* special case; size change but the necessary
1942 allocation size won't change (up or down; code
1943 somewhere depends on there not being any unused
1944 allocation space, modulo any alignment
1948 Bufbyte *addroff = pos + string_data (s);
1950 memmove (addroff + delta, addroff,
1951 /* +1 due to zero-termination. */
1952 string_length (s) + 1 - pos);
1957 Bufbyte *old_data = string_data (s);
1959 BIG_STRING_FULLSIZE_P (newfullsize)
1960 ? xnew_array (Bufbyte, string_length (s) + delta + 1)
1961 : allocate_string_chars_struct (s, newfullsize)->chars;
1965 memcpy (new_data, old_data, pos);
1966 memcpy (new_data + pos + delta, old_data + pos,
1967 string_length (s) + 1 - pos);
1969 set_string_data (s, new_data);
1972 /* We need to mark this chunk of the string_chars_block
1973 as unused so that compact_string_chars() doesn't
1975 struct string_chars *old_s_chars = (struct string_chars *)
1976 ((char *) old_data - offsetof (struct string_chars, chars));
1977 /* Sanity check to make sure we aren't hosed by strange
1978 alignment/padding. */
1979 assert (old_s_chars->string == s);
1980 MARK_STRING_CHARS_AS_FREE (old_s_chars);
1981 ((struct unused_string_chars *) old_s_chars)->fullsize =
1987 set_string_length (s, string_length (s) + delta);
1988 /* If pos < 0, the string won't be zero-terminated.
1989 Terminate now just to make sure. */
1990 string_data (s)[string_length (s)] = '\0';
1996 XSETSTRING (string, s);
1997 /* We also have to adjust all of the extent indices after the
1998 place we did the change. We say "pos - 1" because
1999 adjust_extents() is exclusive of the starting position
2001 adjust_extents (string, pos - 1, string_length (s),
2005 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2006 verify_string_chars_integrity ();
2013 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2015 Bufbyte newstr[MAX_EMCHAR_LEN];
2016 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2017 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2018 Bytecount newlen = set_charptr_emchar (newstr, c);
2020 if (oldlen != newlen)
2021 resize_string (s, bytoff, newlen - oldlen);
2022 /* Remember, string_data (s) might have changed so we can't cache it. */
2023 memcpy (string_data (s) + bytoff, newstr, newlen);
2028 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2029 Return a new string consisting of LENGTH copies of CHARACTER.
2030 LENGTH must be a non-negative integer.
2032 (length, character))
2034 CHECK_NATNUM (length);
2035 CHECK_CHAR_COERCE_INT (character);
2037 Bufbyte init_str[MAX_EMCHAR_LEN];
2038 int len = set_charptr_emchar (init_str, XCHAR (character));
2039 Lisp_Object val = make_uninit_string (len * XINT (length));
2042 /* Optimize the single-byte case */
2043 memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val));
2047 Bufbyte *ptr = XSTRING_DATA (val);
2049 for (i = XINT (length); i; i--)
2051 Bufbyte *init_ptr = init_str;
2054 case 4: *ptr++ = *init_ptr++;
2055 case 3: *ptr++ = *init_ptr++;
2056 case 2: *ptr++ = *init_ptr++;
2057 case 1: *ptr++ = *init_ptr++;
2065 DEFUN ("string", Fstring, 0, MANY, 0, /*
2066 Concatenate all the argument characters and make the result a string.
2068 (int nargs, Lisp_Object *args))
2070 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2071 Bufbyte *p = storage;
2073 for (; nargs; nargs--, args++)
2075 Lisp_Object lisp_char = *args;
2076 CHECK_CHAR_COERCE_INT (lisp_char);
2077 p += set_charptr_emchar (p, XCHAR (lisp_char));
2079 return make_string (storage, p - storage);
2083 /* Take some raw memory, which MUST already be in internal format,
2084 and package it up into a Lisp string. */
2086 make_string (const Bufbyte *contents, Bytecount length)
2090 /* Make sure we find out about bad make_string's when they happen */
2091 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2092 bytecount_to_charcount (contents, length); /* Just for the assertions */
2095 val = make_uninit_string (length);
2096 memcpy (XSTRING_DATA (val), contents, length);
2100 /* Take some raw memory, encoded in some external data format,
2101 and convert it into a Lisp string. */
2103 make_ext_string (const Extbyte *contents, EMACS_INT length,
2104 Lisp_Object coding_system)
2107 TO_INTERNAL_FORMAT (DATA, (contents, length),
2108 LISP_STRING, string,
2114 build_string (const char *str)
2116 /* Some strlen's crash and burn if passed null. */
2117 return make_string ((const Bufbyte *) str, (str ? strlen(str) : 0));
2121 build_ext_string (const char *str, Lisp_Object coding_system)
2123 /* Some strlen's crash and burn if passed null. */
2124 return make_ext_string ((const Extbyte *) str, (str ? strlen(str) : 0),
2129 build_translated_string (const char *str)
2131 return build_string (GETTEXT (str));
2135 make_string_nocopy (const Bufbyte *contents, Bytecount length)
2140 /* Make sure we find out about bad make_string_nocopy's when they happen */
2141 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2142 bytecount_to_charcount (contents, length); /* Just for the assertions */
2145 /* Allocate the string header */
2146 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2147 set_lheader_implementation (&s->lheader, &lrecord_string);
2148 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2150 set_string_data (s, (Bufbyte *)contents);
2151 set_string_length (s, length);
2153 XSETSTRING (val, s);
2158 /************************************************************************/
2159 /* lcrecord lists */
2160 /************************************************************************/
2162 /* Lcrecord lists are used to manage the allocation of particular
2163 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2164 malloc() and garbage-collection junk) as much as possible.
2165 It is similar to the Blocktype class.
2169 1) Create an lcrecord-list object using make_lcrecord_list().
2170 This is often done at initialization. Remember to staticpro_nodump
2171 this object! The arguments to make_lcrecord_list() are the
2172 same as would be passed to alloc_lcrecord().
2173 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2174 and pass the lcrecord-list earlier created.
2175 3) When done with the lcrecord, call free_managed_lcrecord().
2176 The standard freeing caveats apply: ** make sure there are no
2177 pointers to the object anywhere! **
2178 4) Calling free_managed_lcrecord() is just like kissing the
2179 lcrecord goodbye as if it were garbage-collected. This means:
2180 -- the contents of the freed lcrecord are undefined, and the
2181 contents of something produced by allocate_managed_lcrecord()
2182 are undefined, just like for alloc_lcrecord().
2183 -- the mark method for the lcrecord's type will *NEVER* be called
2185 -- the finalize method for the lcrecord's type will be called
2186 at the time that free_managed_lcrecord() is called.
2191 mark_lcrecord_list (Lisp_Object obj)
2193 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2194 Lisp_Object chain = list->free;
2196 while (!NILP (chain))
2198 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2199 struct free_lcrecord_header *free_header =
2200 (struct free_lcrecord_header *) lheader;
2203 (/* There should be no other pointers to the free list. */
2204 ! MARKED_RECORD_HEADER_P (lheader)
2206 /* Only lcrecords should be here. */
2207 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
2209 /* Only free lcrecords should be here. */
2210 free_header->lcheader.free
2212 /* The type of the lcrecord must be right. */
2213 LHEADER_IMPLEMENTATION (lheader) == list->implementation
2215 /* So must the size. */
2216 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2217 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
2220 MARK_RECORD_HEADER (lheader);
2221 chain = free_header->chain;
2227 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2228 mark_lcrecord_list, internal_object_printer,
2229 0, 0, 0, 0, struct lcrecord_list);
2231 make_lcrecord_list (size_t size,
2232 const struct lrecord_implementation *implementation)
2234 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2235 &lrecord_lcrecord_list);
2238 p->implementation = implementation;
2241 XSETLCRECORD_LIST (val, p);
2246 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2248 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2249 if (!NILP (list->free))
2251 Lisp_Object val = list->free;
2252 struct free_lcrecord_header *free_header =
2253 (struct free_lcrecord_header *) XPNTR (val);
2255 #ifdef ERROR_CHECK_GC
2256 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2258 /* There should be no other pointers to the free list. */
2259 assert (! MARKED_RECORD_HEADER_P (lheader));
2260 /* Only lcrecords should be here. */
2261 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
2262 /* Only free lcrecords should be here. */
2263 assert (free_header->lcheader.free);
2264 /* The type of the lcrecord must be right. */
2265 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
2266 /* So must the size. */
2267 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2268 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
2269 #endif /* ERROR_CHECK_GC */
2271 list->free = free_header->chain;
2272 free_header->lcheader.free = 0;
2279 XSETOBJ (val, alloc_lcrecord (list->size, list->implementation));
2285 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2287 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2288 struct free_lcrecord_header *free_header =
2289 (struct free_lcrecord_header *) XPNTR (lcrecord);
2290 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2291 const struct lrecord_implementation *implementation
2292 = LHEADER_IMPLEMENTATION (lheader);
2294 /* Make sure the size is correct. This will catch, for example,
2295 putting a window configuration on the wrong free list. */
2296 gc_checking_assert ((implementation->size_in_bytes_method ?
2297 implementation->size_in_bytes_method (lheader) :
2298 implementation->static_size)
2301 if (implementation->finalizer)
2302 implementation->finalizer (lheader, 0);
2303 free_header->chain = list->free;
2304 free_header->lcheader.free = 1;
2305 list->free = lcrecord;
2311 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2312 Kept for compatibility, returns its argument.
2314 Make a copy of OBJECT in pure storage.
2315 Recursively copies contents of vectors and cons cells.
2316 Does not copy symbols.
2324 /************************************************************************/
2325 /* Garbage Collection */
2326 /************************************************************************/
2328 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
2329 Additional ones may be defined by a module (none yet). We leave some
2330 room in `lrecord_implementations_table' for such new lisp object types. */
2331 const struct lrecord_implementation *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT];
2332 unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
2333 /* Object marker functions are in the lrecord_implementation structure.
2334 But copying them to a parallel array is much more cache-friendly.
2335 This hack speeds up (garbage-collect) by about 5%. */
2336 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
2338 struct gcpro *gcprolist;
2340 /* We want the staticpros relocated, but not the pointers found therein.
2341 Hence we use a trivial description, as for pointerless objects. */
2342 static const struct lrecord_description staticpro_description_1[] = {
2346 static const struct struct_description staticpro_description = {
2347 sizeof (Lisp_Object *),
2348 staticpro_description_1
2351 static const struct lrecord_description staticpros_description_1[] = {
2352 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description),
2356 static const struct struct_description staticpros_description = {
2357 sizeof (Lisp_Object_ptr_dynarr),
2358 staticpros_description_1
2361 Lisp_Object_ptr_dynarr *staticpros;
2363 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
2364 garbage collection, and for dumping. */
2366 staticpro (Lisp_Object *varaddress)
2368 Dynarr_add (staticpros, varaddress);
2369 dump_add_root_object (varaddress);
2373 Lisp_Object_ptr_dynarr *staticpros_nodump;
2375 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
2376 garbage collection, but not for dumping. */
2378 staticpro_nodump (Lisp_Object *varaddress)
2380 Dynarr_add (staticpros_nodump, varaddress);
2383 #ifdef ERROR_CHECK_GC
2384 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
2385 struct lrecord_header * GCLI_lh = (lheader); \
2386 assert (GCLI_lh != 0); \
2387 assert (GCLI_lh->type < lrecord_type_count); \
2388 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
2389 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
2390 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
2393 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
2397 /* Mark reference to a Lisp_Object. If the object referred to has not been
2398 seen yet, recursively mark all the references contained in it. */
2401 mark_object (Lisp_Object obj)
2405 /* Checks we used to perform */
2406 /* if (EQ (obj, Qnull_pointer)) return; */
2407 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2408 /* if (PURIFIED (XPNTR (obj))) return; */
2410 if (XTYPE (obj) == Lisp_Type_Record)
2412 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2414 GC_CHECK_LHEADER_INVARIANTS (lheader);
2416 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
2417 ! ((struct lcrecord_header *) lheader)->free);
2419 /* All c_readonly objects have their mark bit set,
2420 so that we only need to check the mark bit here. */
2421 if (! MARKED_RECORD_HEADER_P (lheader))
2423 MARK_RECORD_HEADER (lheader);
2425 if (RECORD_MARKER (lheader))
2427 obj = RECORD_MARKER (lheader) (obj);
2428 if (!NILP (obj)) goto tail_recurse;
2434 /* mark all of the conses in a list and mark the final cdr; but
2435 DO NOT mark the cars.
2437 Use only for internal lists! There should never be other pointers
2438 to the cons cells, because if so, the cars will remain unmarked
2439 even when they maybe should be marked. */
2441 mark_conses_in_list (Lisp_Object obj)
2445 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2447 if (CONS_MARKED_P (XCONS (rest)))
2449 MARK_CONS (XCONS (rest));
2456 /* Find all structures not marked, and free them. */
2458 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2459 static int gc_count_bit_vector_storage;
2460 static int gc_count_num_short_string_in_use;
2461 static int gc_count_string_total_size;
2462 static int gc_count_short_string_total_size;
2464 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2467 /* stats on lcrecords in use - kinda kludgy */
2471 int instances_in_use;
2473 int instances_freed;
2475 int instances_on_free_list;
2476 } lcrecord_stats [countof (lrecord_implementations_table)
2477 + MODULE_DEFINABLE_TYPE_COUNT];
2480 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
2482 unsigned int type_index = h->type;
2484 if (((struct lcrecord_header *) h)->free)
2486 gc_checking_assert (!free_p);
2487 lcrecord_stats[type_index].instances_on_free_list++;
2491 const struct lrecord_implementation *implementation =
2492 LHEADER_IMPLEMENTATION (h);
2494 size_t sz = (implementation->size_in_bytes_method ?
2495 implementation->size_in_bytes_method (h) :
2496 implementation->static_size);
2499 lcrecord_stats[type_index].instances_freed++;
2500 lcrecord_stats[type_index].bytes_freed += sz;
2504 lcrecord_stats[type_index].instances_in_use++;
2505 lcrecord_stats[type_index].bytes_in_use += sz;
2511 /* Free all unmarked records */
2513 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2515 struct lcrecord_header *header;
2517 /* int total_size = 0; */
2519 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2521 /* First go through and call all the finalize methods.
2522 Then go through and free the objects. There used to
2523 be only one loop here, with the call to the finalizer
2524 occurring directly before the xfree() below. That
2525 is marginally faster but much less safe -- if the
2526 finalize method for an object needs to reference any
2527 other objects contained within it (and many do),
2528 we could easily be screwed by having already freed that
2531 for (header = *prev; header; header = header->next)
2533 struct lrecord_header *h = &(header->lheader);
2535 GC_CHECK_LHEADER_INVARIANTS (h);
2537 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
2539 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2540 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2544 for (header = *prev; header; )
2546 struct lrecord_header *h = &(header->lheader);
2547 if (MARKED_RECORD_HEADER_P (h))
2549 if (! C_READONLY_RECORD_HEADER_P (h))
2550 UNMARK_RECORD_HEADER (h);
2552 /* total_size += n->implementation->size_in_bytes (h);*/
2553 /* #### May modify header->next on a C_READONLY lcrecord */
2554 prev = &(header->next);
2556 tick_lcrecord_stats (h, 0);
2560 struct lcrecord_header *next = header->next;
2562 tick_lcrecord_stats (h, 1);
2563 /* used to call finalizer right here. */
2569 /* *total = total_size; */
2574 sweep_bit_vectors_1 (Lisp_Object *prev,
2575 int *used, int *total, int *storage)
2577 Lisp_Object bit_vector;
2580 int total_storage = 0;
2582 /* BIT_VECTORP fails because the objects are marked, which changes
2583 their implementation */
2584 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2586 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2588 if (MARKED_RECORD_P (bit_vector))
2590 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
2591 UNMARK_RECORD_HEADER (&(v->lheader));
2595 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long,
2596 bits, BIT_VECTOR_LONG_STORAGE (len));
2598 /* #### May modify next on a C_READONLY bitvector */
2599 prev = &(bit_vector_next (v));
2604 Lisp_Object next = bit_vector_next (v);
2611 *total = total_size;
2612 *storage = total_storage;
2615 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2616 to make macros prettier. */
2618 #ifdef ERROR_CHECK_GC
2620 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2622 struct typename##_block *SFTB_current; \
2624 int num_free = 0, num_used = 0; \
2626 for (SFTB_current = current_##typename##_block, \
2627 SFTB_limit = current_##typename##_block_index; \
2633 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2635 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2637 if (LRECORD_FREE_P (SFTB_victim)) \
2641 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2645 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2648 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2653 UNMARK_##typename (SFTB_victim); \
2656 SFTB_current = SFTB_current->prev; \
2657 SFTB_limit = countof (current_##typename##_block->block); \
2660 gc_count_num_##typename##_in_use = num_used; \
2661 gc_count_num_##typename##_freelist = num_free; \
2664 #else /* !ERROR_CHECK_GC */
2666 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2668 struct typename##_block *SFTB_current; \
2669 struct typename##_block **SFTB_prev; \
2671 int num_free = 0, num_used = 0; \
2673 typename##_free_list = 0; \
2675 for (SFTB_prev = ¤t_##typename##_block, \
2676 SFTB_current = current_##typename##_block, \
2677 SFTB_limit = current_##typename##_block_index; \
2682 int SFTB_empty = 1; \
2683 Lisp_Free *SFTB_old_free_list = typename##_free_list; \
2685 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2687 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2689 if (LRECORD_FREE_P (SFTB_victim)) \
2692 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2694 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2699 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2702 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2708 UNMARK_##typename (SFTB_victim); \
2713 SFTB_prev = &(SFTB_current->prev); \
2714 SFTB_current = SFTB_current->prev; \
2716 else if (SFTB_current == current_##typename##_block \
2717 && !SFTB_current->prev) \
2719 /* No real point in freeing sole allocation block */ \
2724 struct typename##_block *SFTB_victim_block = SFTB_current; \
2725 if (SFTB_victim_block == current_##typename##_block) \
2726 current_##typename##_block_index \
2727 = countof (current_##typename##_block->block); \
2728 SFTB_current = SFTB_current->prev; \
2730 *SFTB_prev = SFTB_current; \
2731 xfree (SFTB_victim_block); \
2732 /* Restore free list to what it was before victim was swept */ \
2733 typename##_free_list = SFTB_old_free_list; \
2734 num_free -= SFTB_limit; \
2737 SFTB_limit = countof (current_##typename##_block->block); \
2740 gc_count_num_##typename##_in_use = num_used; \
2741 gc_count_num_##typename##_freelist = num_free; \
2744 #endif /* !ERROR_CHECK_GC */
2752 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2753 #define ADDITIONAL_FREE_cons(ptr)
2755 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2758 /* Explicitly free a cons cell. */
2760 free_cons (Lisp_Cons *ptr)
2762 #ifdef ERROR_CHECK_GC
2763 /* If the CAR is not an int, then it will be a pointer, which will
2764 always be four-byte aligned. If this cons cell has already been
2765 placed on the free list, however, its car will probably contain
2766 a chain pointer to the next cons on the list, which has cleverly
2767 had all its 0's and 1's inverted. This allows for a quick
2768 check to make sure we're not freeing something already freed. */
2769 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2770 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2771 #endif /* ERROR_CHECK_GC */
2773 #ifndef ALLOC_NO_POOLS
2774 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2775 #endif /* ALLOC_NO_POOLS */
2778 /* explicitly free a list. You **must make sure** that you have
2779 created all the cons cells that make up this list and that there
2780 are no pointers to any of these cons cells anywhere else. If there
2781 are, you will lose. */
2784 free_list (Lisp_Object list)
2786 Lisp_Object rest, next;
2788 for (rest = list; !NILP (rest); rest = next)
2791 free_cons (XCONS (rest));
2795 /* explicitly free an alist. You **must make sure** that you have
2796 created all the cons cells that make up this alist and that there
2797 are no pointers to any of these cons cells anywhere else. If there
2798 are, you will lose. */
2801 free_alist (Lisp_Object alist)
2803 Lisp_Object rest, next;
2805 for (rest = alist; !NILP (rest); rest = next)
2808 free_cons (XCONS (XCAR (rest)));
2809 free_cons (XCONS (rest));
2814 sweep_compiled_functions (void)
2816 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2817 #define ADDITIONAL_FREE_compiled_function(ptr)
2819 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2823 #ifdef LISP_FLOAT_TYPE
2827 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2828 #define ADDITIONAL_FREE_float(ptr)
2830 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
2832 #endif /* LISP_FLOAT_TYPE */
2835 sweep_symbols (void)
2837 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2838 #define ADDITIONAL_FREE_symbol(ptr)
2840 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
2844 sweep_extents (void)
2846 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2847 #define ADDITIONAL_FREE_extent(ptr)
2849 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2855 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2856 #define ADDITIONAL_FREE_event(ptr)
2858 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
2862 sweep_markers (void)
2864 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2865 #define ADDITIONAL_FREE_marker(ptr) \
2866 do { Lisp_Object tem; \
2867 XSETMARKER (tem, ptr); \
2868 unchain_marker (tem); \
2871 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
2874 /* Explicitly free a marker. */
2876 free_marker (Lisp_Marker *ptr)
2878 /* Perhaps this will catch freeing an already-freed marker. */
2879 gc_checking_assert (ptr->lheader.type == lrecord_type_marker);
2881 #ifndef ALLOC_NO_POOLS
2882 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
2883 #endif /* ALLOC_NO_POOLS */
2887 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2890 verify_string_chars_integrity (void)
2892 struct string_chars_block *sb;
2894 /* Scan each existing string block sequentially, string by string. */
2895 for (sb = first_string_chars_block; sb; sb = sb->next)
2898 /* POS is the index of the next string in the block. */
2899 while (pos < sb->pos)
2901 struct string_chars *s_chars =
2902 (struct string_chars *) &(sb->string_chars[pos]);
2903 Lisp_String *string;
2907 /* If the string_chars struct is marked as free (i.e. the
2908 STRING pointer is NULL) then this is an unused chunk of
2909 string storage. (See below.) */
2911 if (STRING_CHARS_FREE_P (s_chars))
2913 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
2918 string = s_chars->string;
2919 /* Must be 32-bit aligned. */
2920 assert ((((int) string) & 3) == 0);
2922 size = string_length (string);
2923 fullsize = STRING_FULLSIZE (size);
2925 assert (!BIG_STRING_FULLSIZE_P (fullsize));
2926 assert (string_data (string) == s_chars->chars);
2929 assert (pos == sb->pos);
2933 #endif /* MULE && ERROR_CHECK_GC */
2935 /* Compactify string chars, relocating the reference to each --
2936 free any empty string_chars_block we see. */
2938 compact_string_chars (void)
2940 struct string_chars_block *to_sb = first_string_chars_block;
2942 struct string_chars_block *from_sb;
2944 /* Scan each existing string block sequentially, string by string. */
2945 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
2948 /* FROM_POS is the index of the next string in the block. */
2949 while (from_pos < from_sb->pos)
2951 struct string_chars *from_s_chars =
2952 (struct string_chars *) &(from_sb->string_chars[from_pos]);
2953 struct string_chars *to_s_chars;
2954 Lisp_String *string;
2958 /* If the string_chars struct is marked as free (i.e. the
2959 STRING pointer is NULL) then this is an unused chunk of
2960 string storage. This happens under Mule when a string's
2961 size changes in such a way that its fullsize changes.
2962 (Strings can change size because a different-length
2963 character can be substituted for another character.)
2964 In this case, after the bogus string pointer is the
2965 "fullsize" of this entry, i.e. how many bytes to skip. */
2967 if (STRING_CHARS_FREE_P (from_s_chars))
2969 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
2970 from_pos += fullsize;
2974 string = from_s_chars->string;
2975 assert (!(LRECORD_FREE_P (string)));
2977 size = string_length (string);
2978 fullsize = STRING_FULLSIZE (size);
2980 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
2982 /* Just skip it if it isn't marked. */
2983 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
2985 from_pos += fullsize;
2989 /* If it won't fit in what's left of TO_SB, close TO_SB out
2990 and go on to the next string_chars_block. We know that TO_SB
2991 cannot advance past FROM_SB here since FROM_SB is large enough
2992 to currently contain this string. */
2993 if ((to_pos + fullsize) > countof (to_sb->string_chars))
2995 to_sb->pos = to_pos;
2996 to_sb = to_sb->next;
3000 /* Compute new address of this string
3001 and update TO_POS for the space being used. */
3002 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3004 /* Copy the string_chars to the new place. */
3005 if (from_s_chars != to_s_chars)
3006 memmove (to_s_chars, from_s_chars, fullsize);
3008 /* Relocate FROM_S_CHARS's reference */
3009 set_string_data (string, &(to_s_chars->chars[0]));
3011 from_pos += fullsize;
3016 /* Set current to the last string chars block still used and
3017 free any that follow. */
3019 struct string_chars_block *victim;
3021 for (victim = to_sb->next; victim; )
3023 struct string_chars_block *next = victim->next;
3028 current_string_chars_block = to_sb;
3029 current_string_chars_block->pos = to_pos;
3030 current_string_chars_block->next = 0;
3034 #if 1 /* Hack to debug missing purecopy's */
3035 static int debug_string_purity;
3038 debug_string_purity_print (Lisp_String *p)
3041 Charcount s = string_char_length (p);
3043 for (i = 0; i < s; i++)
3045 Emchar ch = string_char (p, i);
3046 if (ch < 32 || ch >= 126)
3047 stderr_out ("\\%03o", ch);
3048 else if (ch == '\\' || ch == '\"')
3049 stderr_out ("\\%c", ch);
3051 stderr_out ("%c", ch);
3053 stderr_out ("\"\n");
3059 sweep_strings (void)
3061 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3062 int debug = debug_string_purity;
3064 #define UNMARK_string(ptr) do { \
3065 Lisp_String *p = (ptr); \
3066 size_t size = string_length (p); \
3067 UNMARK_RECORD_HEADER (&(p->lheader)); \
3068 num_bytes += size; \
3069 if (!BIG_STRING_SIZE_P (size)) \
3071 num_small_bytes += size; \
3075 debug_string_purity_print (p); \
3077 #define ADDITIONAL_FREE_string(ptr) do { \
3078 size_t size = string_length (ptr); \
3079 if (BIG_STRING_SIZE_P (size)) \
3080 xfree (ptr->data); \
3083 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3085 gc_count_num_short_string_in_use = num_small_used;
3086 gc_count_string_total_size = num_bytes;
3087 gc_count_short_string_total_size = num_small_bytes;
3091 /* I hate duplicating all this crap! */
3093 marked_p (Lisp_Object obj)
3095 /* Checks we used to perform. */
3096 /* if (EQ (obj, Qnull_pointer)) return 1; */
3097 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3098 /* if (PURIFIED (XPNTR (obj))) return 1; */
3100 if (XTYPE (obj) == Lisp_Type_Record)
3102 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3104 GC_CHECK_LHEADER_INVARIANTS (lheader);
3106 return MARKED_RECORD_HEADER_P (lheader);
3114 /* Free all unmarked records. Do this at the very beginning,
3115 before anything else, so that the finalize methods can safely
3116 examine items in the objects. sweep_lcrecords_1() makes
3117 sure to call all the finalize methods *before* freeing anything,
3118 to complete the safety. */
3121 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3124 compact_string_chars ();
3126 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3127 macros) must be *extremely* careful to make sure they're not
3128 referencing freed objects. The only two existing finalize
3129 methods (for strings and markers) pass muster -- the string
3130 finalizer doesn't look at anything but its own specially-
3131 created block, and the marker finalizer only looks at live
3132 buffers (which will never be freed) and at the markers before
3133 and after it in the chain (which, by induction, will never be
3134 freed because if so, they would have already removed themselves
3137 /* Put all unmarked strings on free list, free'ing the string chars
3138 of large unmarked strings */
3141 /* Put all unmarked conses on free list */
3144 /* Free all unmarked bit vectors */
3145 sweep_bit_vectors_1 (&all_bit_vectors,
3146 &gc_count_num_bit_vector_used,
3147 &gc_count_bit_vector_total_size,
3148 &gc_count_bit_vector_storage);
3150 /* Free all unmarked compiled-function objects */
3151 sweep_compiled_functions ();
3153 #ifdef LISP_FLOAT_TYPE
3154 /* Put all unmarked floats on free list */
3158 /* Put all unmarked symbols on free list */
3161 /* Put all unmarked extents on free list */
3164 /* Put all unmarked markers on free list.
3165 Dechain each one first from the buffer into which it points. */
3171 pdump_objects_unmark ();
3175 /* Clearing for disksave. */
3178 disksave_object_finalization (void)
3180 /* It's important that certain information from the environment not get
3181 dumped with the executable (pathnames, environment variables, etc.).
3182 To make it easier to tell when this has happened with strings(1) we
3183 clear some known-to-be-garbage blocks of memory, so that leftover
3184 results of old evaluation don't look like potential problems.
3185 But first we set some notable variables to nil and do one more GC,
3186 to turn those strings into garbage.
3189 /* Yeah, this list is pretty ad-hoc... */
3190 Vprocess_environment = Qnil;
3191 Vexec_directory = Qnil;
3192 Vdata_directory = Qnil;
3193 Vsite_directory = Qnil;
3194 Vdoc_directory = Qnil;
3195 Vconfigure_info_directory = Qnil;
3198 /* Vdump_load_path = Qnil; */
3199 /* Release hash tables for locate_file */
3200 Flocate_file_clear_hashing (Qt);
3201 uncache_home_directory();
3203 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3204 defined(LOADHIST_BUILTIN))
3205 Vload_history = Qnil;
3207 Vshell_file_name = Qnil;
3209 garbage_collect_1 ();
3211 /* Run the disksave finalization methods of all live objects. */
3212 disksave_object_finalization_1 ();
3214 /* Zero out the uninitialized (really, unused) part of the containers
3215 for the live strings. */
3217 struct string_chars_block *scb;
3218 for (scb = first_string_chars_block; scb; scb = scb->next)
3220 int count = sizeof (scb->string_chars) - scb->pos;
3222 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3225 /* from the block's fill ptr to the end */
3226 memset ((scb->string_chars + scb->pos), 0, count);
3231 /* There, that ought to be enough... */
3237 restore_gc_inhibit (Lisp_Object val)
3239 gc_currently_forbidden = XINT (val);
3243 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3244 static int gc_hooks_inhibited;
3246 struct post_gc_action
3248 void (*fun) (void *);
3252 typedef struct post_gc_action post_gc_action;
3256 Dynarr_declare (post_gc_action);
3257 } post_gc_action_dynarr;
3259 static post_gc_action_dynarr *post_gc_actions;
3261 /* Register an action to be called at the end of GC.
3262 gc_in_progress is 0 when this is called.
3263 This is used when it is discovered that an action needs to be taken,
3264 but it's during GC, so it's not safe. (e.g. in a finalize method.)
3266 As a general rule, do not use Lisp objects here.
3267 And NEVER signal an error.
3271 register_post_gc_action (void (*fun) (void *), void *arg)
3273 post_gc_action action;
3275 if (!post_gc_actions)
3276 post_gc_actions = Dynarr_new (post_gc_action);
3281 Dynarr_add (post_gc_actions, action);
3285 run_post_gc_actions (void)
3289 if (post_gc_actions)
3291 for (i = 0; i < Dynarr_length (post_gc_actions); i++)
3293 post_gc_action action = Dynarr_at (post_gc_actions, i);
3294 (action.fun) (action.arg);
3297 Dynarr_reset (post_gc_actions);
3303 garbage_collect_1 (void)
3305 #if MAX_SAVE_STACK > 0
3306 char stack_top_variable;
3307 extern char *stack_bottom;
3312 Lisp_Object pre_gc_cursor;
3313 struct gcpro gcpro1;
3316 || gc_currently_forbidden
3318 || preparing_for_armageddon)
3321 /* We used to call selected_frame() here.
3323 The following functions cannot be called inside GC
3324 so we move to after the above tests. */
3327 Lisp_Object device = Fselected_device (Qnil);
3328 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3330 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3332 signal_simple_error ("No frames exist on device", device);
3336 pre_gc_cursor = Qnil;
3339 GCPRO1 (pre_gc_cursor);
3341 /* Very important to prevent GC during any of the following
3342 stuff that might run Lisp code; otherwise, we'll likely
3343 have infinite GC recursion. */
3344 speccount = specpdl_depth ();
3345 record_unwind_protect (restore_gc_inhibit,
3346 make_int (gc_currently_forbidden));
3347 gc_currently_forbidden = 1;
3349 if (!gc_hooks_inhibited)
3350 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3352 /* Now show the GC cursor/message. */
3353 if (!noninteractive)
3355 if (FRAME_WIN_P (f))
3357 Lisp_Object frame = make_frame (f);
3358 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3359 FRAME_SELECTED_WINDOW (f),
3361 pre_gc_cursor = f->pointer;
3362 if (POINTER_IMAGE_INSTANCEP (cursor)
3363 /* don't change if we don't know how to change back. */
3364 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3367 Fset_frame_pointer (frame, cursor);
3371 /* Don't print messages to the stream device. */
3372 if (!cursor_changed && !FRAME_STREAM_P (f))
3374 char *msg = (STRINGP (Vgc_message)
3375 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3377 Lisp_Object args[2], whole_msg;
3378 args[0] = build_string (msg ? msg :
3379 GETTEXT ((const char *) gc_default_message));
3380 args[1] = build_string ("...");
3381 whole_msg = Fconcat (2, args);
3382 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3383 Qgarbage_collecting);
3387 /***** Now we actually start the garbage collection. */
3391 gc_generation_number[0]++;
3393 #if MAX_SAVE_STACK > 0
3395 /* Save a copy of the contents of the stack, for debugging. */
3398 /* Static buffer in which we save a copy of the C stack at each GC. */
3399 static char *stack_copy;
3400 static size_t stack_copy_size;
3402 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3403 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3404 if (stack_size < MAX_SAVE_STACK)
3406 if (stack_copy_size < stack_size)
3408 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3409 stack_copy_size = stack_size;
3413 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3417 #endif /* MAX_SAVE_STACK > 0 */
3419 /* Do some totally ad-hoc resource clearing. */
3420 /* #### generalize this? */
3421 clear_event_resource ();
3422 cleanup_specifiers ();
3424 /* Mark all the special slots that serve as the roots of accessibility. */
3427 Lisp_Object **p = Dynarr_begin (staticpros);
3429 for (count = Dynarr_length (staticpros); count; count--)
3430 mark_object (**p++);
3433 { /* staticpro_nodump() */
3434 Lisp_Object **p = Dynarr_begin (staticpros_nodump);
3436 for (count = Dynarr_length (staticpros_nodump); count; count--)
3437 mark_object (**p++);
3443 for (tail = gcprolist; tail; tail = tail->next)
3444 for (i = 0; i < tail->nvars; i++)
3445 mark_object (tail->var[i]);
3449 struct specbinding *bind;
3450 for (bind = specpdl; bind != specpdl_ptr; bind++)
3452 mark_object (bind->symbol);
3453 mark_object (bind->old_value);
3458 struct catchtag *catch;
3459 for (catch = catchlist; catch; catch = catch->next)
3461 mark_object (catch->tag);
3462 mark_object (catch->val);
3467 struct backtrace *backlist;
3468 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3470 int nargs = backlist->nargs;
3473 mark_object (*backlist->function);
3474 if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */)
3475 mark_object (backlist->args[0]);
3477 for (i = 0; i < nargs; i++)
3478 mark_object (backlist->args[i]);
3483 mark_profiling_info ();
3485 /* OK, now do the after-mark stuff. This is for things that
3486 are only marked when something else is marked (e.g. weak hash tables).
3487 There may be complex dependencies between such objects -- e.g.
3488 a weak hash table might be unmarked, but after processing a later
3489 weak hash table, the former one might get marked. So we have to
3490 iterate until nothing more gets marked. */
3492 while (finish_marking_weak_hash_tables () > 0 ||
3493 finish_marking_weak_lists () > 0)
3496 /* And prune (this needs to be called after everything else has been
3497 marked and before we do any sweeping). */
3498 /* #### this is somewhat ad-hoc and should probably be an object
3500 prune_weak_hash_tables ();
3501 prune_weak_lists ();
3502 prune_specifiers ();
3503 prune_syntax_tables ();
3507 consing_since_gc = 0;
3508 #ifndef DEBUG_XEMACS
3509 /* Allow you to set it really fucking low if you really want ... */
3510 if (gc_cons_threshold < 10000)
3511 gc_cons_threshold = 10000;
3516 run_post_gc_actions ();
3518 /******* End of garbage collection ********/
3520 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3522 /* Now remove the GC cursor/message */
3523 if (!noninteractive)
3526 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3527 else if (!FRAME_STREAM_P (f))
3529 char *msg = (STRINGP (Vgc_message)
3530 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3533 /* Show "...done" only if the echo area would otherwise be empty. */
3534 if (NILP (clear_echo_area (selected_frame (),
3535 Qgarbage_collecting, 0)))
3537 Lisp_Object args[2], whole_msg;
3538 args[0] = build_string (msg ? msg :
3539 GETTEXT ((const char *)
3540 gc_default_message));
3541 args[1] = build_string ("... done");
3542 whole_msg = Fconcat (2, args);
3543 echo_area_message (selected_frame (), (Bufbyte *) 0,
3545 Qgarbage_collecting);
3550 /* now stop inhibiting GC */
3551 unbind_to (speccount, Qnil);
3553 if (!breathing_space)
3555 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3562 /* Debugging aids. */
3565 gc_plist_hack (const char *name, int value, Lisp_Object tail)
3567 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3568 or portable numeric datatypes, or bit-vectors, or characters, or
3569 arrays, or exceptions, or ...) */
3570 return cons3 (intern (name), make_int (value), tail);
3573 #define HACK_O_MATIC(type, name, pl) do { \
3575 struct type##_block *x = current_##type##_block; \
3576 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3577 (pl) = gc_plist_hack ((name), s, (pl)); \
3580 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3581 Reclaim storage for Lisp objects no longer needed.
3582 Return info on amount of space in use:
3583 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3584 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3586 where `PLIST' is a list of alternating keyword/value pairs providing
3587 more detailed information.
3588 Garbage collection happens automatically if you cons more than
3589 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3593 Lisp_Object pl = Qnil;
3595 int gc_count_vector_total_size = 0;
3597 garbage_collect_1 ();
3599 for (i = 0; i < lrecord_type_count; i++)
3601 if (lcrecord_stats[i].bytes_in_use != 0
3602 || lcrecord_stats[i].bytes_freed != 0
3603 || lcrecord_stats[i].instances_on_free_list != 0)
3606 const char *name = lrecord_implementations_table[i]->name;
3607 int len = strlen (name);
3608 /* save this for the FSFmacs-compatible part of the summary */
3609 if (i == lrecord_type_vector)
3610 gc_count_vector_total_size =
3611 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3613 sprintf (buf, "%s-storage", name);
3614 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3615 /* Okay, simple pluralization check for `symbol-value-varalias' */
3616 if (name[len-1] == 's')
3617 sprintf (buf, "%ses-freed", name);
3619 sprintf (buf, "%ss-freed", name);
3620 if (lcrecord_stats[i].instances_freed != 0)
3621 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3622 if (name[len-1] == 's')
3623 sprintf (buf, "%ses-on-free-list", name);
3625 sprintf (buf, "%ss-on-free-list", name);
3626 if (lcrecord_stats[i].instances_on_free_list != 0)
3627 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3629 if (name[len-1] == 's')
3630 sprintf (buf, "%ses-used", name);
3632 sprintf (buf, "%ss-used", name);
3633 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3637 HACK_O_MATIC (extent, "extent-storage", pl);
3638 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3639 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3640 HACK_O_MATIC (event, "event-storage", pl);
3641 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3642 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3643 HACK_O_MATIC (marker, "marker-storage", pl);
3644 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3645 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3646 #ifdef LISP_FLOAT_TYPE
3647 HACK_O_MATIC (float, "float-storage", pl);
3648 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3649 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3650 #endif /* LISP_FLOAT_TYPE */
3651 HACK_O_MATIC (string, "string-header-storage", pl);
3652 pl = gc_plist_hack ("long-strings-total-length",
3653 gc_count_string_total_size
3654 - gc_count_short_string_total_size, pl);
3655 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3656 pl = gc_plist_hack ("short-strings-total-length",
3657 gc_count_short_string_total_size, pl);
3658 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3659 pl = gc_plist_hack ("long-strings-used",
3660 gc_count_num_string_in_use
3661 - gc_count_num_short_string_in_use, pl);
3662 pl = gc_plist_hack ("short-strings-used",
3663 gc_count_num_short_string_in_use, pl);
3665 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3666 pl = gc_plist_hack ("compiled-functions-free",
3667 gc_count_num_compiled_function_freelist, pl);
3668 pl = gc_plist_hack ("compiled-functions-used",
3669 gc_count_num_compiled_function_in_use, pl);
3671 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3672 pl = gc_plist_hack ("bit-vectors-total-length",
3673 gc_count_bit_vector_total_size, pl);
3674 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3676 HACK_O_MATIC (symbol, "symbol-storage", pl);
3677 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3678 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3680 HACK_O_MATIC (cons, "cons-storage", pl);
3681 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3682 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3684 /* The things we do for backwards-compatibility */
3686 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3687 make_int (gc_count_num_cons_freelist)),
3688 Fcons (make_int (gc_count_num_symbol_in_use),
3689 make_int (gc_count_num_symbol_freelist)),
3690 Fcons (make_int (gc_count_num_marker_in_use),
3691 make_int (gc_count_num_marker_freelist)),
3692 make_int (gc_count_string_total_size),
3693 make_int (gc_count_vector_total_size),
3698 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3699 Return the number of bytes consed since the last garbage collection.
3700 \"Consed\" is a misnomer in that this actually counts allocation
3701 of all different kinds of objects, not just conses.
3703 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3707 return make_int (consing_since_gc);
3711 DEFUN ("memory-limit", Fmemory_limit, 0, 0, 0, /*
3712 Return the address of the last byte Emacs has allocated, divided by 1024.
3713 This may be helpful in debugging Emacs's memory usage.
3714 The value is divided by 1024 to make sure it will fit in a lisp integer.
3718 return make_int ((EMACS_INT) sbrk (0) / 1024);
3724 object_dead_p (Lisp_Object obj)
3726 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3727 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3728 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3729 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3730 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3731 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3732 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3735 #ifdef MEMORY_USAGE_STATS
3737 /* Attempt to determine the actual amount of space that is used for
3738 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3740 It seems that the following holds:
3742 1. When using the old allocator (malloc.c):
3744 -- blocks are always allocated in chunks of powers of two. For
3745 each block, there is an overhead of 8 bytes if rcheck is not
3746 defined, 20 bytes if it is defined. In other words, a
3747 one-byte allocation needs 8 bytes of overhead for a total of
3748 9 bytes, and needs to have 16 bytes of memory chunked out for
3751 2. When using the new allocator (gmalloc.c):
3753 -- blocks are always allocated in chunks of powers of two up
3754 to 4096 bytes. Larger blocks are allocated in chunks of
3755 an integral multiple of 4096 bytes. The minimum block
3756 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3757 is defined. There is no per-block overhead, but there
3758 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3761 3. When using the system malloc, anything goes, but they are
3762 generally slower and more space-efficient than the GNU
3763 allocators. One possibly reasonable assumption to make
3764 for want of better data is that sizeof (void *), or maybe
3765 2 * sizeof (void *), is required as overhead and that
3766 blocks are allocated in the minimum required size except
3767 that some minimum block size is imposed (e.g. 16 bytes). */
3770 malloced_storage_size (void *ptr, size_t claimed_size,
3771 struct overhead_stats *stats)
3773 size_t orig_claimed_size = claimed_size;
3777 if (claimed_size < 2 * sizeof (void *))
3778 claimed_size = 2 * sizeof (void *);
3779 # ifdef SUNOS_LOCALTIME_BUG
3780 if (claimed_size < 16)
3783 if (claimed_size < 4096)
3787 /* compute the log base two, more or less, then use it to compute
3788 the block size needed. */
3790 /* It's big, it's heavy, it's wood! */
3791 while ((claimed_size /= 2) != 0)
3794 /* It's better than bad, it's good! */
3800 /* We have to come up with some average about the amount of
3802 if ((size_t) (rand () & 4095) < claimed_size)
3803 claimed_size += 3 * sizeof (void *);
3807 claimed_size += 4095;
3808 claimed_size &= ~4095;
3809 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3812 #elif defined (SYSTEM_MALLOC)
3814 if (claimed_size < 16)
3816 claimed_size += 2 * sizeof (void *);
3818 #else /* old GNU allocator */
3820 # ifdef rcheck /* #### may not be defined here */
3828 /* compute the log base two, more or less, then use it to compute
3829 the block size needed. */
3831 /* It's big, it's heavy, it's wood! */
3832 while ((claimed_size /= 2) != 0)
3835 /* It's better than bad, it's good! */
3843 #endif /* old GNU allocator */
3847 stats->was_requested += orig_claimed_size;
3848 stats->malloc_overhead += claimed_size - orig_claimed_size;
3850 return claimed_size;
3854 fixed_type_block_overhead (size_t size)
3856 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3857 size_t overhead = 0;
3858 size_t storage_size = malloced_storage_size (0, per_block, 0);
3859 while (size >= per_block)
3862 overhead += sizeof (void *) + per_block - storage_size;
3864 if (rand () % per_block < size)
3865 overhead += sizeof (void *) + per_block - storage_size;
3869 #endif /* MEMORY_USAGE_STATS */
3872 /* Initialization */
3874 reinit_alloc_once_early (void)
3876 gc_generation_number[0] = 0;
3877 breathing_space = 0;
3878 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3879 XSETINT (Vgc_message, 0);
3881 ignore_malloc_warnings = 1;
3882 #ifdef DOUG_LEA_MALLOC
3883 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3884 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3885 #if 0 /* Moved to emacs.c */
3886 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3889 init_string_alloc ();
3890 init_string_chars_alloc ();
3892 init_symbol_alloc ();
3893 init_compiled_function_alloc ();
3894 #ifdef LISP_FLOAT_TYPE
3895 init_float_alloc ();
3896 #endif /* LISP_FLOAT_TYPE */
3897 init_marker_alloc ();
3898 init_extent_alloc ();
3899 init_event_alloc ();
3901 ignore_malloc_warnings = 0;
3903 if (staticpros_nodump)
3904 Dynarr_free (staticpros_nodump);
3905 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3906 Dynarr_resize (staticpros_nodump, 100); /* merely a small optimization */
3908 consing_since_gc = 0;
3910 gc_cons_threshold = 500000; /* XEmacs change */
3912 gc_cons_threshold = 15000; /* debugging */
3914 lrecord_uid_counter = 259;
3915 debug_string_purity = 0;
3918 gc_currently_forbidden = 0;
3919 gc_hooks_inhibited = 0;
3921 #ifdef ERROR_CHECK_TYPECHECK
3922 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3925 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3927 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3929 #endif /* ERROR_CHECK_TYPECHECK */
3933 init_alloc_once_early (void)
3935 reinit_alloc_once_early ();
3939 for (i = 0; i < countof (lrecord_implementations_table); i++)
3940 lrecord_implementations_table[i] = 0;
3943 INIT_LRECORD_IMPLEMENTATION (cons);
3944 INIT_LRECORD_IMPLEMENTATION (vector);
3945 INIT_LRECORD_IMPLEMENTATION (string);
3946 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
3948 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3949 Dynarr_resize (staticpros, 1410); /* merely a small optimization */
3950 dump_add_root_struct_ptr (&staticpros, &staticpros_description);
3960 syms_of_alloc (void)
3962 DEFSYMBOL (Qpre_gc_hook);
3963 DEFSYMBOL (Qpost_gc_hook);
3964 DEFSYMBOL (Qgarbage_collecting);
3969 DEFSUBR (Fbit_vector);
3970 DEFSUBR (Fmake_byte_code);
3971 DEFSUBR (Fmake_list);
3972 DEFSUBR (Fmake_vector);
3973 DEFSUBR (Fmake_bit_vector);
3974 DEFSUBR (Fmake_string);
3976 DEFSUBR (Fmake_symbol);
3977 DEFSUBR (Fmake_marker);
3978 DEFSUBR (Fpurecopy);
3979 DEFSUBR (Fgarbage_collect);
3981 DEFSUBR (Fmemory_limit);
3983 DEFSUBR (Fconsing_since_gc);
3987 vars_of_alloc (void)
3989 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
3990 *Number of bytes of consing between garbage collections.
3991 \"Consing\" is a misnomer in that this actually counts allocation
3992 of all different kinds of objects, not just conses.
3993 Garbage collection can happen automatically once this many bytes have been
3994 allocated since the last garbage collection. All data types count.
3996 Garbage collection happens automatically when `eval' or `funcall' are
3997 called. (Note that `funcall' is called implicitly as part of evaluation.)
3998 By binding this temporarily to a large number, you can effectively
3999 prevent garbage collection during a part of the program.
4001 See also `consing-since-gc'.
4005 DEFVAR_INT ("debug-allocation", &debug_allocation /*
4006 If non-zero, print out information to stderr about all objects allocated.
4007 See also `debug-allocation-backtrace-length'.
4009 debug_allocation = 0;
4011 DEFVAR_INT ("debug-allocation-backtrace-length",
4012 &debug_allocation_backtrace_length /*
4013 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4015 debug_allocation_backtrace_length = 2;
4018 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4019 Non-nil means loading Lisp code in order to dump an executable.
4020 This means that certain objects should be allocated in readonly space.
4023 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4024 Function or functions to be run just before each garbage collection.
4025 Interrupts, garbage collection, and errors are inhibited while this hook
4026 runs, so be extremely careful in what you add here. In particular, avoid
4027 consing, and do not interact with the user.
4029 Vpre_gc_hook = Qnil;
4031 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4032 Function or functions to be run just after each garbage collection.
4033 Interrupts, garbage collection, and errors are inhibited while this hook
4034 runs, so be extremely careful in what you add here. In particular, avoid
4035 consing, and do not interact with the user.
4037 Vpost_gc_hook = Qnil;
4039 DEFVAR_LISP ("gc-message", &Vgc_message /*
4040 String to print to indicate that a garbage collection is in progress.
4041 This is printed in the echo area. If the selected frame is on a
4042 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4043 image instance) in the domain of the selected frame, the mouse pointer
4044 will change instead of this message being printed.
4046 Vgc_message = build_string (gc_default_message);
4048 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4049 Pointer glyph used to indicate that a garbage collection is in progress.
4050 If the selected window is on a window system and this glyph specifies a
4051 value (i.e. a pointer image instance) in the domain of the selected
4052 window, the pointer will be changed as specified during garbage collection.
4053 Otherwise, a message will be printed in the echo area, as controlled
4059 complex_vars_of_alloc (void)
4061 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);