1 /* Storage allocation and gc for XEmacs Lisp interpreter.
2 Copyright (C) 1985-1998 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
4 Copyright (C) 1995, 1996 Ben Wing.
6 This file is part of XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from
28 FSF: Original version; a long time ago.
29 Mly: Significantly rewritten to use new 3-bit tags and
30 nicely abstracted object definitions, for 19.8.
31 JWZ: Improved code to keep track of purespace usage and
32 issue nice purespace and GC stats.
33 Ben Wing: Cleaned up frob-block lrecord code, added error-checking
34 and various changes for Mule, for 19.12.
35 Added bit vectors for 19.13.
36 Added lcrecord lists for 19.14.
37 slb: Lots of work on the purification and dump time code.
38 Synched Doug Lea malloc support from Emacs 20.2.
39 og: Killed the purespace. Portable dumper (moved to dumper.c)
45 #include "backtrace.h"
56 #include "redisplay.h"
57 #include "specifier.h"
61 #include "console-stream.h"
63 #ifdef DOUG_LEA_MALLOC
71 EXFUN (Fgarbage_collect, 0);
73 #if 0 /* this is _way_ too slow to be part of the standard debug options */
74 #if defined(DEBUG_XEMACS) && defined(MULE)
75 #define VERIFY_STRING_CHARS_INTEGRITY
79 /* Define this to use malloc/free with no freelist for all datatypes,
80 the hope being that some debugging tools may help detect
81 freed memory references */
82 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
84 #define ALLOC_NO_POOLS
88 static int debug_allocation;
89 static int debug_allocation_backtrace_length;
92 /* Number of bytes of consing done since the last gc */
93 EMACS_INT consing_since_gc;
94 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
96 #define debug_allocation_backtrace() \
98 if (debug_allocation_backtrace_length > 0) \
99 debug_short_backtrace (debug_allocation_backtrace_length); \
103 #define INCREMENT_CONS_COUNTER(foosize, type) \
105 if (debug_allocation) \
107 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
108 debug_allocation_backtrace (); \
110 INCREMENT_CONS_COUNTER_1 (foosize); \
112 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
114 if (debug_allocation > 1) \
116 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
117 debug_allocation_backtrace (); \
119 INCREMENT_CONS_COUNTER_1 (foosize); \
122 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
123 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
124 INCREMENT_CONS_COUNTER_1 (size)
127 #define DECREMENT_CONS_COUNTER(size) do { \
128 consing_since_gc -= (size); \
129 if (consing_since_gc < 0) \
130 consing_since_gc = 0; \
133 /* Number of bytes of consing since gc before another gc should be done. */
134 EMACS_INT gc_cons_threshold;
136 /* Nonzero during gc */
139 /* Number of times GC has happened at this level or below.
140 * Level 0 is most volatile, contrary to usual convention.
141 * (Of course, there's only one level at present) */
142 EMACS_INT gc_generation_number[1];
144 /* This is just for use by the printer, to allow things to print uniquely */
145 static int lrecord_uid_counter;
147 /* Nonzero when calling certain hooks or doing other things where
149 int gc_currently_forbidden;
152 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
153 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
155 /* "Garbage collecting" */
156 Lisp_Object Vgc_message;
157 Lisp_Object Vgc_pointer_glyph;
158 static const char gc_default_message[] = "Garbage collecting";
159 Lisp_Object Qgarbage_collecting;
161 /* Non-zero means we're in the process of doing the dump */
164 #ifdef ERROR_CHECK_TYPECHECK
166 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
171 c_readonly (Lisp_Object obj)
173 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
177 lisp_readonly (Lisp_Object obj)
179 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
183 /* Maximum amount of C stack to save when a GC happens. */
185 #ifndef MAX_SAVE_STACK
186 #define MAX_SAVE_STACK 0 /* 16000 */
189 /* Non-zero means ignore malloc warnings. Set during initialization. */
190 int ignore_malloc_warnings;
193 static void *breathing_space;
196 release_breathing_space (void)
200 void *tmp = breathing_space;
206 /* malloc calls this if it finds we are near exhausting storage */
208 malloc_warning (const char *str)
210 if (ignore_malloc_warnings)
216 "Killing some buffers may delay running out of memory.\n"
217 "However, certainly by the time you receive the 95%% warning,\n"
218 "you should clean up, kill this Emacs, and start a new one.",
222 /* Called if malloc returns zero */
226 /* Force a GC next time eval is called.
227 It's better to loop garbage-collecting (we might reclaim enough
228 to win) than to loop beeping and barfing "Memory exhausted"
230 consing_since_gc = gc_cons_threshold + 1;
231 release_breathing_space ();
233 /* Flush some histories which might conceivably contain garbalogical
235 if (!NILP (Fboundp (Qvalues)))
236 Fset (Qvalues, Qnil);
237 Vcommand_history = Qnil;
239 error ("Memory exhausted");
242 /* like malloc and realloc but check for no memory left, and block input. */
246 xmalloc (size_t size)
248 void *val = malloc (size);
250 if (!val && (size != 0)) memory_full ();
256 xcalloc (size_t nelem, size_t elsize)
258 void *val = calloc (nelem, elsize);
260 if (!val && (nelem != 0)) memory_full ();
265 xmalloc_and_zero (size_t size)
267 return xcalloc (size, sizeof (char));
272 xrealloc (void *block, size_t size)
274 /* We must call malloc explicitly when BLOCK is 0, since some
275 reallocs don't do this. */
276 void *val = block ? realloc (block, size) : malloc (size);
278 if (!val && (size != 0)) memory_full ();
283 #ifdef ERROR_CHECK_MALLOC
284 xfree_1 (void *block)
289 #ifdef ERROR_CHECK_MALLOC
290 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
291 error until much later on for many system mallocs, such as
292 the one that comes with Solaris 2.3. FMH!! */
293 assert (block != (void *) 0xDEADBEEF);
295 #endif /* ERROR_CHECK_MALLOC */
299 #ifdef ERROR_CHECK_GC
302 typedef unsigned int four_byte_t;
303 #elif SIZEOF_LONG == 4
304 typedef unsigned long four_byte_t;
305 #elif SIZEOF_SHORT == 4
306 typedef unsigned short four_byte_t;
308 What kind of strange-ass system are we running on?
312 deadbeef_memory (void *ptr, size_t size)
314 four_byte_t *ptr4 = (four_byte_t *) ptr;
315 size_t beefs = size >> 2;
317 /* In practice, size will always be a multiple of four. */
319 (*ptr4++) = 0xDEADBEEF;
322 #else /* !ERROR_CHECK_GC */
325 #define deadbeef_memory(ptr, size)
327 #endif /* !ERROR_CHECK_GC */
331 xstrdup (const char *str)
333 int len = strlen (str) + 1; /* for stupid terminating 0 */
335 void *val = xmalloc (len);
336 if (val == 0) return 0;
337 return (char *) memcpy (val, str, len);
342 strdup (const char *s)
346 #endif /* NEED_STRDUP */
350 allocate_lisp_storage (size_t size)
352 return xmalloc (size);
356 /* lcrecords are chained together through their "next" field.
357 After doing the mark phase, GC will walk this linked list
358 and free any lcrecord which hasn't been marked. */
359 static struct lcrecord_header *all_lcrecords;
362 alloc_lcrecord (size_t size, const struct lrecord_implementation *implementation)
364 struct lcrecord_header *lcheader;
367 ((implementation->static_size == 0 ?
368 implementation->size_in_bytes_method != NULL :
369 implementation->static_size == size)
371 (! implementation->basic_p)
373 (! (implementation->hash == NULL && implementation->equal != NULL)));
375 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
376 set_lheader_implementation (&lcheader->lheader, implementation);
377 lcheader->next = all_lcrecords;
378 #if 1 /* mly prefers to see small ID numbers */
379 lcheader->uid = lrecord_uid_counter++;
380 #else /* jwz prefers to see real addrs */
381 lcheader->uid = (int) &lcheader;
384 all_lcrecords = lcheader;
385 INCREMENT_CONS_COUNTER (size, implementation->name);
389 #if 0 /* Presently unused */
390 /* Very, very poor man's EGC?
391 * This may be slow and thrash pages all over the place.
392 * Only call it if you really feel you must (and if the
393 * lrecord was fairly recently allocated).
394 * Otherwise, just let the GC do its job -- that's what it's there for
397 free_lcrecord (struct lcrecord_header *lcrecord)
399 if (all_lcrecords == lcrecord)
401 all_lcrecords = lcrecord->next;
405 struct lrecord_header *header = all_lcrecords;
408 struct lrecord_header *next = header->next;
409 if (next == lcrecord)
411 header->next = lrecord->next;
420 if (lrecord->implementation->finalizer)
421 lrecord->implementation->finalizer (lrecord, 0);
429 disksave_object_finalization_1 (void)
431 struct lcrecord_header *header;
433 for (header = all_lcrecords; header; header = header->next)
435 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
437 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
442 /************************************************************************/
443 /* Debugger support */
444 /************************************************************************/
445 /* Give gdb/dbx enough information to decode Lisp Objects. We make
446 sure certain symbols are always defined, so gdb doesn't complain
447 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
448 to see how this is used. */
450 const EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
451 const EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
453 #ifdef USE_UNION_TYPE
454 const unsigned char dbg_USE_UNION_TYPE = 1;
456 const unsigned char dbg_USE_UNION_TYPE = 0;
459 const unsigned char dbg_valbits = VALBITS;
460 const unsigned char dbg_gctypebits = GCTYPEBITS;
462 /* Macros turned into functions for ease of debugging.
463 Debuggers don't know about macros! */
464 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
466 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
468 return EQ (obj1, obj2);
472 /************************************************************************/
473 /* Fixed-size type macros */
474 /************************************************************************/
476 /* For fixed-size types that are commonly used, we malloc() large blocks
477 of memory at a time and subdivide them into chunks of the correct
478 size for an object of that type. This is more efficient than
479 malloc()ing each object separately because we save on malloc() time
480 and overhead due to the fewer number of malloc()ed blocks, and
481 also because we don't need any extra pointers within each object
482 to keep them threaded together for GC purposes. For less common
483 (and frequently large-size) types, we use lcrecords, which are
484 malloc()ed individually and chained together through a pointer
485 in the lcrecord header. lcrecords do not need to be fixed-size
486 (i.e. two objects of the same type need not have the same size;
487 however, the size of a particular object cannot vary dynamically).
488 It is also much easier to create a new lcrecord type because no
489 additional code needs to be added to alloc.c. Finally, lcrecords
490 may be more efficient when there are only a small number of them.
492 The types that are stored in these large blocks (or "frob blocks")
493 are cons, float, compiled-function, symbol, marker, extent, event,
496 Note that strings are special in that they are actually stored in
497 two parts: a structure containing information about the string, and
498 the actual data associated with the string. The former structure
499 (a struct Lisp_String) is a fixed-size structure and is managed the
500 same way as all the other such types. This structure contains a
501 pointer to the actual string data, which is stored in structures of
502 type struct string_chars_block. Each string_chars_block consists
503 of a pointer to a struct Lisp_String, followed by the data for that
504 string, followed by another pointer to a Lisp_String, followed by
505 the data for that string, etc. At GC time, the data in these
506 blocks is compacted by searching sequentially through all the
507 blocks and compressing out any holes created by unmarked strings.
508 Strings that are more than a certain size (bigger than the size of
509 a string_chars_block, although something like half as big might
510 make more sense) are malloc()ed separately and not stored in
511 string_chars_blocks. Furthermore, no one string stretches across
512 two string_chars_blocks.
514 Vectors are each malloc()ed separately, similar to lcrecords.
516 In the following discussion, we use conses, but it applies equally
517 well to the other fixed-size types.
519 We store cons cells inside of cons_blocks, allocating a new
520 cons_block with malloc() whenever necessary. Cons cells reclaimed
521 by GC are put on a free list to be reallocated before allocating
522 any new cons cells from the latest cons_block. Each cons_block is
523 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
524 the versions in malloc.c and gmalloc.c) really allocates in units
525 of powers of two and uses 4 bytes for its own overhead.
527 What GC actually does is to search through all the cons_blocks,
528 from the most recently allocated to the oldest, and put all
529 cons cells that are not marked (whether or not they're already
530 free) on a cons_free_list. The cons_free_list is a stack, and
531 so the cons cells in the oldest-allocated cons_block end up
532 at the head of the stack and are the first to be reallocated.
533 If any cons_block is entirely free, it is freed with free()
534 and its cons cells removed from the cons_free_list. Because
535 the cons_free_list ends up basically in memory order, we have
536 a high locality of reference (assuming a reasonable turnover
537 of allocating and freeing) and have a reasonable probability
538 of entirely freeing up cons_blocks that have been more recently
539 allocated. This stage is called the "sweep stage" of GC, and
540 is executed after the "mark stage", which involves starting
541 from all places that are known to point to in-use Lisp objects
542 (e.g. the obarray, where are all symbols are stored; the
543 current catches and condition-cases; the backtrace list of
544 currently executing functions; the gcpro list; etc.) and
545 recursively marking all objects that are accessible.
547 At the beginning of the sweep stage, the conses in the cons blocks
548 are in one of three states: in use and marked, in use but not
549 marked, and not in use (already freed). Any conses that are marked
550 have been marked in the mark stage just executed, because as part
551 of the sweep stage we unmark any marked objects. The way we tell
552 whether or not a cons cell is in use is through the LRECORD_FREE_P
553 macro. This uses a special lrecord type `lrecord_type_free',
554 which is never associated with any valid object.
556 Conses on the free_cons_list are threaded through a pointer stored
557 in the conses themselves. Because the cons is still in a
558 cons_block and needs to remain marked as not in use for the next
559 time that GC happens, we need room to store both the "free"
560 indicator and the chaining pointer. So this pointer is stored
561 after the lrecord header (actually where C places a pointer after
562 the lrecord header; they are not necessarily contiguous). This
563 implies that all fixed-size types must be big enough to contain at
564 least one pointer. This is true for all current fixed-size types,
565 with the possible exception of Lisp_Floats, for which we define the
566 meat of the struct using a union of a pointer and a double to
567 ensure adequate space for the free list chain pointer.
569 Some types of objects need additional "finalization" done
570 when an object is converted from in use to not in use;
571 this is the purpose of the ADDITIONAL_FREE_type macro.
572 For example, markers need to be removed from the chain
573 of markers that is kept in each buffer. This is because
574 markers in a buffer automatically disappear if the marker
575 is no longer referenced anywhere (the same does not
576 apply to extents, however).
578 WARNING: Things are in an extremely bizarre state when
579 the ADDITIONAL_FREE_type macros are called, so beware!
581 When ERROR_CHECK_GC is defined, we do things differently so as to
582 maximize our chances of catching places where there is insufficient
583 GCPROing. The thing we want to avoid is having an object that
584 we're using but didn't GCPRO get freed by GC and then reallocated
585 while we're in the process of using it -- this will result in
586 something seemingly unrelated getting trashed, and is extremely
587 difficult to track down. If the object gets freed but not
588 reallocated, we can usually catch this because we set most of the
589 bytes of a freed object to 0xDEADBEEF. (The lisp object type is set
590 to the invalid type `lrecord_type_free', however, and a pointer
591 used to chain freed objects together is stored after the lrecord
592 header; we play some tricks with this pointer to make it more
593 bogus, so crashes are more likely to occur right away.)
595 We want freed objects to stay free as long as possible,
596 so instead of doing what we do above, we maintain the
597 free objects in a first-in first-out queue. We also
598 don't recompute the free list each GC, unlike above;
599 this ensures that the queue ordering is preserved.
600 [This means that we are likely to have worse locality
601 of reference, and that we can never free a frob block
602 once it's allocated. (Even if we know that all cells
603 in it are free, there's no easy way to remove all those
604 cells from the free list because the objects on the
605 free list are unlikely to be in memory order.)]
606 Furthermore, we never take objects off the free list
607 unless there's a large number (usually 1000, but
608 varies depending on type) of them already on the list.
609 This way, we ensure that an object that gets freed will
610 remain free for the next 1000 (or whatever) times that
611 an object of that type is allocated. */
613 #ifndef MALLOC_OVERHEAD
615 #define MALLOC_OVERHEAD 0
616 #elif defined (rcheck)
617 #define MALLOC_OVERHEAD 20
619 #define MALLOC_OVERHEAD 8
621 #endif /* MALLOC_OVERHEAD */
623 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
624 /* If we released our reserve (due to running out of memory),
625 and we have a fair amount free once again,
626 try to set aside another reserve in case we run out once more.
628 This is called when a relocatable block is freed in ralloc.c. */
629 void refill_memory_reserve (void);
631 refill_memory_reserve (void)
633 if (breathing_space == 0)
634 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
638 #ifdef ALLOC_NO_POOLS
639 # define TYPE_ALLOC_SIZE(type, structtype) 1
641 # define TYPE_ALLOC_SIZE(type, structtype) \
642 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
643 / sizeof (structtype))
644 #endif /* ALLOC_NO_POOLS */
646 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
648 struct type##_block \
650 struct type##_block *prev; \
651 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
654 static struct type##_block *current_##type##_block; \
655 static int current_##type##_block_index; \
657 static Lisp_Free *type##_free_list; \
658 static Lisp_Free *type##_free_list_tail; \
661 init_##type##_alloc (void) \
663 current_##type##_block = 0; \
664 current_##type##_block_index = \
665 countof (current_##type##_block->block); \
666 type##_free_list = 0; \
667 type##_free_list_tail = 0; \
670 static int gc_count_num_##type##_in_use; \
671 static int gc_count_num_##type##_freelist
673 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
674 if (current_##type##_block_index \
675 == countof (current_##type##_block->block)) \
677 struct type##_block *AFTFB_new = (struct type##_block *) \
678 allocate_lisp_storage (sizeof (struct type##_block)); \
679 AFTFB_new->prev = current_##type##_block; \
680 current_##type##_block = AFTFB_new; \
681 current_##type##_block_index = 0; \
684 &(current_##type##_block->block[current_##type##_block_index++]); \
687 /* Allocate an instance of a type that is stored in blocks.
688 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
691 #ifdef ERROR_CHECK_GC
693 /* Note: if you get crashes in this function, suspect incorrect calls
694 to free_cons() and friends. This happened once because the cons
695 cell was not GC-protected and was getting collected before
696 free_cons() was called. */
698 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
699 if (gc_count_num_##type##_freelist > \
700 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
702 result = (structtype *) type##_free_list; \
703 /* Before actually using the chain pointer, \
704 we complement all its bits; see FREE_FIXED_TYPE(). */ \
705 type##_free_list = (Lisp_Free *) \
706 (~ (EMACS_UINT) (type##_free_list->chain)); \
707 gc_count_num_##type##_freelist--; \
710 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
711 MARK_LRECORD_AS_NOT_FREE (result); \
714 #else /* !ERROR_CHECK_GC */
716 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
717 if (type##_free_list) \
719 result = (structtype *) type##_free_list; \
720 type##_free_list = type##_free_list->chain; \
723 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
724 MARK_LRECORD_AS_NOT_FREE (result); \
727 #endif /* !ERROR_CHECK_GC */
730 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
733 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
734 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
737 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
740 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
741 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
745 /* Lisp_Free is the type to represent a free list member inside a frob
746 block of any lisp object type. */
747 typedef struct Lisp_Free
749 struct lrecord_header lheader;
750 struct Lisp_Free *chain;
753 #define LRECORD_FREE_P(ptr) \
754 ((ptr)->lheader.type == lrecord_type_free)
756 #define MARK_LRECORD_AS_FREE(ptr) \
757 ((void) ((ptr)->lheader.type = lrecord_type_free))
759 #ifdef ERROR_CHECK_GC
760 #define MARK_LRECORD_AS_NOT_FREE(ptr) \
761 ((void) ((ptr)->lheader.type = lrecord_type_undefined))
763 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING
766 #ifdef ERROR_CHECK_GC
768 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
769 if (type##_free_list_tail) \
771 /* When we store the chain pointer, we complement all \
772 its bits; this should significantly increase its \
773 bogosity in case someone tries to use the value, and \
774 should make us crash faster if someone overwrites the \
775 pointer because when it gets un-complemented in \
776 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
777 extremely bogus. */ \
778 type##_free_list_tail->chain = \
779 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \
782 type##_free_list = (Lisp_Free *) (ptr); \
783 type##_free_list_tail = (Lisp_Free *) (ptr); \
786 #else /* !ERROR_CHECK_GC */
788 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
789 ((Lisp_Free *) (ptr))->chain = type##_free_list; \
790 type##_free_list = (Lisp_Free *) (ptr); \
793 #endif /* !ERROR_CHECK_GC */
795 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
797 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
798 structtype *FFT_ptr = (ptr); \
799 ADDITIONAL_FREE_##type (FFT_ptr); \
800 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
801 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
802 MARK_LRECORD_AS_FREE (FFT_ptr); \
805 /* Like FREE_FIXED_TYPE() but used when we are explicitly
806 freeing a structure through free_cons(), free_marker(), etc.
807 rather than through the normal process of sweeping.
808 We attempt to undo the changes made to the allocation counters
809 as a result of this structure being allocated. This is not
810 completely necessary but helps keep things saner: e.g. this way,
811 repeatedly allocating and freeing a cons will not result in
812 the consing-since-gc counter advancing, which would cause a GC
813 and somewhat defeat the purpose of explicitly freeing. */
815 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
816 do { FREE_FIXED_TYPE (type, structtype, ptr); \
817 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
818 gc_count_num_##type##_freelist++; \
823 /************************************************************************/
824 /* Cons allocation */
825 /************************************************************************/
827 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
828 /* conses are used and freed so often that we set this really high */
829 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
830 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
833 mark_cons (Lisp_Object obj)
835 if (NILP (XCDR (obj)))
838 mark_object (XCAR (obj));
843 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
846 while (internal_equal (XCAR (ob1), XCAR (ob2), depth))
850 if (! CONSP (ob1) || ! CONSP (ob2))
851 return internal_equal (ob1, ob2, depth);
856 static const struct lrecord_description cons_description[] = {
857 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
858 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
862 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
863 mark_cons, print_cons, 0,
866 * No `hash' method needed.
867 * internal_hash knows how to
874 DEFUN ("cons", Fcons, 2, 2, 0, /*
875 Create a new cons, give it CAR and CDR as components, and return it.
879 /* This cannot GC. */
883 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
884 set_lheader_implementation (&c->lheader, &lrecord_cons);
891 /* This is identical to Fcons() but it used for conses that we're
892 going to free later, and is useful when trying to track down
895 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
900 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
901 set_lheader_implementation (&c->lheader, &lrecord_cons);
908 DEFUN ("list", Flist, 0, MANY, 0, /*
909 Return a newly created list with specified arguments as elements.
910 Any number of arguments, even zero arguments, are allowed.
912 (int nargs, Lisp_Object *args))
914 Lisp_Object val = Qnil;
915 Lisp_Object *argp = args + nargs;
918 val = Fcons (*--argp, val);
923 list1 (Lisp_Object obj0)
925 /* This cannot GC. */
926 return Fcons (obj0, Qnil);
930 list2 (Lisp_Object obj0, Lisp_Object obj1)
932 /* This cannot GC. */
933 return Fcons (obj0, Fcons (obj1, Qnil));
937 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
939 /* This cannot GC. */
940 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
944 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
946 /* This cannot GC. */
947 return Fcons (obj0, Fcons (obj1, obj2));
951 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
953 return Fcons (Fcons (key, value), alist);
957 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
959 /* This cannot GC. */
960 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
964 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
967 /* This cannot GC. */
968 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
972 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
973 Lisp_Object obj4, Lisp_Object obj5)
975 /* This cannot GC. */
976 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
979 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
980 Return a new list of length LENGTH, with each element being OBJECT.
984 CHECK_NATNUM (length);
987 Lisp_Object val = Qnil;
988 size_t size = XINT (length);
991 val = Fcons (object, val);
997 /************************************************************************/
998 /* Float allocation */
999 /************************************************************************/
1001 #ifdef LISP_FLOAT_TYPE
1003 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
1004 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1007 make_float (double float_value)
1012 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
1014 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1015 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1018 set_lheader_implementation (&f->lheader, &lrecord_float);
1019 float_data (f) = float_value;
1024 #endif /* LISP_FLOAT_TYPE */
1027 /************************************************************************/
1028 /* Vector allocation */
1029 /************************************************************************/
1032 mark_vector (Lisp_Object obj)
1034 Lisp_Vector *ptr = XVECTOR (obj);
1035 int len = vector_length (ptr);
1038 for (i = 0; i < len - 1; i++)
1039 mark_object (ptr->contents[i]);
1040 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1044 size_vector (const void *lheader)
1046 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, contents,
1047 ((Lisp_Vector *) lheader)->size);
1051 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1053 int len = XVECTOR_LENGTH (obj1);
1054 if (len != XVECTOR_LENGTH (obj2))
1058 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1059 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1061 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1068 vector_hash (Lisp_Object obj, int depth)
1070 return HASH2 (XVECTOR_LENGTH (obj),
1071 internal_array_hash (XVECTOR_DATA (obj),
1072 XVECTOR_LENGTH (obj),
1076 static const struct lrecord_description vector_description[] = {
1077 { XD_LONG, offsetof (Lisp_Vector, size) },
1078 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1082 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1083 mark_vector, print_vector, 0,
1087 size_vector, Lisp_Vector);
1089 /* #### should allocate `small' vectors from a frob-block */
1090 static Lisp_Vector *
1091 make_vector_internal (size_t sizei)
1093 /* no vector_next */
1094 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object,
1096 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1103 make_vector (size_t length, Lisp_Object object)
1105 Lisp_Vector *vecp = make_vector_internal (length);
1106 Lisp_Object *p = vector_data (vecp);
1113 XSETVECTOR (vector, vecp);
1118 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1119 Return a new vector of length LENGTH, with each element being OBJECT.
1120 See also the function `vector'.
1124 CONCHECK_NATNUM (length);
1125 return make_vector (XINT (length), object);
1128 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1129 Return a newly created vector with specified arguments as elements.
1130 Any number of arguments, even zero arguments, are allowed.
1132 (int nargs, Lisp_Object *args))
1134 Lisp_Vector *vecp = make_vector_internal (nargs);
1135 Lisp_Object *p = vector_data (vecp);
1142 XSETVECTOR (vector, vecp);
1148 vector1 (Lisp_Object obj0)
1150 return Fvector (1, &obj0);
1154 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1156 Lisp_Object args[2];
1159 return Fvector (2, args);
1163 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1165 Lisp_Object args[3];
1169 return Fvector (3, args);
1172 #if 0 /* currently unused */
1175 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1178 Lisp_Object args[4];
1183 return Fvector (4, args);
1187 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1188 Lisp_Object obj3, Lisp_Object obj4)
1190 Lisp_Object args[5];
1196 return Fvector (5, args);
1200 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1201 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1203 Lisp_Object args[6];
1210 return Fvector (6, args);
1214 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1215 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1218 Lisp_Object args[7];
1226 return Fvector (7, args);
1230 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1231 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1232 Lisp_Object obj6, Lisp_Object obj7)
1234 Lisp_Object args[8];
1243 return Fvector (8, args);
1247 /************************************************************************/
1248 /* Bit Vector allocation */
1249 /************************************************************************/
1251 static Lisp_Object all_bit_vectors;
1253 /* #### should allocate `small' bit vectors from a frob-block */
1254 static Lisp_Bit_Vector *
1255 make_bit_vector_internal (size_t sizei)
1257 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1258 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long,
1260 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1261 set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
1263 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1265 bit_vector_length (p) = sizei;
1266 bit_vector_next (p) = all_bit_vectors;
1267 /* make sure the extra bits in the last long are 0; the calling
1268 functions might not set them. */
1269 p->bits[num_longs - 1] = 0;
1270 XSETBIT_VECTOR (all_bit_vectors, p);
1275 make_bit_vector (size_t length, Lisp_Object bit)
1277 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1278 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1283 memset (p->bits, 0, num_longs * sizeof (long));
1286 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1287 memset (p->bits, ~0, num_longs * sizeof (long));
1288 /* But we have to make sure that the unused bits in the
1289 last long are 0, so that equal/hash is easy. */
1291 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1295 Lisp_Object bit_vector;
1296 XSETBIT_VECTOR (bit_vector, p);
1302 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1305 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1307 for (i = 0; i < length; i++)
1308 set_bit_vector_bit (p, i, bytevec[i]);
1311 Lisp_Object bit_vector;
1312 XSETBIT_VECTOR (bit_vector, p);
1317 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1318 Return a new bit vector of length LENGTH. with each bit set to BIT.
1319 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
1323 CONCHECK_NATNUM (length);
1325 return make_bit_vector (XINT (length), bit);
1328 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1329 Return a newly created bit vector with specified arguments as elements.
1330 Any number of arguments, even zero arguments, are allowed.
1331 Each argument must be one of the integers 0 or 1.
1333 (int nargs, Lisp_Object *args))
1336 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1338 for (i = 0; i < nargs; i++)
1340 CHECK_BIT (args[i]);
1341 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1345 Lisp_Object bit_vector;
1346 XSETBIT_VECTOR (bit_vector, p);
1352 /************************************************************************/
1353 /* Compiled-function allocation */
1354 /************************************************************************/
1356 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1357 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1360 make_compiled_function (void)
1362 Lisp_Compiled_Function *f;
1365 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1366 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
1369 f->specpdl_depth = 0;
1370 f->flags.documentationp = 0;
1371 f->flags.interactivep = 0;
1372 f->flags.domainp = 0; /* I18N3 */
1373 f->instructions = Qzero;
1374 f->constants = Qzero;
1376 f->doc_and_interactive = Qnil;
1377 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1378 f->annotated = Qnil;
1380 XSETCOMPILED_FUNCTION (fun, f);
1384 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1385 Return a new compiled-function object.
1386 Usage: (arglist instructions constants stack-depth
1387 &optional doc-string interactive)
1388 Note that, unlike all other emacs-lisp functions, calling this with five
1389 arguments is NOT the same as calling it with six arguments, the last of
1390 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1391 that this function was defined with `(interactive)'. If the arg is not
1392 specified, then that means the function is not interactive.
1393 This is terrible behavior which is retained for compatibility with old
1394 `.elc' files which expect these semantics.
1396 (int nargs, Lisp_Object *args))
1398 /* In a non-insane world this function would have this arglist...
1399 (arglist instructions constants stack_depth &optional doc_string interactive)
1401 Lisp_Object fun = make_compiled_function ();
1402 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1404 Lisp_Object arglist = args[0];
1405 Lisp_Object instructions = args[1];
1406 Lisp_Object constants = args[2];
1407 Lisp_Object stack_depth = args[3];
1408 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1409 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1411 if (nargs < 4 || nargs > 6)
1412 return Fsignal (Qwrong_number_of_arguments,
1413 list2 (intern ("make-byte-code"), make_int (nargs)));
1415 /* Check for valid formal parameter list now, to allow us to use
1416 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1418 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1420 CHECK_SYMBOL (symbol);
1421 if (EQ (symbol, Qt) ||
1422 EQ (symbol, Qnil) ||
1423 SYMBOL_IS_KEYWORD (symbol))
1424 signal_simple_error_2
1425 ("Invalid constant symbol in formal parameter list",
1429 f->arglist = arglist;
1431 /* `instructions' is a string or a cons (string . int) for a
1432 lazy-loaded function. */
1433 if (CONSP (instructions))
1435 CHECK_STRING (XCAR (instructions));
1436 CHECK_INT (XCDR (instructions));
1440 CHECK_STRING (instructions);
1442 f->instructions = instructions;
1444 if (!NILP (constants))
1445 CHECK_VECTOR (constants);
1446 f->constants = constants;
1448 CHECK_NATNUM (stack_depth);
1449 f->stack_depth = (unsigned short) XINT (stack_depth);
1451 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1452 if (!NILP (Vcurrent_compiled_function_annotation))
1453 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1454 else if (!NILP (Vload_file_name_internal_the_purecopy))
1455 f->annotated = Vload_file_name_internal_the_purecopy;
1456 else if (!NILP (Vload_file_name_internal))
1458 struct gcpro gcpro1;
1459 GCPRO1 (fun); /* don't let fun get reaped */
1460 Vload_file_name_internal_the_purecopy =
1461 Ffile_name_nondirectory (Vload_file_name_internal);
1462 f->annotated = Vload_file_name_internal_the_purecopy;
1465 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1467 /* doc_string may be nil, string, int, or a cons (string . int).
1468 interactive may be list or string (or unbound). */
1469 f->doc_and_interactive = Qunbound;
1471 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1472 f->doc_and_interactive = Vfile_domain;
1474 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1476 f->doc_and_interactive
1477 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1478 Fcons (interactive, f->doc_and_interactive));
1480 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1482 f->doc_and_interactive
1483 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1484 Fcons (doc_string, f->doc_and_interactive));
1486 if (UNBOUNDP (f->doc_and_interactive))
1487 f->doc_and_interactive = Qnil;
1493 /************************************************************************/
1494 /* Symbol allocation */
1495 /************************************************************************/
1497 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1498 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1500 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1501 Return a newly allocated uninterned symbol whose name is NAME.
1502 Its value and function definition are void, and its property list is nil.
1509 CHECK_STRING (name);
1511 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1512 set_lheader_implementation (&p->lheader, &lrecord_symbol);
1513 p->name = XSTRING (name);
1515 p->value = Qunbound;
1516 p->function = Qunbound;
1517 symbol_next (p) = 0;
1518 XSETSYMBOL (val, p);
1523 /************************************************************************/
1524 /* Extent allocation */
1525 /************************************************************************/
1527 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1528 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1531 allocate_extent (void)
1535 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1536 set_lheader_implementation (&e->lheader, &lrecord_extent);
1537 extent_object (e) = Qnil;
1538 set_extent_start (e, -1);
1539 set_extent_end (e, -1);
1544 extent_face (e) = Qnil;
1545 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1546 e->flags.detachable = 1;
1552 /************************************************************************/
1553 /* Event allocation */
1554 /************************************************************************/
1556 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1557 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1560 allocate_event (void)
1565 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1566 set_lheader_implementation (&e->lheader, &lrecord_event);
1573 /************************************************************************/
1574 /* Marker allocation */
1575 /************************************************************************/
1577 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1578 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1580 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1581 Return a new marker which does not point at any place.
1588 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1589 set_lheader_implementation (&p->lheader, &lrecord_marker);
1592 marker_next (p) = 0;
1593 marker_prev (p) = 0;
1594 p->insertion_type = 0;
1595 XSETMARKER (val, p);
1600 noseeum_make_marker (void)
1605 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1606 set_lheader_implementation (&p->lheader, &lrecord_marker);
1609 marker_next (p) = 0;
1610 marker_prev (p) = 0;
1611 p->insertion_type = 0;
1612 XSETMARKER (val, p);
1617 /************************************************************************/
1618 /* String allocation */
1619 /************************************************************************/
1621 /* The data for "short" strings generally resides inside of structs of type
1622 string_chars_block. The Lisp_String structure is allocated just like any
1623 other Lisp object (except for vectors), and these are freelisted when
1624 they get garbage collected. The data for short strings get compacted,
1625 but the data for large strings do not.
1627 Previously Lisp_String structures were relocated, but this caused a lot
1628 of bus-errors because the C code didn't include enough GCPRO's for
1629 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1630 that the reference would get relocated).
1632 This new method makes things somewhat bigger, but it is MUCH safer. */
1634 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1635 /* strings are used and freed quite often */
1636 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1637 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1640 mark_string (Lisp_Object obj)
1642 Lisp_String *ptr = XSTRING (obj);
1644 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1645 flush_cached_extent_info (XCAR (ptr->plist));
1650 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1653 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1654 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1657 static const struct lrecord_description string_description[] = {
1658 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1659 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1660 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1664 /* We store the string's extent info as the first element of the string's
1665 property list; and the string's MODIFF as the first or second element
1666 of the string's property list (depending on whether the extent info
1667 is present), but only if the string has been modified. This is ugly
1668 but it reduces the memory allocated for the string in the vast
1669 majority of cases, where the string is never modified and has no
1672 #### This means you can't use an int as a key in a string's plist. */
1674 static Lisp_Object *
1675 string_plist_ptr (Lisp_Object string)
1677 Lisp_Object *ptr = &XSTRING (string)->plist;
1679 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
1681 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
1687 string_getprop (Lisp_Object string, Lisp_Object property)
1689 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
1693 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
1695 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
1700 string_remprop (Lisp_Object string, Lisp_Object property)
1702 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
1706 string_plist (Lisp_Object string)
1708 return *string_plist_ptr (string);
1711 /* No `finalize', or `hash' methods.
1712 internal_hash() already knows how to hash strings and finalization
1713 is done with the ADDITIONAL_FREE_string macro, which is the
1714 standard way to do finalization when using
1715 SWEEP_FIXED_TYPE_BLOCK(). */
1716 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
1717 mark_string, print_string,
1726 /* String blocks contain this many useful bytes. */
1727 #define STRING_CHARS_BLOCK_SIZE \
1728 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1729 ((2 * sizeof (struct string_chars_block *)) \
1730 + sizeof (EMACS_INT))))
1731 /* Block header for small strings. */
1732 struct string_chars_block
1735 struct string_chars_block *next;
1736 struct string_chars_block *prev;
1737 /* Contents of string_chars_block->string_chars are interleaved
1738 string_chars structures (see below) and the actual string data */
1739 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1742 static struct string_chars_block *first_string_chars_block;
1743 static struct string_chars_block *current_string_chars_block;
1745 /* If SIZE is the length of a string, this returns how many bytes
1746 * the string occupies in string_chars_block->string_chars
1747 * (including alignment padding).
1749 #define STRING_FULLSIZE(size) \
1750 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1751 ALIGNOF (Lisp_String *))
1753 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1754 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1756 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
1757 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
1761 Lisp_String *string;
1762 unsigned char chars[1];
1765 struct unused_string_chars
1767 Lisp_String *string;
1772 init_string_chars_alloc (void)
1774 first_string_chars_block = xnew (struct string_chars_block);
1775 first_string_chars_block->prev = 0;
1776 first_string_chars_block->next = 0;
1777 first_string_chars_block->pos = 0;
1778 current_string_chars_block = first_string_chars_block;
1781 static struct string_chars *
1782 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1785 struct string_chars *s_chars;
1788 (countof (current_string_chars_block->string_chars)
1789 - current_string_chars_block->pos))
1791 /* This string can fit in the current string chars block */
1792 s_chars = (struct string_chars *)
1793 (current_string_chars_block->string_chars
1794 + current_string_chars_block->pos);
1795 current_string_chars_block->pos += fullsize;
1799 /* Make a new current string chars block */
1800 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1802 current_string_chars_block->next = new_scb;
1803 new_scb->prev = current_string_chars_block;
1805 current_string_chars_block = new_scb;
1806 new_scb->pos = fullsize;
1807 s_chars = (struct string_chars *)
1808 current_string_chars_block->string_chars;
1811 s_chars->string = string_it_goes_with;
1813 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1819 make_uninit_string (Bytecount length)
1822 EMACS_INT fullsize = STRING_FULLSIZE (length);
1825 assert (length >= 0 && fullsize > 0);
1827 /* Allocate the string header */
1828 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1829 set_lheader_implementation (&s->lheader, &lrecord_string);
1831 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1832 ? xnew_array (Bufbyte, length + 1)
1833 : allocate_string_chars_struct (s, fullsize)->chars);
1835 set_string_length (s, length);
1838 set_string_byte (s, length, 0);
1840 XSETSTRING (val, s);
1844 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1845 static void verify_string_chars_integrity (void);
1848 /* Resize the string S so that DELTA bytes can be inserted starting
1849 at POS. If DELTA < 0, it means deletion starting at POS. If
1850 POS < 0, resize the string but don't copy any characters. Use
1851 this if you're planning on completely overwriting the string.
1855 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
1857 Bytecount oldfullsize, newfullsize;
1858 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1859 verify_string_chars_integrity ();
1862 #ifdef ERROR_CHECK_BUFPOS
1865 assert (pos <= string_length (s));
1867 assert (pos + (-delta) <= string_length (s));
1872 assert ((-delta) <= string_length (s));
1874 #endif /* ERROR_CHECK_BUFPOS */
1877 /* simplest case: no size change. */
1880 if (pos >= 0 && delta < 0)
1881 /* If DELTA < 0, the functions below will delete the characters
1882 before POS. We want to delete characters *after* POS, however,
1883 so convert this to the appropriate form. */
1886 oldfullsize = STRING_FULLSIZE (string_length (s));
1887 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1889 if (BIG_STRING_FULLSIZE_P (oldfullsize))
1891 if (BIG_STRING_FULLSIZE_P (newfullsize))
1893 /* Both strings are big. We can just realloc().
1894 But careful! If the string is shrinking, we have to
1895 memmove() _before_ realloc(), and if growing, we have to
1896 memmove() _after_ realloc() - otherwise the access is
1897 illegal, and we might crash. */
1898 Bytecount len = string_length (s) + 1 - pos;
1900 if (delta < 0 && pos >= 0)
1901 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1902 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1903 string_length (s) + delta + 1));
1904 if (delta > 0 && pos >= 0)
1905 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1907 else /* String has been demoted from BIG_STRING. */
1910 allocate_string_chars_struct (s, newfullsize)->chars;
1911 Bufbyte *old_data = string_data (s);
1915 memcpy (new_data, old_data, pos);
1916 memcpy (new_data + pos + delta, old_data + pos,
1917 string_length (s) + 1 - pos);
1919 set_string_data (s, new_data);
1923 else /* old string is small */
1925 if (oldfullsize == newfullsize)
1927 /* special case; size change but the necessary
1928 allocation size won't change (up or down; code
1929 somewhere depends on there not being any unused
1930 allocation space, modulo any alignment
1934 Bufbyte *addroff = pos + string_data (s);
1936 memmove (addroff + delta, addroff,
1937 /* +1 due to zero-termination. */
1938 string_length (s) + 1 - pos);
1943 Bufbyte *old_data = string_data (s);
1945 BIG_STRING_FULLSIZE_P (newfullsize)
1946 ? xnew_array (Bufbyte, string_length (s) + delta + 1)
1947 : allocate_string_chars_struct (s, newfullsize)->chars;
1951 memcpy (new_data, old_data, pos);
1952 memcpy (new_data + pos + delta, old_data + pos,
1953 string_length (s) + 1 - pos);
1955 set_string_data (s, new_data);
1958 /* We need to mark this chunk of the string_chars_block
1959 as unused so that compact_string_chars() doesn't
1961 struct string_chars *old_s_chars = (struct string_chars *)
1962 ((char *) old_data - offsetof (struct string_chars, chars));
1963 /* Sanity check to make sure we aren't hosed by strange
1964 alignment/padding. */
1965 assert (old_s_chars->string == s);
1966 MARK_STRING_CHARS_AS_FREE (old_s_chars);
1967 ((struct unused_string_chars *) old_s_chars)->fullsize =
1973 set_string_length (s, string_length (s) + delta);
1974 /* If pos < 0, the string won't be zero-terminated.
1975 Terminate now just to make sure. */
1976 string_data (s)[string_length (s)] = '\0';
1982 XSETSTRING (string, s);
1983 /* We also have to adjust all of the extent indices after the
1984 place we did the change. We say "pos - 1" because
1985 adjust_extents() is exclusive of the starting position
1987 adjust_extents (string, pos - 1, string_length (s),
1991 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1992 verify_string_chars_integrity ();
1999 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2001 Bufbyte newstr[MAX_EMCHAR_LEN];
2002 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2003 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2004 Bytecount newlen = set_charptr_emchar (newstr, c);
2006 if (oldlen != newlen)
2007 resize_string (s, bytoff, newlen - oldlen);
2008 /* Remember, string_data (s) might have changed so we can't cache it. */
2009 memcpy (string_data (s) + bytoff, newstr, newlen);
2014 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2015 Return a new string consisting of LENGTH copies of CHARACTER.
2016 LENGTH must be a non-negative integer.
2018 (length, character))
2020 CHECK_NATNUM (length);
2021 CHECK_CHAR_COERCE_INT (character);
2023 Bufbyte init_str[MAX_EMCHAR_LEN];
2024 int len = set_charptr_emchar (init_str, XCHAR (character));
2025 Lisp_Object val = make_uninit_string (len * XINT (length));
2028 /* Optimize the single-byte case */
2029 memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val));
2033 Bufbyte *ptr = XSTRING_DATA (val);
2035 for (i = XINT (length); i; i--)
2037 Bufbyte *init_ptr = init_str;
2041 case 6: *ptr++ = *init_ptr++;
2042 case 5: *ptr++ = *init_ptr++;
2044 case 4: *ptr++ = *init_ptr++;
2045 case 3: *ptr++ = *init_ptr++;
2046 case 2: *ptr++ = *init_ptr++;
2047 case 1: *ptr++ = *init_ptr++;
2055 DEFUN ("string", Fstring, 0, MANY, 0, /*
2056 Concatenate all the argument characters and make the result a string.
2058 (int nargs, Lisp_Object *args))
2060 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2061 Bufbyte *p = storage;
2063 for (; nargs; nargs--, args++)
2065 Lisp_Object lisp_char = *args;
2066 CHECK_CHAR_COERCE_INT (lisp_char);
2067 p += set_charptr_emchar (p, XCHAR (lisp_char));
2069 return make_string (storage, p - storage);
2073 /* Take some raw memory, which MUST already be in internal format,
2074 and package it up into a Lisp string. */
2076 make_string (const Bufbyte *contents, Bytecount length)
2080 /* Make sure we find out about bad make_string's when they happen */
2081 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2082 bytecount_to_charcount (contents, length); /* Just for the assertions */
2085 val = make_uninit_string (length);
2086 memcpy (XSTRING_DATA (val), contents, length);
2090 /* Take some raw memory, encoded in some external data format,
2091 and convert it into a Lisp string. */
2093 make_ext_string (const Extbyte *contents, EMACS_INT length,
2094 Lisp_Object coding_system)
2097 TO_INTERNAL_FORMAT (DATA, (contents, length),
2098 LISP_STRING, string,
2104 build_string (const char *str)
2106 /* Some strlen's crash and burn if passed null. */
2107 return make_string ((const Bufbyte *) str, (str ? strlen(str) : 0));
2111 build_ext_string (const char *str, Lisp_Object coding_system)
2113 /* Some strlen's crash and burn if passed null. */
2114 return make_ext_string ((const Extbyte *) str, (str ? strlen(str) : 0),
2119 build_translated_string (const char *str)
2121 return build_string (GETTEXT (str));
2125 make_string_nocopy (const Bufbyte *contents, Bytecount length)
2130 /* Make sure we find out about bad make_string_nocopy's when they happen */
2131 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2132 bytecount_to_charcount (contents, length); /* Just for the assertions */
2135 /* Allocate the string header */
2136 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2137 set_lheader_implementation (&s->lheader, &lrecord_string);
2138 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2140 set_string_data (s, (Bufbyte *)contents);
2141 set_string_length (s, length);
2143 XSETSTRING (val, s);
2148 /************************************************************************/
2149 /* lcrecord lists */
2150 /************************************************************************/
2152 /* Lcrecord lists are used to manage the allocation of particular
2153 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2154 malloc() and garbage-collection junk) as much as possible.
2155 It is similar to the Blocktype class.
2159 1) Create an lcrecord-list object using make_lcrecord_list().
2160 This is often done at initialization. Remember to staticpro_nodump
2161 this object! The arguments to make_lcrecord_list() are the
2162 same as would be passed to alloc_lcrecord().
2163 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2164 and pass the lcrecord-list earlier created.
2165 3) When done with the lcrecord, call free_managed_lcrecord().
2166 The standard freeing caveats apply: ** make sure there are no
2167 pointers to the object anywhere! **
2168 4) Calling free_managed_lcrecord() is just like kissing the
2169 lcrecord goodbye as if it were garbage-collected. This means:
2170 -- the contents of the freed lcrecord are undefined, and the
2171 contents of something produced by allocate_managed_lcrecord()
2172 are undefined, just like for alloc_lcrecord().
2173 -- the mark method for the lcrecord's type will *NEVER* be called
2175 -- the finalize method for the lcrecord's type will be called
2176 at the time that free_managed_lcrecord() is called.
2181 mark_lcrecord_list (Lisp_Object obj)
2183 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2184 Lisp_Object chain = list->free;
2186 while (!NILP (chain))
2188 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2189 struct free_lcrecord_header *free_header =
2190 (struct free_lcrecord_header *) lheader;
2193 (/* There should be no other pointers to the free list. */
2194 ! MARKED_RECORD_HEADER_P (lheader)
2196 /* Only lcrecords should be here. */
2197 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
2199 /* Only free lcrecords should be here. */
2200 free_header->lcheader.free
2202 /* The type of the lcrecord must be right. */
2203 LHEADER_IMPLEMENTATION (lheader) == list->implementation
2205 /* So must the size. */
2206 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2207 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
2210 MARK_RECORD_HEADER (lheader);
2211 chain = free_header->chain;
2217 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2218 mark_lcrecord_list, internal_object_printer,
2219 0, 0, 0, 0, struct lcrecord_list);
2221 make_lcrecord_list (size_t size,
2222 const struct lrecord_implementation *implementation)
2224 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2225 &lrecord_lcrecord_list);
2228 p->implementation = implementation;
2231 XSETLCRECORD_LIST (val, p);
2236 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2238 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2239 if (!NILP (list->free))
2241 Lisp_Object val = list->free;
2242 struct free_lcrecord_header *free_header =
2243 (struct free_lcrecord_header *) XPNTR (val);
2245 #ifdef ERROR_CHECK_GC
2246 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2248 /* There should be no other pointers to the free list. */
2249 assert (! MARKED_RECORD_HEADER_P (lheader));
2250 /* Only lcrecords should be here. */
2251 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
2252 /* Only free lcrecords should be here. */
2253 assert (free_header->lcheader.free);
2254 /* The type of the lcrecord must be right. */
2255 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
2256 /* So must the size. */
2257 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2258 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
2259 #endif /* ERROR_CHECK_GC */
2261 list->free = free_header->chain;
2262 free_header->lcheader.free = 0;
2269 XSETOBJ (val, alloc_lcrecord (list->size, list->implementation));
2275 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2277 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2278 struct free_lcrecord_header *free_header =
2279 (struct free_lcrecord_header *) XPNTR (lcrecord);
2280 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2281 const struct lrecord_implementation *implementation
2282 = LHEADER_IMPLEMENTATION (lheader);
2284 /* Make sure the size is correct. This will catch, for example,
2285 putting a window configuration on the wrong free list. */
2286 gc_checking_assert ((implementation->size_in_bytes_method ?
2287 implementation->size_in_bytes_method (lheader) :
2288 implementation->static_size)
2291 if (implementation->finalizer)
2292 implementation->finalizer (lheader, 0);
2293 free_header->chain = list->free;
2294 free_header->lcheader.free = 1;
2295 list->free = lcrecord;
2301 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2302 Kept for compatibility, returns its argument.
2304 Make a copy of OBJECT in pure storage.
2305 Recursively copies contents of vectors and cons cells.
2306 Does not copy symbols.
2314 /************************************************************************/
2315 /* Garbage Collection */
2316 /************************************************************************/
2318 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
2319 Additional ones may be defined by a module (none yet). We leave some
2320 room in `lrecord_implementations_table' for such new lisp object types. */
2321 const struct lrecord_implementation *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT];
2322 unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
2323 /* Object marker functions are in the lrecord_implementation structure.
2324 But copying them to a parallel array is much more cache-friendly.
2325 This hack speeds up (garbage-collect) by about 5%. */
2326 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
2328 struct gcpro *gcprolist;
2330 /* We want the staticpros relocated, but not the pointers found therein.
2331 Hence we use a trivial description, as for pointerless objects. */
2332 static const struct lrecord_description staticpro_description_1[] = {
2336 static const struct struct_description staticpro_description = {
2337 sizeof (Lisp_Object *),
2338 staticpro_description_1
2341 static const struct lrecord_description staticpros_description_1[] = {
2342 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description),
2346 static const struct struct_description staticpros_description = {
2347 sizeof (Lisp_Object_ptr_dynarr),
2348 staticpros_description_1
2351 Lisp_Object_ptr_dynarr *staticpros;
2353 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
2354 garbage collection, and for dumping. */
2356 staticpro (Lisp_Object *varaddress)
2358 Dynarr_add (staticpros, varaddress);
2359 dump_add_root_object (varaddress);
2363 Lisp_Object_ptr_dynarr *staticpros_nodump;
2365 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
2366 garbage collection, but not for dumping. */
2368 staticpro_nodump (Lisp_Object *varaddress)
2370 Dynarr_add (staticpros_nodump, varaddress);
2373 #ifdef ERROR_CHECK_GC
2374 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
2375 struct lrecord_header * GCLI_lh = (lheader); \
2376 assert (GCLI_lh != 0); \
2377 assert (GCLI_lh->type < lrecord_type_count); \
2378 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
2379 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
2380 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
2383 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
2387 /* Mark reference to a Lisp_Object. If the object referred to has not been
2388 seen yet, recursively mark all the references contained in it. */
2391 mark_object (Lisp_Object obj)
2395 /* Checks we used to perform */
2396 /* if (EQ (obj, Qnull_pointer)) return; */
2397 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2398 /* if (PURIFIED (XPNTR (obj))) return; */
2400 if (XTYPE (obj) == Lisp_Type_Record)
2402 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2404 GC_CHECK_LHEADER_INVARIANTS (lheader);
2406 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
2407 ! ((struct lcrecord_header *) lheader)->free);
2409 /* All c_readonly objects have their mark bit set,
2410 so that we only need to check the mark bit here. */
2411 if (! MARKED_RECORD_HEADER_P (lheader))
2413 MARK_RECORD_HEADER (lheader);
2415 if (RECORD_MARKER (lheader))
2417 obj = RECORD_MARKER (lheader) (obj);
2418 if (!NILP (obj)) goto tail_recurse;
2424 /* mark all of the conses in a list and mark the final cdr; but
2425 DO NOT mark the cars.
2427 Use only for internal lists! There should never be other pointers
2428 to the cons cells, because if so, the cars will remain unmarked
2429 even when they maybe should be marked. */
2431 mark_conses_in_list (Lisp_Object obj)
2435 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2437 if (CONS_MARKED_P (XCONS (rest)))
2439 MARK_CONS (XCONS (rest));
2446 /* Find all structures not marked, and free them. */
2448 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2449 static int gc_count_bit_vector_storage;
2450 static int gc_count_num_short_string_in_use;
2451 static int gc_count_string_total_size;
2452 static int gc_count_short_string_total_size;
2454 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2457 /* stats on lcrecords in use - kinda kludgy */
2461 int instances_in_use;
2463 int instances_freed;
2465 int instances_on_free_list;
2466 } lcrecord_stats [countof (lrecord_implementations_table)];
2469 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
2471 unsigned int type_index = h->type;
2473 if (((struct lcrecord_header *) h)->free)
2475 gc_checking_assert (!free_p);
2476 lcrecord_stats[type_index].instances_on_free_list++;
2480 const struct lrecord_implementation *implementation =
2481 LHEADER_IMPLEMENTATION (h);
2483 size_t sz = (implementation->size_in_bytes_method ?
2484 implementation->size_in_bytes_method (h) :
2485 implementation->static_size);
2488 lcrecord_stats[type_index].instances_freed++;
2489 lcrecord_stats[type_index].bytes_freed += sz;
2493 lcrecord_stats[type_index].instances_in_use++;
2494 lcrecord_stats[type_index].bytes_in_use += sz;
2500 /* Free all unmarked records */
2502 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2504 struct lcrecord_header *header;
2506 /* int total_size = 0; */
2508 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2510 /* First go through and call all the finalize methods.
2511 Then go through and free the objects. There used to
2512 be only one loop here, with the call to the finalizer
2513 occurring directly before the xfree() below. That
2514 is marginally faster but much less safe -- if the
2515 finalize method for an object needs to reference any
2516 other objects contained within it (and many do),
2517 we could easily be screwed by having already freed that
2520 for (header = *prev; header; header = header->next)
2522 struct lrecord_header *h = &(header->lheader);
2524 GC_CHECK_LHEADER_INVARIANTS (h);
2526 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
2528 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2529 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2533 for (header = *prev; header; )
2535 struct lrecord_header *h = &(header->lheader);
2536 if (MARKED_RECORD_HEADER_P (h))
2538 if (! C_READONLY_RECORD_HEADER_P (h))
2539 UNMARK_RECORD_HEADER (h);
2541 /* total_size += n->implementation->size_in_bytes (h);*/
2542 /* #### May modify header->next on a C_READONLY lcrecord */
2543 prev = &(header->next);
2545 tick_lcrecord_stats (h, 0);
2549 struct lcrecord_header *next = header->next;
2551 tick_lcrecord_stats (h, 1);
2552 /* used to call finalizer right here. */
2558 /* *total = total_size; */
2563 sweep_bit_vectors_1 (Lisp_Object *prev,
2564 int *used, int *total, int *storage)
2566 Lisp_Object bit_vector;
2569 int total_storage = 0;
2571 /* BIT_VECTORP fails because the objects are marked, which changes
2572 their implementation */
2573 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2575 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2577 if (MARKED_RECORD_P (bit_vector))
2579 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
2580 UNMARK_RECORD_HEADER (&(v->lheader));
2584 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long,
2585 bits, BIT_VECTOR_LONG_STORAGE (len));
2587 /* #### May modify next on a C_READONLY bitvector */
2588 prev = &(bit_vector_next (v));
2593 Lisp_Object next = bit_vector_next (v);
2600 *total = total_size;
2601 *storage = total_storage;
2604 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2605 to make macros prettier. */
2607 #ifdef ERROR_CHECK_GC
2609 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2611 struct typename##_block *SFTB_current; \
2613 int num_free = 0, num_used = 0; \
2615 for (SFTB_current = current_##typename##_block, \
2616 SFTB_limit = current_##typename##_block_index; \
2622 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2624 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2626 if (LRECORD_FREE_P (SFTB_victim)) \
2630 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2634 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2637 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2642 UNMARK_##typename (SFTB_victim); \
2645 SFTB_current = SFTB_current->prev; \
2646 SFTB_limit = countof (current_##typename##_block->block); \
2649 gc_count_num_##typename##_in_use = num_used; \
2650 gc_count_num_##typename##_freelist = num_free; \
2653 #else /* !ERROR_CHECK_GC */
2655 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2657 struct typename##_block *SFTB_current; \
2658 struct typename##_block **SFTB_prev; \
2660 int num_free = 0, num_used = 0; \
2662 typename##_free_list = 0; \
2664 for (SFTB_prev = ¤t_##typename##_block, \
2665 SFTB_current = current_##typename##_block, \
2666 SFTB_limit = current_##typename##_block_index; \
2671 int SFTB_empty = 1; \
2672 Lisp_Free *SFTB_old_free_list = typename##_free_list; \
2674 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2676 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2678 if (LRECORD_FREE_P (SFTB_victim)) \
2681 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2683 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2688 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2691 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2697 UNMARK_##typename (SFTB_victim); \
2702 SFTB_prev = &(SFTB_current->prev); \
2703 SFTB_current = SFTB_current->prev; \
2705 else if (SFTB_current == current_##typename##_block \
2706 && !SFTB_current->prev) \
2708 /* No real point in freeing sole allocation block */ \
2713 struct typename##_block *SFTB_victim_block = SFTB_current; \
2714 if (SFTB_victim_block == current_##typename##_block) \
2715 current_##typename##_block_index \
2716 = countof (current_##typename##_block->block); \
2717 SFTB_current = SFTB_current->prev; \
2719 *SFTB_prev = SFTB_current; \
2720 xfree (SFTB_victim_block); \
2721 /* Restore free list to what it was before victim was swept */ \
2722 typename##_free_list = SFTB_old_free_list; \
2723 num_free -= SFTB_limit; \
2726 SFTB_limit = countof (current_##typename##_block->block); \
2729 gc_count_num_##typename##_in_use = num_used; \
2730 gc_count_num_##typename##_freelist = num_free; \
2733 #endif /* !ERROR_CHECK_GC */
2741 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2742 #define ADDITIONAL_FREE_cons(ptr)
2744 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2747 /* Explicitly free a cons cell. */
2749 free_cons (Lisp_Cons *ptr)
2751 #ifdef ERROR_CHECK_GC
2752 /* If the CAR is not an int, then it will be a pointer, which will
2753 always be four-byte aligned. If this cons cell has already been
2754 placed on the free list, however, its car will probably contain
2755 a chain pointer to the next cons on the list, which has cleverly
2756 had all its 0's and 1's inverted. This allows for a quick
2757 check to make sure we're not freeing something already freed. */
2758 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2759 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2760 #endif /* ERROR_CHECK_GC */
2762 #ifndef ALLOC_NO_POOLS
2763 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2764 #endif /* ALLOC_NO_POOLS */
2767 /* explicitly free a list. You **must make sure** that you have
2768 created all the cons cells that make up this list and that there
2769 are no pointers to any of these cons cells anywhere else. If there
2770 are, you will lose. */
2773 free_list (Lisp_Object list)
2775 Lisp_Object rest, next;
2777 for (rest = list; !NILP (rest); rest = next)
2780 free_cons (XCONS (rest));
2784 /* explicitly free an alist. You **must make sure** that you have
2785 created all the cons cells that make up this alist and that there
2786 are no pointers to any of these cons cells anywhere else. If there
2787 are, you will lose. */
2790 free_alist (Lisp_Object alist)
2792 Lisp_Object rest, next;
2794 for (rest = alist; !NILP (rest); rest = next)
2797 free_cons (XCONS (XCAR (rest)));
2798 free_cons (XCONS (rest));
2803 sweep_compiled_functions (void)
2805 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2806 #define ADDITIONAL_FREE_compiled_function(ptr)
2808 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2812 #ifdef LISP_FLOAT_TYPE
2816 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2817 #define ADDITIONAL_FREE_float(ptr)
2819 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
2821 #endif /* LISP_FLOAT_TYPE */
2824 sweep_symbols (void)
2826 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2827 #define ADDITIONAL_FREE_symbol(ptr)
2829 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
2833 sweep_extents (void)
2835 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2836 #define ADDITIONAL_FREE_extent(ptr)
2838 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2844 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2845 #define ADDITIONAL_FREE_event(ptr)
2847 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
2851 sweep_markers (void)
2853 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2854 #define ADDITIONAL_FREE_marker(ptr) \
2855 do { Lisp_Object tem; \
2856 XSETMARKER (tem, ptr); \
2857 unchain_marker (tem); \
2860 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
2863 /* Explicitly free a marker. */
2865 free_marker (Lisp_Marker *ptr)
2867 /* Perhaps this will catch freeing an already-freed marker. */
2868 gc_checking_assert (ptr->lheader.type == lrecord_type_marker);
2870 #ifndef ALLOC_NO_POOLS
2871 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
2872 #endif /* ALLOC_NO_POOLS */
2876 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2879 verify_string_chars_integrity (void)
2881 struct string_chars_block *sb;
2883 /* Scan each existing string block sequentially, string by string. */
2884 for (sb = first_string_chars_block; sb; sb = sb->next)
2887 /* POS is the index of the next string in the block. */
2888 while (pos < sb->pos)
2890 struct string_chars *s_chars =
2891 (struct string_chars *) &(sb->string_chars[pos]);
2892 Lisp_String *string;
2896 /* If the string_chars struct is marked as free (i.e. the
2897 STRING pointer is NULL) then this is an unused chunk of
2898 string storage. (See below.) */
2900 if (STRING_CHARS_FREE_P (s_chars))
2902 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
2907 string = s_chars->string;
2908 /* Must be 32-bit aligned. */
2909 assert ((((int) string) & 3) == 0);
2911 size = string_length (string);
2912 fullsize = STRING_FULLSIZE (size);
2914 assert (!BIG_STRING_FULLSIZE_P (fullsize));
2915 assert (string_data (string) == s_chars->chars);
2918 assert (pos == sb->pos);
2922 #endif /* MULE && ERROR_CHECK_GC */
2924 /* Compactify string chars, relocating the reference to each --
2925 free any empty string_chars_block we see. */
2927 compact_string_chars (void)
2929 struct string_chars_block *to_sb = first_string_chars_block;
2931 struct string_chars_block *from_sb;
2933 /* Scan each existing string block sequentially, string by string. */
2934 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
2937 /* FROM_POS is the index of the next string in the block. */
2938 while (from_pos < from_sb->pos)
2940 struct string_chars *from_s_chars =
2941 (struct string_chars *) &(from_sb->string_chars[from_pos]);
2942 struct string_chars *to_s_chars;
2943 Lisp_String *string;
2947 /* If the string_chars struct is marked as free (i.e. the
2948 STRING pointer is NULL) then this is an unused chunk of
2949 string storage. This happens under Mule when a string's
2950 size changes in such a way that its fullsize changes.
2951 (Strings can change size because a different-length
2952 character can be substituted for another character.)
2953 In this case, after the bogus string pointer is the
2954 "fullsize" of this entry, i.e. how many bytes to skip. */
2956 if (STRING_CHARS_FREE_P (from_s_chars))
2958 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
2959 from_pos += fullsize;
2963 string = from_s_chars->string;
2964 assert (!(LRECORD_FREE_P (string)));
2966 size = string_length (string);
2967 fullsize = STRING_FULLSIZE (size);
2969 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
2971 /* Just skip it if it isn't marked. */
2972 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
2974 from_pos += fullsize;
2978 /* If it won't fit in what's left of TO_SB, close TO_SB out
2979 and go on to the next string_chars_block. We know that TO_SB
2980 cannot advance past FROM_SB here since FROM_SB is large enough
2981 to currently contain this string. */
2982 if ((to_pos + fullsize) > countof (to_sb->string_chars))
2984 to_sb->pos = to_pos;
2985 to_sb = to_sb->next;
2989 /* Compute new address of this string
2990 and update TO_POS for the space being used. */
2991 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
2993 /* Copy the string_chars to the new place. */
2994 if (from_s_chars != to_s_chars)
2995 memmove (to_s_chars, from_s_chars, fullsize);
2997 /* Relocate FROM_S_CHARS's reference */
2998 set_string_data (string, &(to_s_chars->chars[0]));
3000 from_pos += fullsize;
3005 /* Set current to the last string chars block still used and
3006 free any that follow. */
3008 struct string_chars_block *victim;
3010 for (victim = to_sb->next; victim; )
3012 struct string_chars_block *next = victim->next;
3017 current_string_chars_block = to_sb;
3018 current_string_chars_block->pos = to_pos;
3019 current_string_chars_block->next = 0;
3023 #if 1 /* Hack to debug missing purecopy's */
3024 static int debug_string_purity;
3027 debug_string_purity_print (Lisp_String *p)
3030 Charcount s = string_char_length (p);
3032 for (i = 0; i < s; i++)
3034 Emchar ch = string_char (p, i);
3035 if (ch < 32 || ch >= 126)
3036 stderr_out ("\\%03o", ch);
3037 else if (ch == '\\' || ch == '\"')
3038 stderr_out ("\\%c", ch);
3040 stderr_out ("%c", ch);
3042 stderr_out ("\"\n");
3048 sweep_strings (void)
3050 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3051 int debug = debug_string_purity;
3053 #define UNMARK_string(ptr) do { \
3054 Lisp_String *p = (ptr); \
3055 size_t size = string_length (p); \
3056 UNMARK_RECORD_HEADER (&(p->lheader)); \
3057 num_bytes += size; \
3058 if (!BIG_STRING_SIZE_P (size)) \
3060 num_small_bytes += size; \
3064 debug_string_purity_print (p); \
3066 #define ADDITIONAL_FREE_string(ptr) do { \
3067 size_t size = string_length (ptr); \
3068 if (BIG_STRING_SIZE_P (size)) \
3069 xfree (ptr->data); \
3072 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3074 gc_count_num_short_string_in_use = num_small_used;
3075 gc_count_string_total_size = num_bytes;
3076 gc_count_short_string_total_size = num_small_bytes;
3080 /* I hate duplicating all this crap! */
3082 marked_p (Lisp_Object obj)
3084 /* Checks we used to perform. */
3085 /* if (EQ (obj, Qnull_pointer)) return 1; */
3086 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3087 /* if (PURIFIED (XPNTR (obj))) return 1; */
3089 if (XTYPE (obj) == Lisp_Type_Record)
3091 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3093 GC_CHECK_LHEADER_INVARIANTS (lheader);
3095 return MARKED_RECORD_HEADER_P (lheader);
3103 /* Free all unmarked records. Do this at the very beginning,
3104 before anything else, so that the finalize methods can safely
3105 examine items in the objects. sweep_lcrecords_1() makes
3106 sure to call all the finalize methods *before* freeing anything,
3107 to complete the safety. */
3110 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3113 compact_string_chars ();
3115 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3116 macros) must be *extremely* careful to make sure they're not
3117 referencing freed objects. The only two existing finalize
3118 methods (for strings and markers) pass muster -- the string
3119 finalizer doesn't look at anything but its own specially-
3120 created block, and the marker finalizer only looks at live
3121 buffers (which will never be freed) and at the markers before
3122 and after it in the chain (which, by induction, will never be
3123 freed because if so, they would have already removed themselves
3126 /* Put all unmarked strings on free list, free'ing the string chars
3127 of large unmarked strings */
3130 /* Put all unmarked conses on free list */
3133 /* Free all unmarked bit vectors */
3134 sweep_bit_vectors_1 (&all_bit_vectors,
3135 &gc_count_num_bit_vector_used,
3136 &gc_count_bit_vector_total_size,
3137 &gc_count_bit_vector_storage);
3139 /* Free all unmarked compiled-function objects */
3140 sweep_compiled_functions ();
3142 #ifdef LISP_FLOAT_TYPE
3143 /* Put all unmarked floats on free list */
3147 /* Put all unmarked symbols on free list */
3150 /* Put all unmarked extents on free list */
3153 /* Put all unmarked markers on free list.
3154 Dechain each one first from the buffer into which it points. */
3160 pdump_objects_unmark ();
3164 /* Clearing for disksave. */
3167 disksave_object_finalization (void)
3169 /* It's important that certain information from the environment not get
3170 dumped with the executable (pathnames, environment variables, etc.).
3171 To make it easier to tell when this has happened with strings(1) we
3172 clear some known-to-be-garbage blocks of memory, so that leftover
3173 results of old evaluation don't look like potential problems.
3174 But first we set some notable variables to nil and do one more GC,
3175 to turn those strings into garbage.
3178 /* Yeah, this list is pretty ad-hoc... */
3179 Vprocess_environment = Qnil;
3180 Vexec_directory = Qnil;
3181 Vdata_directory = Qnil;
3182 Vsite_directory = Qnil;
3183 Vdoc_directory = Qnil;
3184 Vconfigure_info_directory = Qnil;
3187 /* Vdump_load_path = Qnil; */
3188 /* Release hash tables for locate_file */
3189 Flocate_file_clear_hashing (Qt);
3190 uncache_home_directory();
3192 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3193 defined(LOADHIST_BUILTIN))
3194 Vload_history = Qnil;
3196 Vshell_file_name = Qnil;
3198 garbage_collect_1 ();
3200 /* Run the disksave finalization methods of all live objects. */
3201 disksave_object_finalization_1 ();
3203 /* Zero out the uninitialized (really, unused) part of the containers
3204 for the live strings. */
3206 struct string_chars_block *scb;
3207 for (scb = first_string_chars_block; scb; scb = scb->next)
3209 int count = sizeof (scb->string_chars) - scb->pos;
3211 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3214 /* from the block's fill ptr to the end */
3215 memset ((scb->string_chars + scb->pos), 0, count);
3220 /* There, that ought to be enough... */
3226 restore_gc_inhibit (Lisp_Object val)
3228 gc_currently_forbidden = XINT (val);
3232 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3233 static int gc_hooks_inhibited;
3237 garbage_collect_1 (void)
3239 #if MAX_SAVE_STACK > 0
3240 char stack_top_variable;
3241 extern char *stack_bottom;
3246 Lisp_Object pre_gc_cursor;
3247 struct gcpro gcpro1;
3250 || gc_currently_forbidden
3252 || preparing_for_armageddon)
3255 /* We used to call selected_frame() here.
3257 The following functions cannot be called inside GC
3258 so we move to after the above tests. */
3261 Lisp_Object device = Fselected_device (Qnil);
3262 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3264 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3266 signal_simple_error ("No frames exist on device", device);
3270 pre_gc_cursor = Qnil;
3273 GCPRO1 (pre_gc_cursor);
3275 /* Very important to prevent GC during any of the following
3276 stuff that might run Lisp code; otherwise, we'll likely
3277 have infinite GC recursion. */
3278 speccount = specpdl_depth ();
3279 record_unwind_protect (restore_gc_inhibit,
3280 make_int (gc_currently_forbidden));
3281 gc_currently_forbidden = 1;
3283 if (!gc_hooks_inhibited)
3284 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3286 /* Now show the GC cursor/message. */
3287 if (!noninteractive)
3289 if (FRAME_WIN_P (f))
3291 Lisp_Object frame = make_frame (f);
3292 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3293 FRAME_SELECTED_WINDOW (f),
3295 pre_gc_cursor = f->pointer;
3296 if (POINTER_IMAGE_INSTANCEP (cursor)
3297 /* don't change if we don't know how to change back. */
3298 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3301 Fset_frame_pointer (frame, cursor);
3305 /* Don't print messages to the stream device. */
3306 if (!cursor_changed && !FRAME_STREAM_P (f))
3308 char *msg = (STRINGP (Vgc_message)
3309 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3311 Lisp_Object args[2], whole_msg;
3312 args[0] = build_string (msg ? msg :
3313 GETTEXT ((const char *) gc_default_message));
3314 args[1] = build_string ("...");
3315 whole_msg = Fconcat (2, args);
3316 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3317 Qgarbage_collecting);
3321 /***** Now we actually start the garbage collection. */
3325 gc_generation_number[0]++;
3327 #if MAX_SAVE_STACK > 0
3329 /* Save a copy of the contents of the stack, for debugging. */
3332 /* Static buffer in which we save a copy of the C stack at each GC. */
3333 static char *stack_copy;
3334 static size_t stack_copy_size;
3336 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3337 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3338 if (stack_size < MAX_SAVE_STACK)
3340 if (stack_copy_size < stack_size)
3342 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3343 stack_copy_size = stack_size;
3347 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3351 #endif /* MAX_SAVE_STACK > 0 */
3353 /* Do some totally ad-hoc resource clearing. */
3354 /* #### generalize this? */
3355 clear_event_resource ();
3356 cleanup_specifiers ();
3358 /* Mark all the special slots that serve as the roots of accessibility. */
3361 Lisp_Object **p = Dynarr_begin (staticpros);
3363 for (count = Dynarr_length (staticpros); count; count--)
3364 mark_object (**p++);
3367 { /* staticpro_nodump() */
3368 Lisp_Object **p = Dynarr_begin (staticpros_nodump);
3370 for (count = Dynarr_length (staticpros_nodump); count; count--)
3371 mark_object (**p++);
3377 for (tail = gcprolist; tail; tail = tail->next)
3378 for (i = 0; i < tail->nvars; i++)
3379 mark_object (tail->var[i]);
3383 struct specbinding *bind;
3384 for (bind = specpdl; bind != specpdl_ptr; bind++)
3386 mark_object (bind->symbol);
3387 mark_object (bind->old_value);
3392 struct catchtag *catch;
3393 for (catch = catchlist; catch; catch = catch->next)
3395 mark_object (catch->tag);
3396 mark_object (catch->val);
3401 struct backtrace *backlist;
3402 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3404 int nargs = backlist->nargs;
3407 mark_object (*backlist->function);
3408 if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */)
3409 mark_object (backlist->args[0]);
3411 for (i = 0; i < nargs; i++)
3412 mark_object (backlist->args[i]);
3417 mark_profiling_info ();
3419 /* OK, now do the after-mark stuff. This is for things that
3420 are only marked when something else is marked (e.g. weak hash tables).
3421 There may be complex dependencies between such objects -- e.g.
3422 a weak hash table might be unmarked, but after processing a later
3423 weak hash table, the former one might get marked. So we have to
3424 iterate until nothing more gets marked. */
3426 while (finish_marking_weak_hash_tables () > 0 ||
3427 finish_marking_weak_lists () > 0)
3430 /* And prune (this needs to be called after everything else has been
3431 marked and before we do any sweeping). */
3432 /* #### this is somewhat ad-hoc and should probably be an object
3434 prune_weak_hash_tables ();
3435 prune_weak_lists ();
3436 prune_specifiers ();
3437 prune_syntax_tables ();
3441 consing_since_gc = 0;
3442 #ifndef DEBUG_XEMACS
3443 /* Allow you to set it really fucking low if you really want ... */
3444 if (gc_cons_threshold < 10000)
3445 gc_cons_threshold = 10000;
3450 /******* End of garbage collection ********/
3452 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3454 /* Now remove the GC cursor/message */
3455 if (!noninteractive)
3458 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3459 else if (!FRAME_STREAM_P (f))
3461 char *msg = (STRINGP (Vgc_message)
3462 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3465 /* Show "...done" only if the echo area would otherwise be empty. */
3466 if (NILP (clear_echo_area (selected_frame (),
3467 Qgarbage_collecting, 0)))
3469 Lisp_Object args[2], whole_msg;
3470 args[0] = build_string (msg ? msg :
3471 GETTEXT ((const char *)
3472 gc_default_message));
3473 args[1] = build_string ("... done");
3474 whole_msg = Fconcat (2, args);
3475 echo_area_message (selected_frame (), (Bufbyte *) 0,
3477 Qgarbage_collecting);
3482 /* now stop inhibiting GC */
3483 unbind_to (speccount, Qnil);
3485 if (!breathing_space)
3487 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3494 /* Debugging aids. */
3497 gc_plist_hack (const char *name, int value, Lisp_Object tail)
3499 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3500 or portable numeric datatypes, or bit-vectors, or characters, or
3501 arrays, or exceptions, or ...) */
3502 return cons3 (intern (name), make_int (value), tail);
3505 #define HACK_O_MATIC(type, name, pl) do { \
3507 struct type##_block *x = current_##type##_block; \
3508 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3509 (pl) = gc_plist_hack ((name), s, (pl)); \
3512 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3513 Reclaim storage for Lisp objects no longer needed.
3514 Return info on amount of space in use:
3515 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3516 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3518 where `PLIST' is a list of alternating keyword/value pairs providing
3519 more detailed information.
3520 Garbage collection happens automatically if you cons more than
3521 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3525 Lisp_Object pl = Qnil;
3527 int gc_count_vector_total_size = 0;
3529 garbage_collect_1 ();
3531 for (i = 0; i < lrecord_type_count; i++)
3533 if (lcrecord_stats[i].bytes_in_use != 0
3534 || lcrecord_stats[i].bytes_freed != 0
3535 || lcrecord_stats[i].instances_on_free_list != 0)
3538 const char *name = lrecord_implementations_table[i]->name;
3539 int len = strlen (name);
3540 /* save this for the FSFmacs-compatible part of the summary */
3541 if (i == lrecord_vector.lrecord_type_index)
3542 gc_count_vector_total_size =
3543 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3545 sprintf (buf, "%s-storage", name);
3546 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3547 /* Okay, simple pluralization check for `symbol-value-varalias' */
3548 if (name[len-1] == 's')
3549 sprintf (buf, "%ses-freed", name);
3551 sprintf (buf, "%ss-freed", name);
3552 if (lcrecord_stats[i].instances_freed != 0)
3553 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3554 if (name[len-1] == 's')
3555 sprintf (buf, "%ses-on-free-list", name);
3557 sprintf (buf, "%ss-on-free-list", name);
3558 if (lcrecord_stats[i].instances_on_free_list != 0)
3559 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3561 if (name[len-1] == 's')
3562 sprintf (buf, "%ses-used", name);
3564 sprintf (buf, "%ss-used", name);
3565 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3569 HACK_O_MATIC (extent, "extent-storage", pl);
3570 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3571 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3572 HACK_O_MATIC (event, "event-storage", pl);
3573 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3574 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3575 HACK_O_MATIC (marker, "marker-storage", pl);
3576 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3577 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3578 #ifdef LISP_FLOAT_TYPE
3579 HACK_O_MATIC (float, "float-storage", pl);
3580 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3581 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3582 #endif /* LISP_FLOAT_TYPE */
3583 HACK_O_MATIC (string, "string-header-storage", pl);
3584 pl = gc_plist_hack ("long-strings-total-length",
3585 gc_count_string_total_size
3586 - gc_count_short_string_total_size, pl);
3587 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3588 pl = gc_plist_hack ("short-strings-total-length",
3589 gc_count_short_string_total_size, pl);
3590 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3591 pl = gc_plist_hack ("long-strings-used",
3592 gc_count_num_string_in_use
3593 - gc_count_num_short_string_in_use, pl);
3594 pl = gc_plist_hack ("short-strings-used",
3595 gc_count_num_short_string_in_use, pl);
3597 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3598 pl = gc_plist_hack ("compiled-functions-free",
3599 gc_count_num_compiled_function_freelist, pl);
3600 pl = gc_plist_hack ("compiled-functions-used",
3601 gc_count_num_compiled_function_in_use, pl);
3603 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3604 pl = gc_plist_hack ("bit-vectors-total-length",
3605 gc_count_bit_vector_total_size, pl);
3606 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3608 HACK_O_MATIC (symbol, "symbol-storage", pl);
3609 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3610 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3612 HACK_O_MATIC (cons, "cons-storage", pl);
3613 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3614 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3616 /* The things we do for backwards-compatibility */
3618 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3619 make_int (gc_count_num_cons_freelist)),
3620 Fcons (make_int (gc_count_num_symbol_in_use),
3621 make_int (gc_count_num_symbol_freelist)),
3622 Fcons (make_int (gc_count_num_marker_in_use),
3623 make_int (gc_count_num_marker_freelist)),
3624 make_int (gc_count_string_total_size),
3625 make_int (gc_count_vector_total_size),
3630 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3631 Return the number of bytes consed since the last garbage collection.
3632 \"Consed\" is a misnomer in that this actually counts allocation
3633 of all different kinds of objects, not just conses.
3635 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3639 return make_int (consing_since_gc);
3643 DEFUN ("memory-limit", Fmemory_limit, 0, 0, 0, /*
3644 Return the address of the last byte Emacs has allocated, divided by 1024.
3645 This may be helpful in debugging Emacs's memory usage.
3646 The value is divided by 1024 to make sure it will fit in a lisp integer.
3650 return make_int ((EMACS_INT) sbrk (0) / 1024);
3656 object_dead_p (Lisp_Object obj)
3658 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3659 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3660 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3661 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3662 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3663 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3664 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3667 #ifdef MEMORY_USAGE_STATS
3669 /* Attempt to determine the actual amount of space that is used for
3670 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3672 It seems that the following holds:
3674 1. When using the old allocator (malloc.c):
3676 -- blocks are always allocated in chunks of powers of two. For
3677 each block, there is an overhead of 8 bytes if rcheck is not
3678 defined, 20 bytes if it is defined. In other words, a
3679 one-byte allocation needs 8 bytes of overhead for a total of
3680 9 bytes, and needs to have 16 bytes of memory chunked out for
3683 2. When using the new allocator (gmalloc.c):
3685 -- blocks are always allocated in chunks of powers of two up
3686 to 4096 bytes. Larger blocks are allocated in chunks of
3687 an integral multiple of 4096 bytes. The minimum block
3688 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3689 is defined. There is no per-block overhead, but there
3690 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3693 3. When using the system malloc, anything goes, but they are
3694 generally slower and more space-efficient than the GNU
3695 allocators. One possibly reasonable assumption to make
3696 for want of better data is that sizeof (void *), or maybe
3697 2 * sizeof (void *), is required as overhead and that
3698 blocks are allocated in the minimum required size except
3699 that some minimum block size is imposed (e.g. 16 bytes). */
3702 malloced_storage_size (void *ptr, size_t claimed_size,
3703 struct overhead_stats *stats)
3705 size_t orig_claimed_size = claimed_size;
3709 if (claimed_size < 2 * sizeof (void *))
3710 claimed_size = 2 * sizeof (void *);
3711 # ifdef SUNOS_LOCALTIME_BUG
3712 if (claimed_size < 16)
3715 if (claimed_size < 4096)
3719 /* compute the log base two, more or less, then use it to compute
3720 the block size needed. */
3722 /* It's big, it's heavy, it's wood! */
3723 while ((claimed_size /= 2) != 0)
3726 /* It's better than bad, it's good! */
3732 /* We have to come up with some average about the amount of
3734 if ((size_t) (rand () & 4095) < claimed_size)
3735 claimed_size += 3 * sizeof (void *);
3739 claimed_size += 4095;
3740 claimed_size &= ~4095;
3741 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3744 #elif defined (SYSTEM_MALLOC)
3746 if (claimed_size < 16)
3748 claimed_size += 2 * sizeof (void *);
3750 #else /* old GNU allocator */
3752 # ifdef rcheck /* #### may not be defined here */
3760 /* compute the log base two, more or less, then use it to compute
3761 the block size needed. */
3763 /* It's big, it's heavy, it's wood! */
3764 while ((claimed_size /= 2) != 0)
3767 /* It's better than bad, it's good! */
3775 #endif /* old GNU allocator */
3779 stats->was_requested += orig_claimed_size;
3780 stats->malloc_overhead += claimed_size - orig_claimed_size;
3782 return claimed_size;
3786 fixed_type_block_overhead (size_t size)
3788 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3789 size_t overhead = 0;
3790 size_t storage_size = malloced_storage_size (0, per_block, 0);
3791 while (size >= per_block)
3794 overhead += sizeof (void *) + per_block - storage_size;
3796 if (rand () % per_block < size)
3797 overhead += sizeof (void *) + per_block - storage_size;
3801 #endif /* MEMORY_USAGE_STATS */
3804 /* Initialization */
3806 reinit_alloc_once_early (void)
3808 gc_generation_number[0] = 0;
3809 breathing_space = 0;
3810 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3811 XSETINT (Vgc_message, 0);
3813 ignore_malloc_warnings = 1;
3814 #ifdef DOUG_LEA_MALLOC
3815 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3816 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3817 #if 0 /* Moved to emacs.c */
3818 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3821 init_string_alloc ();
3822 init_string_chars_alloc ();
3824 init_symbol_alloc ();
3825 init_compiled_function_alloc ();
3826 #ifdef LISP_FLOAT_TYPE
3827 init_float_alloc ();
3828 #endif /* LISP_FLOAT_TYPE */
3829 init_marker_alloc ();
3830 init_extent_alloc ();
3831 init_event_alloc ();
3833 ignore_malloc_warnings = 0;
3835 if (staticpros_nodump)
3836 Dynarr_free (staticpros_nodump);
3837 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3838 Dynarr_resize (staticpros_nodump, 100); /* merely a small optimization */
3840 consing_since_gc = 0;
3842 gc_cons_threshold = 500000; /* XEmacs change */
3844 gc_cons_threshold = 15000; /* debugging */
3846 lrecord_uid_counter = 259;
3847 debug_string_purity = 0;
3850 gc_currently_forbidden = 0;
3851 gc_hooks_inhibited = 0;
3853 #ifdef ERROR_CHECK_TYPECHECK
3854 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3857 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3859 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3861 #endif /* ERROR_CHECK_TYPECHECK */
3865 init_alloc_once_early (void)
3867 reinit_alloc_once_early ();
3871 for (i = 0; i < countof (lrecord_implementations_table); i++)
3872 lrecord_implementations_table[i] = 0;
3875 INIT_LRECORD_IMPLEMENTATION (cons);
3876 INIT_LRECORD_IMPLEMENTATION (vector);
3877 INIT_LRECORD_IMPLEMENTATION (string);
3878 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
3880 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
3881 Dynarr_resize (staticpros, 1410); /* merely a small optimization */
3882 dump_add_root_struct_ptr (&staticpros, &staticpros_description);
3892 syms_of_alloc (void)
3894 DEFSYMBOL (Qpre_gc_hook);
3895 DEFSYMBOL (Qpost_gc_hook);
3896 DEFSYMBOL (Qgarbage_collecting);
3901 DEFSUBR (Fbit_vector);
3902 DEFSUBR (Fmake_byte_code);
3903 DEFSUBR (Fmake_list);
3904 DEFSUBR (Fmake_vector);
3905 DEFSUBR (Fmake_bit_vector);
3906 DEFSUBR (Fmake_string);
3908 DEFSUBR (Fmake_symbol);
3909 DEFSUBR (Fmake_marker);
3910 DEFSUBR (Fpurecopy);
3911 DEFSUBR (Fgarbage_collect);
3913 DEFSUBR (Fmemory_limit);
3915 DEFSUBR (Fconsing_since_gc);
3919 vars_of_alloc (void)
3921 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
3922 *Number of bytes of consing between garbage collections.
3923 \"Consing\" is a misnomer in that this actually counts allocation
3924 of all different kinds of objects, not just conses.
3925 Garbage collection can happen automatically once this many bytes have been
3926 allocated since the last garbage collection. All data types count.
3928 Garbage collection happens automatically when `eval' or `funcall' are
3929 called. (Note that `funcall' is called implicitly as part of evaluation.)
3930 By binding this temporarily to a large number, you can effectively
3931 prevent garbage collection during a part of the program.
3933 See also `consing-since-gc'.
3937 DEFVAR_INT ("debug-allocation", &debug_allocation /*
3938 If non-zero, print out information to stderr about all objects allocated.
3939 See also `debug-allocation-backtrace-length'.
3941 debug_allocation = 0;
3943 DEFVAR_INT ("debug-allocation-backtrace-length",
3944 &debug_allocation_backtrace_length /*
3945 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
3947 debug_allocation_backtrace_length = 2;
3950 DEFVAR_BOOL ("purify-flag", &purify_flag /*
3951 Non-nil means loading Lisp code in order to dump an executable.
3952 This means that certain objects should be allocated in readonly space.
3955 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
3956 Function or functions to be run just before each garbage collection.
3957 Interrupts, garbage collection, and errors are inhibited while this hook
3958 runs, so be extremely careful in what you add here. In particular, avoid
3959 consing, and do not interact with the user.
3961 Vpre_gc_hook = Qnil;
3963 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
3964 Function or functions to be run just after each garbage collection.
3965 Interrupts, garbage collection, and errors are inhibited while this hook
3966 runs, so be extremely careful in what you add here. In particular, avoid
3967 consing, and do not interact with the user.
3969 Vpost_gc_hook = Qnil;
3971 DEFVAR_LISP ("gc-message", &Vgc_message /*
3972 String to print to indicate that a garbage collection is in progress.
3973 This is printed in the echo area. If the selected frame is on a
3974 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
3975 image instance) in the domain of the selected frame, the mouse pointer
3976 will change instead of this message being printed.
3978 Vgc_message = build_string (gc_default_message);
3980 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
3981 Pointer glyph used to indicate that a garbage collection is in progress.
3982 If the selected window is on a window system and this glyph specifies a
3983 value (i.e. a pointer image instance) in the domain of the selected
3984 window, the pointer will be changed as specified during garbage collection.
3985 Otherwise, a message will be printed in the echo area, as controlled
3991 complex_vars_of_alloc (void)
3993 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);