1 /* Storage allocation and gc for XEmacs Lisp interpreter.
2 Copyright (C) 1985-1998 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
4 Copyright (C) 1995, 1996 Ben Wing.
6 This file is part of XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from
28 FSF: Original version; a long time ago.
29 Mly: Significantly rewritten to use new 3-bit tags and
30 nicely abstracted object definitions, for 19.8.
31 JWZ: Improved code to keep track of purespace usage and
32 issue nice purespace and GC stats.
33 Ben Wing: Cleaned up frob-block lrecord code, added error-checking
34 and various changes for Mule, for 19.12.
35 Added bit vectors for 19.13.
36 Added lcrecord lists for 19.14.
37 slb: Lots of work on the purification and dump time code.
38 Synched Doug Lea malloc support from Emacs 20.2.
39 og: Killed the purespace. Portable dumper (moved to dumper.c)
46 #include "backtrace.h"
57 #include "redisplay.h"
58 #include "specifier.h"
62 #include "console-stream.h"
64 #ifdef DOUG_LEA_MALLOC
72 EXFUN (Fgarbage_collect, 0);
74 #if 0 /* this is _way_ too slow to be part of the standard debug options */
75 #if defined(DEBUG_XEMACS) && defined(MULE)
76 #define VERIFY_STRING_CHARS_INTEGRITY
80 /* Define this to use malloc/free with no freelist for all datatypes,
81 the hope being that some debugging tools may help detect
82 freed memory references */
83 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
85 #define ALLOC_NO_POOLS
89 static int debug_allocation;
90 static int debug_allocation_backtrace_length;
93 /* Number of bytes of consing done since the last gc */
94 EMACS_INT consing_since_gc;
95 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
97 #define debug_allocation_backtrace() \
99 if (debug_allocation_backtrace_length > 0) \
100 debug_short_backtrace (debug_allocation_backtrace_length); \
104 #define INCREMENT_CONS_COUNTER(foosize, type) \
106 if (debug_allocation) \
108 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
109 debug_allocation_backtrace (); \
111 INCREMENT_CONS_COUNTER_1 (foosize); \
113 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
115 if (debug_allocation > 1) \
117 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
118 debug_allocation_backtrace (); \
120 INCREMENT_CONS_COUNTER_1 (foosize); \
123 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
124 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
125 INCREMENT_CONS_COUNTER_1 (size)
128 #define DECREMENT_CONS_COUNTER(size) do { \
129 consing_since_gc -= (size); \
130 if (consing_since_gc < 0) \
131 consing_since_gc = 0; \
134 /* Number of bytes of consing since gc before another gc should be done. */
135 EMACS_INT gc_cons_threshold;
137 /* Nonzero during gc */
140 /* Number of times GC has happened at this level or below.
141 * Level 0 is most volatile, contrary to usual convention.
142 * (Of course, there's only one level at present) */
143 EMACS_INT gc_generation_number[1];
145 /* This is just for use by the printer, to allow things to print uniquely */
146 static int lrecord_uid_counter;
148 /* Nonzero when calling certain hooks or doing other things where
150 int gc_currently_forbidden;
153 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
154 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
156 /* "Garbage collecting" */
157 Lisp_Object Vgc_message;
158 Lisp_Object Vgc_pointer_glyph;
159 static const char gc_default_message[] = "Garbage collecting";
160 Lisp_Object Qgarbage_collecting;
162 /* Non-zero means we're in the process of doing the dump */
165 #ifdef ERROR_CHECK_TYPECHECK
167 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
172 c_readonly (Lisp_Object obj)
174 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
178 lisp_readonly (Lisp_Object obj)
180 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
184 /* Maximum amount of C stack to save when a GC happens. */
186 #ifndef MAX_SAVE_STACK
187 #define MAX_SAVE_STACK 0 /* 16000 */
190 /* Non-zero means ignore malloc warnings. Set during initialization. */
191 int ignore_malloc_warnings;
194 static void *breathing_space;
197 release_breathing_space (void)
201 void *tmp = breathing_space;
207 /* malloc calls this if it finds we are near exhausting storage */
209 malloc_warning (const char *str)
211 if (ignore_malloc_warnings)
217 "Killing some buffers may delay running out of memory.\n"
218 "However, certainly by the time you receive the 95%% warning,\n"
219 "you should clean up, kill this Emacs, and start a new one.",
223 /* Called if malloc returns zero */
227 /* Force a GC next time eval is called.
228 It's better to loop garbage-collecting (we might reclaim enough
229 to win) than to loop beeping and barfing "Memory exhausted"
231 consing_since_gc = gc_cons_threshold + 1;
232 release_breathing_space ();
234 /* Flush some histories which might conceivably contain garbalogical
236 if (!NILP (Fboundp (Qvalues)))
237 Fset (Qvalues, Qnil);
238 Vcommand_history = Qnil;
240 error ("Memory exhausted");
243 /* like malloc and realloc but check for no memory left, and block input. */
247 xmalloc (size_t size)
249 void *val = malloc (size);
251 if (!val && (size != 0)) memory_full ();
257 xcalloc (size_t nelem, size_t elsize)
259 void *val = calloc (nelem, elsize);
261 if (!val && (nelem != 0)) memory_full ();
266 xmalloc_and_zero (size_t size)
268 return xcalloc (size, sizeof (char));
273 xrealloc (void *block, size_t size)
275 /* We must call malloc explicitly when BLOCK is 0, since some
276 reallocs don't do this. */
277 void *val = block ? realloc (block, size) : malloc (size);
279 if (!val && (size != 0)) memory_full ();
284 #ifdef ERROR_CHECK_MALLOC
285 xfree_1 (void *block)
290 #ifdef ERROR_CHECK_MALLOC
291 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
292 error until much later on for many system mallocs, such as
293 the one that comes with Solaris 2.3. FMH!! */
294 assert (block != (void *) 0xDEADBEEF);
296 #endif /* ERROR_CHECK_MALLOC */
300 #ifdef ERROR_CHECK_GC
303 typedef unsigned int four_byte_t;
304 #elif SIZEOF_LONG == 4
305 typedef unsigned long four_byte_t;
306 #elif SIZEOF_SHORT == 4
307 typedef unsigned short four_byte_t;
309 What kind of strange-ass system are we running on?
313 deadbeef_memory (void *ptr, size_t size)
315 four_byte_t *ptr4 = (four_byte_t *) ptr;
316 size_t beefs = size >> 2;
318 /* In practice, size will always be a multiple of four. */
320 (*ptr4++) = 0xDEADBEEF;
323 #else /* !ERROR_CHECK_GC */
326 #define deadbeef_memory(ptr, size)
328 #endif /* !ERROR_CHECK_GC */
332 xstrdup (const char *str)
334 int len = strlen (str) + 1; /* for stupid terminating 0 */
336 void *val = xmalloc (len);
337 if (val == 0) return 0;
338 return (char *) memcpy (val, str, len);
343 strdup (const char *s)
347 #endif /* NEED_STRDUP */
351 allocate_lisp_storage (size_t size)
353 return xmalloc (size);
357 /* lcrecords are chained together through their "next" field.
358 After doing the mark phase, GC will walk this linked list
359 and free any lcrecord which hasn't been marked. */
360 static struct lcrecord_header *all_lcrecords;
363 alloc_lcrecord (size_t size, const struct lrecord_implementation *implementation)
365 struct lcrecord_header *lcheader;
368 ((implementation->static_size == 0 ?
369 implementation->size_in_bytes_method != NULL :
370 implementation->static_size == size)
372 (! implementation->basic_p)
374 (! (implementation->hash == NULL && implementation->equal != NULL)));
376 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
377 set_lheader_implementation (&lcheader->lheader, implementation);
378 lcheader->next = all_lcrecords;
379 #if 1 /* mly prefers to see small ID numbers */
380 lcheader->uid = lrecord_uid_counter++;
381 #else /* jwz prefers to see real addrs */
382 lcheader->uid = (int) &lcheader;
385 all_lcrecords = lcheader;
386 INCREMENT_CONS_COUNTER (size, implementation->name);
390 #if 0 /* Presently unused */
391 /* Very, very poor man's EGC?
392 * This may be slow and thrash pages all over the place.
393 * Only call it if you really feel you must (and if the
394 * lrecord was fairly recently allocated).
395 * Otherwise, just let the GC do its job -- that's what it's there for
398 free_lcrecord (struct lcrecord_header *lcrecord)
400 if (all_lcrecords == lcrecord)
402 all_lcrecords = lcrecord->next;
406 struct lrecord_header *header = all_lcrecords;
409 struct lrecord_header *next = header->next;
410 if (next == lcrecord)
412 header->next = lrecord->next;
421 if (lrecord->implementation->finalizer)
422 lrecord->implementation->finalizer (lrecord, 0);
430 disksave_object_finalization_1 (void)
432 struct lcrecord_header *header;
434 for (header = all_lcrecords; header; header = header->next)
436 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
438 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
443 /************************************************************************/
444 /* Debugger support */
445 /************************************************************************/
446 /* Give gdb/dbx enough information to decode Lisp Objects. We make
447 sure certain symbols are always defined, so gdb doesn't complain
448 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
449 to see how this is used. */
451 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
452 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
454 #ifdef USE_UNION_TYPE
455 unsigned char dbg_USE_UNION_TYPE = 1;
457 unsigned char dbg_USE_UNION_TYPE = 0;
460 unsigned char dbg_valbits = VALBITS;
461 unsigned char dbg_gctypebits = GCTYPEBITS;
463 /* Macros turned into functions for ease of debugging.
464 Debuggers don't know about macros! */
465 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
467 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
469 return EQ (obj1, obj2);
473 /************************************************************************/
474 /* Fixed-size type macros */
475 /************************************************************************/
477 /* For fixed-size types that are commonly used, we malloc() large blocks
478 of memory at a time and subdivide them into chunks of the correct
479 size for an object of that type. This is more efficient than
480 malloc()ing each object separately because we save on malloc() time
481 and overhead due to the fewer number of malloc()ed blocks, and
482 also because we don't need any extra pointers within each object
483 to keep them threaded together for GC purposes. For less common
484 (and frequently large-size) types, we use lcrecords, which are
485 malloc()ed individually and chained together through a pointer
486 in the lcrecord header. lcrecords do not need to be fixed-size
487 (i.e. two objects of the same type need not have the same size;
488 however, the size of a particular object cannot vary dynamically).
489 It is also much easier to create a new lcrecord type because no
490 additional code needs to be added to alloc.c. Finally, lcrecords
491 may be more efficient when there are only a small number of them.
493 The types that are stored in these large blocks (or "frob blocks")
494 are cons, float, compiled-function, symbol, marker, extent, event,
497 Note that strings are special in that they are actually stored in
498 two parts: a structure containing information about the string, and
499 the actual data associated with the string. The former structure
500 (a struct Lisp_String) is a fixed-size structure and is managed the
501 same way as all the other such types. This structure contains a
502 pointer to the actual string data, which is stored in structures of
503 type struct string_chars_block. Each string_chars_block consists
504 of a pointer to a struct Lisp_String, followed by the data for that
505 string, followed by another pointer to a Lisp_String, followed by
506 the data for that string, etc. At GC time, the data in these
507 blocks is compacted by searching sequentially through all the
508 blocks and compressing out any holes created by unmarked strings.
509 Strings that are more than a certain size (bigger than the size of
510 a string_chars_block, although something like half as big might
511 make more sense) are malloc()ed separately and not stored in
512 string_chars_blocks. Furthermore, no one string stretches across
513 two string_chars_blocks.
515 Vectors are each malloc()ed separately, similar to lcrecords.
517 In the following discussion, we use conses, but it applies equally
518 well to the other fixed-size types.
520 We store cons cells inside of cons_blocks, allocating a new
521 cons_block with malloc() whenever necessary. Cons cells reclaimed
522 by GC are put on a free list to be reallocated before allocating
523 any new cons cells from the latest cons_block. Each cons_block is
524 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
525 the versions in malloc.c and gmalloc.c) really allocates in units
526 of powers of two and uses 4 bytes for its own overhead.
528 What GC actually does is to search through all the cons_blocks,
529 from the most recently allocated to the oldest, and put all
530 cons cells that are not marked (whether or not they're already
531 free) on a cons_free_list. The cons_free_list is a stack, and
532 so the cons cells in the oldest-allocated cons_block end up
533 at the head of the stack and are the first to be reallocated.
534 If any cons_block is entirely free, it is freed with free()
535 and its cons cells removed from the cons_free_list. Because
536 the cons_free_list ends up basically in memory order, we have
537 a high locality of reference (assuming a reasonable turnover
538 of allocating and freeing) and have a reasonable probability
539 of entirely freeing up cons_blocks that have been more recently
540 allocated. This stage is called the "sweep stage" of GC, and
541 is executed after the "mark stage", which involves starting
542 from all places that are known to point to in-use Lisp objects
543 (e.g. the obarray, where are all symbols are stored; the
544 current catches and condition-cases; the backtrace list of
545 currently executing functions; the gcpro list; etc.) and
546 recursively marking all objects that are accessible.
548 At the beginning of the sweep stage, the conses in the cons
549 blocks are in one of three states: in use and marked, in use
550 but not marked, and not in use (already freed). Any conses
551 that are marked have been marked in the mark stage just
552 executed, because as part of the sweep stage we unmark any
553 marked objects. The way we tell whether or not a cons cell
554 is in use is through the FREE_STRUCT_P macro. This basically
555 looks at the first 4 bytes (or however many bytes a pointer
556 fits in) to see if all the bits in those bytes are 1. The
557 resulting value (0xFFFFFFFF) is not a valid pointer and is
558 not a valid Lisp_Object. All current fixed-size types have
559 a pointer or Lisp_Object as their first element with the
560 exception of strings; they have a size value, which can
561 never be less than zero, and so 0xFFFFFFFF is invalid for
562 strings as well. Now assuming that a cons cell is in use,
563 the way we tell whether or not it is marked is to look at
564 the mark bit of its car (each Lisp_Object has one bit
565 reserved as a mark bit, in case it's needed). Note that
566 different types of objects use different fields to indicate
567 whether the object is marked, but the principle is the same.
569 Conses on the free_cons_list are threaded through a pointer
570 stored in the bytes directly after the bytes that are set
571 to 0xFFFFFFFF (we cannot overwrite these because the cons
572 is still in a cons_block and needs to remain marked as
573 not in use for the next time that GC happens). This
574 implies that all fixed-size types must be at least big
575 enough to store two pointers, which is indeed the case
576 for all current fixed-size types.
578 Some types of objects need additional "finalization" done
579 when an object is converted from in use to not in use;
580 this is the purpose of the ADDITIONAL_FREE_type macro.
581 For example, markers need to be removed from the chain
582 of markers that is kept in each buffer. This is because
583 markers in a buffer automatically disappear if the marker
584 is no longer referenced anywhere (the same does not
585 apply to extents, however).
587 WARNING: Things are in an extremely bizarre state when
588 the ADDITIONAL_FREE_type macros are called, so beware!
590 When ERROR_CHECK_GC is defined, we do things differently
591 so as to maximize our chances of catching places where
592 there is insufficient GCPROing. The thing we want to
593 avoid is having an object that we're using but didn't
594 GCPRO get freed by GC and then reallocated while we're
595 in the process of using it -- this will result in something
596 seemingly unrelated getting trashed, and is extremely
597 difficult to track down. If the object gets freed but
598 not reallocated, we can usually catch this because we
599 set all bytes of a freed object to 0xDEADBEEF. (The
600 first four bytes, however, are 0xFFFFFFFF, and the next
601 four are a pointer used to chain freed objects together;
602 we play some tricks with this pointer to make it more
603 bogus, so crashes are more likely to occur right away.)
605 We want freed objects to stay free as long as possible,
606 so instead of doing what we do above, we maintain the
607 free objects in a first-in first-out queue. We also
608 don't recompute the free list each GC, unlike above;
609 this ensures that the queue ordering is preserved.
610 [This means that we are likely to have worse locality
611 of reference, and that we can never free a frob block
612 once it's allocated. (Even if we know that all cells
613 in it are free, there's no easy way to remove all those
614 cells from the free list because the objects on the
615 free list are unlikely to be in memory order.)]
616 Furthermore, we never take objects off the free list
617 unless there's a large number (usually 1000, but
618 varies depending on type) of them already on the list.
619 This way, we ensure that an object that gets freed will
620 remain free for the next 1000 (or whatever) times that
621 an object of that type is allocated. */
623 #ifndef MALLOC_OVERHEAD
625 #define MALLOC_OVERHEAD 0
626 #elif defined (rcheck)
627 #define MALLOC_OVERHEAD 20
629 #define MALLOC_OVERHEAD 8
631 #endif /* MALLOC_OVERHEAD */
633 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
634 /* If we released our reserve (due to running out of memory),
635 and we have a fair amount free once again,
636 try to set aside another reserve in case we run out once more.
638 This is called when a relocatable block is freed in ralloc.c. */
639 void refill_memory_reserve (void);
641 refill_memory_reserve (void)
643 if (breathing_space == 0)
644 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
648 #ifdef ALLOC_NO_POOLS
649 # define TYPE_ALLOC_SIZE(type, structtype) 1
651 # define TYPE_ALLOC_SIZE(type, structtype) \
652 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
653 / sizeof (structtype))
654 #endif /* ALLOC_NO_POOLS */
656 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
658 struct type##_block \
660 struct type##_block *prev; \
661 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
664 static struct type##_block *current_##type##_block; \
665 static int current_##type##_block_index; \
667 static structtype *type##_free_list; \
668 static structtype *type##_free_list_tail; \
671 init_##type##_alloc (void) \
673 current_##type##_block = 0; \
674 current_##type##_block_index = \
675 countof (current_##type##_block->block); \
676 type##_free_list = 0; \
677 type##_free_list_tail = 0; \
680 static int gc_count_num_##type##_in_use; \
681 static int gc_count_num_##type##_freelist
683 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
684 if (current_##type##_block_index \
685 == countof (current_##type##_block->block)) \
687 struct type##_block *AFTFB_new = (struct type##_block *) \
688 allocate_lisp_storage (sizeof (struct type##_block)); \
689 AFTFB_new->prev = current_##type##_block; \
690 current_##type##_block = AFTFB_new; \
691 current_##type##_block_index = 0; \
694 &(current_##type##_block->block[current_##type##_block_index++]); \
697 /* Allocate an instance of a type that is stored in blocks.
698 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
701 #ifdef ERROR_CHECK_GC
703 /* Note: if you get crashes in this function, suspect incorrect calls
704 to free_cons() and friends. This happened once because the cons
705 cell was not GC-protected and was getting collected before
706 free_cons() was called. */
708 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
711 if (gc_count_num_##type##_freelist > \
712 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
714 result = type##_free_list; \
715 /* Before actually using the chain pointer, we complement all its \
716 bits; see FREE_FIXED_TYPE(). */ \
718 (structtype *) ~(unsigned long) \
719 (* (structtype **) ((char *) result + sizeof (void *))); \
720 gc_count_num_##type##_freelist--; \
723 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
724 MARK_STRUCT_AS_NOT_FREE (result); \
727 #else /* !ERROR_CHECK_GC */
729 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
732 if (type##_free_list) \
734 result = type##_free_list; \
736 * (structtype **) ((char *) result + sizeof (void *)); \
739 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
740 MARK_STRUCT_AS_NOT_FREE (result); \
743 #endif /* !ERROR_CHECK_GC */
745 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
748 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
749 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
752 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
755 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
756 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
759 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
760 to a Lisp object and invalid as an actual Lisp_Object value. We have
761 to make sure that this value cannot be an integer in Lisp_Object form.
762 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
763 On a 32-bit system, the type bits will be non-zero, making the value
764 be a pointer, and the pointer will be misaligned.
766 Even if Emacs is run on some weirdo system that allows and allocates
767 byte-aligned pointers, this pointer is at the very top of the address
768 space and so it's almost inconceivable that it could ever be valid. */
771 # define INVALID_POINTER_VALUE 0xFFFFFFFF
773 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
775 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
777 You have some weird system and need to supply a reasonable value here.
780 /* The construct (* (void **) (ptr)) would cause aliasing problems
781 with modern optimizing compilers like `gcc -O3 -fstrict-aliasing'.
782 But `char *' can legally alias any pointer. Hence this union trick. */
783 typedef union { char c; void *p; } *aliasing_voidpp;
784 #define ALIASING_VOIDPP_DEREFERENCE(ptr) \
785 (((aliasing_voidpp) (ptr))->p)
786 #define FREE_STRUCT_P(ptr) \
787 (ALIASING_VOIDPP_DEREFERENCE (ptr) == (void *) INVALID_POINTER_VALUE)
788 #define MARK_STRUCT_AS_FREE(ptr) \
789 (ALIASING_VOIDPP_DEREFERENCE (ptr) = (void *) INVALID_POINTER_VALUE)
790 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
791 (ALIASING_VOIDPP_DEREFERENCE (ptr) = 0)
793 #ifdef ERROR_CHECK_GC
795 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
796 do { if (type##_free_list_tail) \
798 /* When we store the chain pointer, we complement all \
799 its bits; this should significantly increase its \
800 bogosity in case someone tries to use the value, and \
801 should make us dump faster if someone stores something \
802 over the pointer because when it gets un-complemented in \
803 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
804 extremely bogus. */ \
806 ((char *) type##_free_list_tail + sizeof (void *)) = \
807 (structtype *) ~(unsigned long) ptr; \
810 type##_free_list = ptr; \
811 type##_free_list_tail = ptr; \
814 #else /* !ERROR_CHECK_GC */
816 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
817 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
819 type##_free_list = (ptr); \
822 #endif /* !ERROR_CHECK_GC */
824 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
826 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
827 structtype *FFT_ptr = (ptr); \
828 ADDITIONAL_FREE_##type (FFT_ptr); \
829 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
830 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
831 MARK_STRUCT_AS_FREE (FFT_ptr); \
834 /* Like FREE_FIXED_TYPE() but used when we are explicitly
835 freeing a structure through free_cons(), free_marker(), etc.
836 rather than through the normal process of sweeping.
837 We attempt to undo the changes made to the allocation counters
838 as a result of this structure being allocated. This is not
839 completely necessary but helps keep things saner: e.g. this way,
840 repeatedly allocating and freeing a cons will not result in
841 the consing-since-gc counter advancing, which would cause a GC
842 and somewhat defeat the purpose of explicitly freeing. */
844 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
845 do { FREE_FIXED_TYPE (type, structtype, ptr); \
846 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
847 gc_count_num_##type##_freelist++; \
852 /************************************************************************/
853 /* Cons allocation */
854 /************************************************************************/
856 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
857 /* conses are used and freed so often that we set this really high */
858 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
859 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
862 mark_cons (Lisp_Object obj)
864 if (NILP (XCDR (obj)))
867 mark_object (XCAR (obj));
872 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
875 while (internal_equal (XCAR (ob1), XCAR (ob2), depth))
879 if (! CONSP (ob1) || ! CONSP (ob2))
880 return internal_equal (ob1, ob2, depth);
885 static const struct lrecord_description cons_description[] = {
886 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
887 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
891 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
892 mark_cons, print_cons, 0,
895 * No `hash' method needed.
896 * internal_hash knows how to
903 DEFUN ("cons", Fcons, 2, 2, 0, /*
904 Create a new cons, give it CAR and CDR as components, and return it.
908 /* This cannot GC. */
912 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
913 set_lheader_implementation (&c->lheader, &lrecord_cons);
920 /* This is identical to Fcons() but it used for conses that we're
921 going to free later, and is useful when trying to track down
924 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
929 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
930 set_lheader_implementation (&c->lheader, &lrecord_cons);
937 DEFUN ("list", Flist, 0, MANY, 0, /*
938 Return a newly created list with specified arguments as elements.
939 Any number of arguments, even zero arguments, are allowed.
941 (int nargs, Lisp_Object *args))
943 Lisp_Object val = Qnil;
944 Lisp_Object *argp = args + nargs;
947 val = Fcons (*--argp, val);
952 list1 (Lisp_Object obj0)
954 /* This cannot GC. */
955 return Fcons (obj0, Qnil);
959 list2 (Lisp_Object obj0, Lisp_Object obj1)
961 /* This cannot GC. */
962 return Fcons (obj0, Fcons (obj1, Qnil));
966 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
968 /* This cannot GC. */
969 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
973 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
975 /* This cannot GC. */
976 return Fcons (obj0, Fcons (obj1, obj2));
980 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
982 return Fcons (Fcons (key, value), alist);
986 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
988 /* This cannot GC. */
989 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
993 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
996 /* This cannot GC. */
997 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1001 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1002 Lisp_Object obj4, Lisp_Object obj5)
1004 /* This cannot GC. */
1005 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1008 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1009 Return a new list of length LENGTH, with each element being INIT.
1013 CHECK_NATNUM (length);
1016 Lisp_Object val = Qnil;
1017 size_t size = XINT (length);
1020 val = Fcons (init, val);
1026 /************************************************************************/
1027 /* Float allocation */
1028 /************************************************************************/
1030 #ifdef LISP_FLOAT_TYPE
1032 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
1033 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1036 make_float (double float_value)
1041 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
1043 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1044 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1047 set_lheader_implementation (&f->lheader, &lrecord_float);
1048 float_data (f) = float_value;
1053 #endif /* LISP_FLOAT_TYPE */
1056 /************************************************************************/
1057 /* Vector allocation */
1058 /************************************************************************/
1061 mark_vector (Lisp_Object obj)
1063 Lisp_Vector *ptr = XVECTOR (obj);
1064 int len = vector_length (ptr);
1067 for (i = 0; i < len - 1; i++)
1068 mark_object (ptr->contents[i]);
1069 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1073 size_vector (const void *lheader)
1075 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, contents,
1076 ((Lisp_Vector *) lheader)->size);
1080 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1082 int len = XVECTOR_LENGTH (obj1);
1083 if (len != XVECTOR_LENGTH (obj2))
1087 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1088 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1090 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1097 vector_hash (Lisp_Object obj, int depth)
1099 return HASH2 (XVECTOR_LENGTH (obj),
1100 internal_array_hash (XVECTOR_DATA (obj),
1101 XVECTOR_LENGTH (obj),
1105 static const struct lrecord_description vector_description[] = {
1106 { XD_LONG, offsetof (Lisp_Vector, size) },
1107 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1111 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1112 mark_vector, print_vector, 0,
1116 size_vector, Lisp_Vector);
1118 /* #### should allocate `small' vectors from a frob-block */
1119 static Lisp_Vector *
1120 make_vector_internal (size_t sizei)
1122 /* no vector_next */
1123 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1124 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1131 make_vector (size_t length, Lisp_Object init)
1133 Lisp_Vector *vecp = make_vector_internal (length);
1134 Lisp_Object *p = vector_data (vecp);
1141 XSETVECTOR (vector, vecp);
1146 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1147 Return a new vector of length LENGTH, with each element being INIT.
1148 See also the function `vector'.
1152 CONCHECK_NATNUM (length);
1153 return make_vector (XINT (length), init);
1156 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1157 Return a newly created vector with specified arguments as elements.
1158 Any number of arguments, even zero arguments, are allowed.
1160 (int nargs, Lisp_Object *args))
1162 Lisp_Vector *vecp = make_vector_internal (nargs);
1163 Lisp_Object *p = vector_data (vecp);
1170 XSETVECTOR (vector, vecp);
1176 vector1 (Lisp_Object obj0)
1178 return Fvector (1, &obj0);
1182 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1184 Lisp_Object args[2];
1187 return Fvector (2, args);
1191 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1193 Lisp_Object args[3];
1197 return Fvector (3, args);
1200 #if 0 /* currently unused */
1203 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1206 Lisp_Object args[4];
1211 return Fvector (4, args);
1215 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1216 Lisp_Object obj3, Lisp_Object obj4)
1218 Lisp_Object args[5];
1224 return Fvector (5, args);
1228 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1229 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1231 Lisp_Object args[6];
1238 return Fvector (6, args);
1242 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1243 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1246 Lisp_Object args[7];
1254 return Fvector (7, args);
1258 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1259 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1260 Lisp_Object obj6, Lisp_Object obj7)
1262 Lisp_Object args[8];
1271 return Fvector (8, args);
1275 /************************************************************************/
1276 /* Bit Vector allocation */
1277 /************************************************************************/
1279 static Lisp_Object all_bit_vectors;
1281 /* #### should allocate `small' bit vectors from a frob-block */
1282 static Lisp_Bit_Vector *
1283 make_bit_vector_internal (size_t sizei)
1285 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1286 size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1287 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1288 set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
1290 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1292 bit_vector_length (p) = sizei;
1293 bit_vector_next (p) = all_bit_vectors;
1294 /* make sure the extra bits in the last long are 0; the calling
1295 functions might not set them. */
1296 p->bits[num_longs - 1] = 0;
1297 XSETBIT_VECTOR (all_bit_vectors, p);
1302 make_bit_vector (size_t length, Lisp_Object init)
1304 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1305 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1310 memset (p->bits, 0, num_longs * sizeof (long));
1313 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1314 memset (p->bits, ~0, num_longs * sizeof (long));
1315 /* But we have to make sure that the unused bits in the
1316 last long are 0, so that equal/hash is easy. */
1318 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1322 Lisp_Object bit_vector;
1323 XSETBIT_VECTOR (bit_vector, p);
1329 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1332 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1334 for (i = 0; i < length; i++)
1335 set_bit_vector_bit (p, i, bytevec[i]);
1338 Lisp_Object bit_vector;
1339 XSETBIT_VECTOR (bit_vector, p);
1344 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1345 Return a new bit vector of length LENGTH. with each bit being INIT.
1346 Each element is set to INIT. See also the function `bit-vector'.
1350 CONCHECK_NATNUM (length);
1352 return make_bit_vector (XINT (length), init);
1355 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1356 Return a newly created bit vector with specified arguments as elements.
1357 Any number of arguments, even zero arguments, are allowed.
1359 (int nargs, Lisp_Object *args))
1362 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1364 for (i = 0; i < nargs; i++)
1366 CHECK_BIT (args[i]);
1367 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1371 Lisp_Object bit_vector;
1372 XSETBIT_VECTOR (bit_vector, p);
1378 /************************************************************************/
1379 /* Compiled-function allocation */
1380 /************************************************************************/
1382 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1383 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1386 make_compiled_function (void)
1388 Lisp_Compiled_Function *f;
1391 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1392 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
1395 f->specpdl_depth = 0;
1396 f->flags.documentationp = 0;
1397 f->flags.interactivep = 0;
1398 f->flags.domainp = 0; /* I18N3 */
1399 f->instructions = Qzero;
1400 f->constants = Qzero;
1402 f->doc_and_interactive = Qnil;
1403 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1404 f->annotated = Qnil;
1406 XSETCOMPILED_FUNCTION (fun, f);
1410 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1411 Return a new compiled-function object.
1412 Usage: (arglist instructions constants stack-depth
1413 &optional doc-string interactive)
1414 Note that, unlike all other emacs-lisp functions, calling this with five
1415 arguments is NOT the same as calling it with six arguments, the last of
1416 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1417 that this function was defined with `(interactive)'. If the arg is not
1418 specified, then that means the function is not interactive.
1419 This is terrible behavior which is retained for compatibility with old
1420 `.elc' files which expect these semantics.
1422 (int nargs, Lisp_Object *args))
1424 /* In a non-insane world this function would have this arglist...
1425 (arglist instructions constants stack_depth &optional doc_string interactive)
1427 Lisp_Object fun = make_compiled_function ();
1428 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1430 Lisp_Object arglist = args[0];
1431 Lisp_Object instructions = args[1];
1432 Lisp_Object constants = args[2];
1433 Lisp_Object stack_depth = args[3];
1434 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1435 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1437 if (nargs < 4 || nargs > 6)
1438 return Fsignal (Qwrong_number_of_arguments,
1439 list2 (intern ("make-byte-code"), make_int (nargs)));
1441 /* Check for valid formal parameter list now, to allow us to use
1442 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1444 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1446 CHECK_SYMBOL (symbol);
1447 if (EQ (symbol, Qt) ||
1448 EQ (symbol, Qnil) ||
1449 SYMBOL_IS_KEYWORD (symbol))
1450 signal_simple_error_2
1451 ("Invalid constant symbol in formal parameter list",
1455 f->arglist = arglist;
1457 /* `instructions' is a string or a cons (string . int) for a
1458 lazy-loaded function. */
1459 if (CONSP (instructions))
1461 CHECK_STRING (XCAR (instructions));
1462 CHECK_INT (XCDR (instructions));
1466 CHECK_STRING (instructions);
1468 f->instructions = instructions;
1470 if (!NILP (constants))
1471 CHECK_VECTOR (constants);
1472 f->constants = constants;
1474 CHECK_NATNUM (stack_depth);
1475 f->stack_depth = (unsigned short) XINT (stack_depth);
1477 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1478 if (!NILP (Vcurrent_compiled_function_annotation))
1479 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1480 else if (!NILP (Vload_file_name_internal_the_purecopy))
1481 f->annotated = Vload_file_name_internal_the_purecopy;
1482 else if (!NILP (Vload_file_name_internal))
1484 struct gcpro gcpro1;
1485 GCPRO1 (fun); /* don't let fun get reaped */
1486 Vload_file_name_internal_the_purecopy =
1487 Ffile_name_nondirectory (Vload_file_name_internal);
1488 f->annotated = Vload_file_name_internal_the_purecopy;
1491 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1493 /* doc_string may be nil, string, int, or a cons (string . int).
1494 interactive may be list or string (or unbound). */
1495 f->doc_and_interactive = Qunbound;
1497 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1498 f->doc_and_interactive = Vfile_domain;
1500 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1502 f->doc_and_interactive
1503 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1504 Fcons (interactive, f->doc_and_interactive));
1506 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1508 f->doc_and_interactive
1509 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1510 Fcons (doc_string, f->doc_and_interactive));
1512 if (UNBOUNDP (f->doc_and_interactive))
1513 f->doc_and_interactive = Qnil;
1519 /************************************************************************/
1520 /* Symbol allocation */
1521 /************************************************************************/
1523 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1524 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1526 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1527 Return a newly allocated uninterned symbol whose name is NAME.
1528 Its value and function definition are void, and its property list is nil.
1535 CHECK_STRING (name);
1537 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1538 set_lheader_implementation (&p->lheader, &lrecord_symbol);
1539 p->name = XSTRING (name);
1541 p->value = Qunbound;
1542 p->function = Qunbound;
1543 symbol_next (p) = 0;
1544 XSETSYMBOL (val, p);
1549 /************************************************************************/
1550 /* Extent allocation */
1551 /************************************************************************/
1553 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1554 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1557 allocate_extent (void)
1561 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1562 set_lheader_implementation (&e->lheader, &lrecord_extent);
1563 extent_object (e) = Qnil;
1564 set_extent_start (e, -1);
1565 set_extent_end (e, -1);
1570 extent_face (e) = Qnil;
1571 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1572 e->flags.detachable = 1;
1578 /************************************************************************/
1579 /* Event allocation */
1580 /************************************************************************/
1582 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1583 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1586 allocate_event (void)
1591 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1592 set_lheader_implementation (&e->lheader, &lrecord_event);
1599 /************************************************************************/
1600 /* Marker allocation */
1601 /************************************************************************/
1603 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1604 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1606 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1607 Return a new marker which does not point at any place.
1614 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1615 set_lheader_implementation (&p->lheader, &lrecord_marker);
1618 marker_next (p) = 0;
1619 marker_prev (p) = 0;
1620 p->insertion_type = 0;
1621 XSETMARKER (val, p);
1626 noseeum_make_marker (void)
1631 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1632 set_lheader_implementation (&p->lheader, &lrecord_marker);
1635 marker_next (p) = 0;
1636 marker_prev (p) = 0;
1637 p->insertion_type = 0;
1638 XSETMARKER (val, p);
1643 /************************************************************************/
1644 /* String allocation */
1645 /************************************************************************/
1647 /* The data for "short" strings generally resides inside of structs of type
1648 string_chars_block. The Lisp_String structure is allocated just like any
1649 other Lisp object (except for vectors), and these are freelisted when
1650 they get garbage collected. The data for short strings get compacted,
1651 but the data for large strings do not.
1653 Previously Lisp_String structures were relocated, but this caused a lot
1654 of bus-errors because the C code didn't include enough GCPRO's for
1655 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1656 that the reference would get relocated).
1658 This new method makes things somewhat bigger, but it is MUCH safer. */
1660 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1661 /* strings are used and freed quite often */
1662 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1663 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1666 mark_string (Lisp_Object obj)
1668 Lisp_String *ptr = XSTRING (obj);
1670 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1671 flush_cached_extent_info (XCAR (ptr->plist));
1676 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1679 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1680 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1683 static const struct lrecord_description string_description[] = {
1684 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1685 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1686 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1690 /* We store the string's extent info as the first element of the string's
1691 property list; and the string's MODIFF as the first or second element
1692 of the string's property list (depending on whether the extent info
1693 is present), but only if the string has been modified. This is ugly
1694 but it reduces the memory allocated for the string in the vast
1695 majority of cases, where the string is never modified and has no
1698 #### This means you can't use an int as a key in a string's plist. */
1700 static Lisp_Object *
1701 string_plist_ptr (Lisp_Object string)
1703 Lisp_Object *ptr = &XSTRING (string)->plist;
1705 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
1707 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
1713 string_getprop (Lisp_Object string, Lisp_Object property)
1715 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
1719 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
1721 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
1726 string_remprop (Lisp_Object string, Lisp_Object property)
1728 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
1732 string_plist (Lisp_Object string)
1734 return *string_plist_ptr (string);
1737 /* No `finalize', or `hash' methods.
1738 internal_hash() already knows how to hash strings and finalization
1739 is done with the ADDITIONAL_FREE_string macro, which is the
1740 standard way to do finalization when using
1741 SWEEP_FIXED_TYPE_BLOCK(). */
1742 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
1743 mark_string, print_string,
1752 /* String blocks contain this many useful bytes. */
1753 #define STRING_CHARS_BLOCK_SIZE \
1754 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1755 ((2 * sizeof (struct string_chars_block *)) \
1756 + sizeof (EMACS_INT))))
1757 /* Block header for small strings. */
1758 struct string_chars_block
1761 struct string_chars_block *next;
1762 struct string_chars_block *prev;
1763 /* Contents of string_chars_block->string_chars are interleaved
1764 string_chars structures (see below) and the actual string data */
1765 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1768 static struct string_chars_block *first_string_chars_block;
1769 static struct string_chars_block *current_string_chars_block;
1771 /* If SIZE is the length of a string, this returns how many bytes
1772 * the string occupies in string_chars_block->string_chars
1773 * (including alignment padding).
1775 #define STRING_FULLSIZE(size) \
1776 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1777 ALIGNOF (Lisp_String *))
1779 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1780 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1784 Lisp_String *string;
1785 unsigned char chars[1];
1788 struct unused_string_chars
1790 Lisp_String *string;
1795 init_string_chars_alloc (void)
1797 first_string_chars_block = xnew (struct string_chars_block);
1798 first_string_chars_block->prev = 0;
1799 first_string_chars_block->next = 0;
1800 first_string_chars_block->pos = 0;
1801 current_string_chars_block = first_string_chars_block;
1804 static struct string_chars *
1805 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1808 struct string_chars *s_chars;
1811 (countof (current_string_chars_block->string_chars)
1812 - current_string_chars_block->pos))
1814 /* This string can fit in the current string chars block */
1815 s_chars = (struct string_chars *)
1816 (current_string_chars_block->string_chars
1817 + current_string_chars_block->pos);
1818 current_string_chars_block->pos += fullsize;
1822 /* Make a new current string chars block */
1823 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1825 current_string_chars_block->next = new_scb;
1826 new_scb->prev = current_string_chars_block;
1828 current_string_chars_block = new_scb;
1829 new_scb->pos = fullsize;
1830 s_chars = (struct string_chars *)
1831 current_string_chars_block->string_chars;
1834 s_chars->string = string_it_goes_with;
1836 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1842 make_uninit_string (Bytecount length)
1845 EMACS_INT fullsize = STRING_FULLSIZE (length);
1848 assert (length >= 0 && fullsize > 0);
1850 /* Allocate the string header */
1851 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1852 set_lheader_implementation (&s->lheader, &lrecord_string);
1854 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1855 ? xnew_array (Bufbyte, length + 1)
1856 : allocate_string_chars_struct (s, fullsize)->chars);
1858 set_string_length (s, length);
1861 set_string_byte (s, length, 0);
1863 XSETSTRING (val, s);
1867 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1868 static void verify_string_chars_integrity (void);
1871 /* Resize the string S so that DELTA bytes can be inserted starting
1872 at POS. If DELTA < 0, it means deletion starting at POS. If
1873 POS < 0, resize the string but don't copy any characters. Use
1874 this if you're planning on completely overwriting the string.
1878 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
1880 Bytecount oldfullsize, newfullsize;
1881 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1882 verify_string_chars_integrity ();
1885 #ifdef ERROR_CHECK_BUFPOS
1888 assert (pos <= string_length (s));
1890 assert (pos + (-delta) <= string_length (s));
1895 assert ((-delta) <= string_length (s));
1897 #endif /* ERROR_CHECK_BUFPOS */
1900 /* simplest case: no size change. */
1903 if (pos >= 0 && delta < 0)
1904 /* If DELTA < 0, the functions below will delete the characters
1905 before POS. We want to delete characters *after* POS, however,
1906 so convert this to the appropriate form. */
1909 oldfullsize = STRING_FULLSIZE (string_length (s));
1910 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1912 if (BIG_STRING_FULLSIZE_P (oldfullsize))
1914 if (BIG_STRING_FULLSIZE_P (newfullsize))
1916 /* Both strings are big. We can just realloc().
1917 But careful! If the string is shrinking, we have to
1918 memmove() _before_ realloc(), and if growing, we have to
1919 memmove() _after_ realloc() - otherwise the access is
1920 illegal, and we might crash. */
1921 Bytecount len = string_length (s) + 1 - pos;
1923 if (delta < 0 && pos >= 0)
1924 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1925 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1926 string_length (s) + delta + 1));
1927 if (delta > 0 && pos >= 0)
1928 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1930 else /* String has been demoted from BIG_STRING. */
1933 allocate_string_chars_struct (s, newfullsize)->chars;
1934 Bufbyte *old_data = string_data (s);
1938 memcpy (new_data, old_data, pos);
1939 memcpy (new_data + pos + delta, old_data + pos,
1940 string_length (s) + 1 - pos);
1942 set_string_data (s, new_data);
1946 else /* old string is small */
1948 if (oldfullsize == newfullsize)
1950 /* special case; size change but the necessary
1951 allocation size won't change (up or down; code
1952 somewhere depends on there not being any unused
1953 allocation space, modulo any alignment
1957 Bufbyte *addroff = pos + string_data (s);
1959 memmove (addroff + delta, addroff,
1960 /* +1 due to zero-termination. */
1961 string_length (s) + 1 - pos);
1966 Bufbyte *old_data = string_data (s);
1968 BIG_STRING_FULLSIZE_P (newfullsize)
1969 ? xnew_array (Bufbyte, string_length (s) + delta + 1)
1970 : allocate_string_chars_struct (s, newfullsize)->chars;
1974 memcpy (new_data, old_data, pos);
1975 memcpy (new_data + pos + delta, old_data + pos,
1976 string_length (s) + 1 - pos);
1978 set_string_data (s, new_data);
1981 /* We need to mark this chunk of the string_chars_block
1982 as unused so that compact_string_chars() doesn't
1984 struct string_chars *old_s_chars = (struct string_chars *)
1985 ((char *) old_data - offsetof (struct string_chars, chars));
1986 /* Sanity check to make sure we aren't hosed by strange
1987 alignment/padding. */
1988 assert (old_s_chars->string == s);
1989 MARK_STRUCT_AS_FREE (old_s_chars);
1990 ((struct unused_string_chars *) old_s_chars)->fullsize =
1996 set_string_length (s, string_length (s) + delta);
1997 /* If pos < 0, the string won't be zero-terminated.
1998 Terminate now just to make sure. */
1999 string_data (s)[string_length (s)] = '\0';
2005 XSETSTRING (string, s);
2006 /* We also have to adjust all of the extent indices after the
2007 place we did the change. We say "pos - 1" because
2008 adjust_extents() is exclusive of the starting position
2010 adjust_extents (string, pos - 1, string_length (s),
2014 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2015 verify_string_chars_integrity ();
2022 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2024 Bufbyte newstr[MAX_EMCHAR_LEN];
2025 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2026 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2027 Bytecount newlen = set_charptr_emchar (newstr, c);
2029 if (oldlen != newlen)
2030 resize_string (s, bytoff, newlen - oldlen);
2031 /* Remember, string_data (s) might have changed so we can't cache it. */
2032 memcpy (string_data (s) + bytoff, newstr, newlen);
2037 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2038 Return a new string of length LENGTH, with each character being INIT.
2039 LENGTH must be an integer and INIT must be a character.
2043 CHECK_NATNUM (length);
2044 CHECK_CHAR_COERCE_INT (init);
2046 Bufbyte init_str[MAX_EMCHAR_LEN];
2047 int len = set_charptr_emchar (init_str, XCHAR (init));
2048 Lisp_Object val = make_uninit_string (len * XINT (length));
2051 /* Optimize the single-byte case */
2052 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2056 Bufbyte *ptr = XSTRING_DATA (val);
2058 for (i = XINT (length); i; i--)
2060 Bufbyte *init_ptr = init_str;
2063 case 4: *ptr++ = *init_ptr++;
2064 case 3: *ptr++ = *init_ptr++;
2065 case 2: *ptr++ = *init_ptr++;
2066 case 1: *ptr++ = *init_ptr++;
2074 DEFUN ("string", Fstring, 0, MANY, 0, /*
2075 Concatenate all the argument characters and make the result a string.
2077 (int nargs, Lisp_Object *args))
2079 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2080 Bufbyte *p = storage;
2082 for (; nargs; nargs--, args++)
2084 Lisp_Object lisp_char = *args;
2085 CHECK_CHAR_COERCE_INT (lisp_char);
2086 p += set_charptr_emchar (p, XCHAR (lisp_char));
2088 return make_string (storage, p - storage);
2092 /* Take some raw memory, which MUST already be in internal format,
2093 and package it up into a Lisp string. */
2095 make_string (const Bufbyte *contents, Bytecount length)
2099 /* Make sure we find out about bad make_string's when they happen */
2100 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2101 bytecount_to_charcount (contents, length); /* Just for the assertions */
2104 val = make_uninit_string (length);
2105 memcpy (XSTRING_DATA (val), contents, length);
2109 /* Take some raw memory, encoded in some external data format,
2110 and convert it into a Lisp string. */
2112 make_ext_string (const Extbyte *contents, EMACS_INT length,
2113 Lisp_Object coding_system)
2116 TO_INTERNAL_FORMAT (DATA, (contents, length),
2117 LISP_STRING, string,
2123 build_string (const char *str)
2125 /* Some strlen's crash and burn if passed null. */
2126 return make_string ((const Bufbyte *) str, (str ? strlen(str) : 0));
2130 build_ext_string (const char *str, Lisp_Object coding_system)
2132 /* Some strlen's crash and burn if passed null. */
2133 return make_ext_string ((const Extbyte *) str, (str ? strlen(str) : 0),
2138 build_translated_string (const char *str)
2140 return build_string (GETTEXT (str));
2144 make_string_nocopy (const Bufbyte *contents, Bytecount length)
2149 /* Make sure we find out about bad make_string_nocopy's when they happen */
2150 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2151 bytecount_to_charcount (contents, length); /* Just for the assertions */
2154 /* Allocate the string header */
2155 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2156 set_lheader_implementation (&s->lheader, &lrecord_string);
2157 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2159 set_string_data (s, (Bufbyte *)contents);
2160 set_string_length (s, length);
2162 XSETSTRING (val, s);
2167 /************************************************************************/
2168 /* lcrecord lists */
2169 /************************************************************************/
2171 /* Lcrecord lists are used to manage the allocation of particular
2172 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2173 malloc() and garbage-collection junk) as much as possible.
2174 It is similar to the Blocktype class.
2178 1) Create an lcrecord-list object using make_lcrecord_list().
2179 This is often done at initialization. Remember to staticpro_nodump
2180 this object! The arguments to make_lcrecord_list() are the
2181 same as would be passed to alloc_lcrecord().
2182 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2183 and pass the lcrecord-list earlier created.
2184 3) When done with the lcrecord, call free_managed_lcrecord().
2185 The standard freeing caveats apply: ** make sure there are no
2186 pointers to the object anywhere! **
2187 4) Calling free_managed_lcrecord() is just like kissing the
2188 lcrecord goodbye as if it were garbage-collected. This means:
2189 -- the contents of the freed lcrecord are undefined, and the
2190 contents of something produced by allocate_managed_lcrecord()
2191 are undefined, just like for alloc_lcrecord().
2192 -- the mark method for the lcrecord's type will *NEVER* be called
2194 -- the finalize method for the lcrecord's type will be called
2195 at the time that free_managed_lcrecord() is called.
2200 mark_lcrecord_list (Lisp_Object obj)
2202 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2203 Lisp_Object chain = list->free;
2205 while (!NILP (chain))
2207 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2208 struct free_lcrecord_header *free_header =
2209 (struct free_lcrecord_header *) lheader;
2212 (/* There should be no other pointers to the free list. */
2213 ! MARKED_RECORD_HEADER_P (lheader)
2215 /* Only lcrecords should be here. */
2216 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
2218 /* Only free lcrecords should be here. */
2219 free_header->lcheader.free
2221 /* The type of the lcrecord must be right. */
2222 LHEADER_IMPLEMENTATION (lheader) == list->implementation
2224 /* So must the size. */
2225 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2226 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
2229 MARK_RECORD_HEADER (lheader);
2230 chain = free_header->chain;
2236 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2237 mark_lcrecord_list, internal_object_printer,
2238 0, 0, 0, 0, struct lcrecord_list);
2240 make_lcrecord_list (size_t size,
2241 const struct lrecord_implementation *implementation)
2243 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2244 &lrecord_lcrecord_list);
2247 p->implementation = implementation;
2250 XSETLCRECORD_LIST (val, p);
2255 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2257 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2258 if (!NILP (list->free))
2260 Lisp_Object val = list->free;
2261 struct free_lcrecord_header *free_header =
2262 (struct free_lcrecord_header *) XPNTR (val);
2264 #ifdef ERROR_CHECK_GC
2265 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2267 /* There should be no other pointers to the free list. */
2268 assert (! MARKED_RECORD_HEADER_P (lheader));
2269 /* Only lcrecords should be here. */
2270 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
2271 /* Only free lcrecords should be here. */
2272 assert (free_header->lcheader.free);
2273 /* The type of the lcrecord must be right. */
2274 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
2275 /* So must the size. */
2276 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2277 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
2278 #endif /* ERROR_CHECK_GC */
2280 list->free = free_header->chain;
2281 free_header->lcheader.free = 0;
2288 XSETOBJ (val, alloc_lcrecord (list->size, list->implementation));
2294 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2296 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2297 struct free_lcrecord_header *free_header =
2298 (struct free_lcrecord_header *) XPNTR (lcrecord);
2299 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2300 const struct lrecord_implementation *implementation
2301 = LHEADER_IMPLEMENTATION (lheader);
2303 /* Make sure the size is correct. This will catch, for example,
2304 putting a window configuration on the wrong free list. */
2305 gc_checking_assert ((implementation->size_in_bytes_method ?
2306 implementation->size_in_bytes_method (lheader) :
2307 implementation->static_size)
2310 if (implementation->finalizer)
2311 implementation->finalizer (lheader, 0);
2312 free_header->chain = list->free;
2313 free_header->lcheader.free = 1;
2314 list->free = lcrecord;
2320 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2321 Kept for compatibility, returns its argument.
2323 Make a copy of OBJECT in pure storage.
2324 Recursively copies contents of vectors and cons cells.
2325 Does not copy symbols.
2333 /************************************************************************/
2334 /* Garbage Collection */
2335 /************************************************************************/
2337 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
2338 Additional ones may be defined by a module (none yet). We leave some
2339 room in `lrecord_implementations_table' for such new lisp object types. */
2340 const struct lrecord_implementation *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT];
2341 unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
2342 /* Object marker functions are in the lrecord_implementation structure.
2343 But copying them to a parallel array is much more cache-friendly.
2344 This hack speeds up (garbage-collect) by about 5%. */
2345 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
2347 struct gcpro *gcprolist;
2349 /* 415 used Mly 29-Jun-93 */
2350 /* 1327 used slb 28-Feb-98 */
2351 /* 1328 used og 03-Oct-99 (moving slowly, heh?) */
2353 #define NSTATICS 4000
2355 #define NSTATICS 2000
2358 /* Not "static" because used by dumper.c */
2359 Lisp_Object *staticvec[NSTATICS];
2362 /* Put an entry in staticvec, pointing at the variable whose address is given
2365 staticpro (Lisp_Object *varaddress)
2367 /* #### This is now a dubious assert() since this routine may be called */
2368 /* by Lisp attempting to load a DLL. */
2369 assert (staticidx < countof (staticvec));
2370 staticvec[staticidx++] = varaddress;
2374 Lisp_Object *staticvec_nodump[200];
2375 int staticidx_nodump;
2377 /* Put an entry in staticvec_nodump, pointing at the variable whose address is given
2380 staticpro_nodump (Lisp_Object *varaddress)
2382 /* #### This is now a dubious assert() since this routine may be called */
2383 /* by Lisp attempting to load a DLL. */
2384 assert (staticidx_nodump < countof (staticvec_nodump));
2385 staticvec_nodump[staticidx_nodump++] = varaddress;
2389 struct pdump_dumpstructinfo dumpstructvec[200];
2392 /* Put an entry in dumpstructvec, pointing at the variable whose address is given
2395 dumpstruct (void *varaddress, const struct struct_description *desc)
2397 assert (dumpstructidx < countof (dumpstructvec));
2398 dumpstructvec[dumpstructidx].data = varaddress;
2399 dumpstructvec[dumpstructidx].desc = desc;
2403 struct pdump_dumpopaqueinfo dumpopaquevec[250];
2406 /* Put an entry in dumpopaquevec, pointing at the variable whose address is given
2409 dumpopaque (void *varaddress, size_t size)
2411 assert (dumpopaqueidx < countof (dumpopaquevec));
2413 dumpopaquevec[dumpopaqueidx].data = varaddress;
2414 dumpopaquevec[dumpopaqueidx].size = size;
2418 Lisp_Object *pdump_wirevec[50];
2421 /* Put an entry in pdump_wirevec, pointing at the variable whose address is given
2424 pdump_wire (Lisp_Object *varaddress)
2426 assert (pdump_wireidx < countof (pdump_wirevec));
2427 pdump_wirevec[pdump_wireidx++] = varaddress;
2431 Lisp_Object *pdump_wirevec_list[50];
2432 int pdump_wireidx_list;
2434 /* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given
2437 pdump_wire_list (Lisp_Object *varaddress)
2439 assert (pdump_wireidx_list < countof (pdump_wirevec_list));
2440 pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
2443 #ifdef ERROR_CHECK_GC
2444 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
2445 struct lrecord_header * GCLI_lh = (lheader); \
2446 assert (GCLI_lh != 0); \
2447 assert (GCLI_lh->type < lrecord_type_count); \
2448 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
2449 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
2450 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
2453 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
2457 /* Mark reference to a Lisp_Object. If the object referred to has not been
2458 seen yet, recursively mark all the references contained in it. */
2461 mark_object (Lisp_Object obj)
2465 /* Checks we used to perform */
2466 /* if (EQ (obj, Qnull_pointer)) return; */
2467 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2468 /* if (PURIFIED (XPNTR (obj))) return; */
2470 if (XTYPE (obj) == Lisp_Type_Record)
2472 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2474 GC_CHECK_LHEADER_INVARIANTS (lheader);
2476 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
2477 ! ((struct lcrecord_header *) lheader)->free);
2479 /* All c_readonly objects have their mark bit set,
2480 so that we only need to check the mark bit here. */
2481 if (! MARKED_RECORD_HEADER_P (lheader))
2483 MARK_RECORD_HEADER (lheader);
2485 if (RECORD_MARKER (lheader))
2487 obj = RECORD_MARKER (lheader) (obj);
2488 if (!NILP (obj)) goto tail_recurse;
2494 /* mark all of the conses in a list and mark the final cdr; but
2495 DO NOT mark the cars.
2497 Use only for internal lists! There should never be other pointers
2498 to the cons cells, because if so, the cars will remain unmarked
2499 even when they maybe should be marked. */
2501 mark_conses_in_list (Lisp_Object obj)
2505 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2507 if (CONS_MARKED_P (XCONS (rest)))
2509 MARK_CONS (XCONS (rest));
2516 /* Find all structures not marked, and free them. */
2518 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2519 static int gc_count_bit_vector_storage;
2520 static int gc_count_num_short_string_in_use;
2521 static int gc_count_string_total_size;
2522 static int gc_count_short_string_total_size;
2524 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2527 /* stats on lcrecords in use - kinda kludgy */
2531 int instances_in_use;
2533 int instances_freed;
2535 int instances_on_free_list;
2536 } lcrecord_stats [countof (lrecord_implementations_table)];
2539 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
2541 unsigned int type_index = h->type;
2543 if (((struct lcrecord_header *) h)->free)
2545 gc_checking_assert (!free_p);
2546 lcrecord_stats[type_index].instances_on_free_list++;
2550 const struct lrecord_implementation *implementation =
2551 LHEADER_IMPLEMENTATION (h);
2553 size_t sz = (implementation->size_in_bytes_method ?
2554 implementation->size_in_bytes_method (h) :
2555 implementation->static_size);
2558 lcrecord_stats[type_index].instances_freed++;
2559 lcrecord_stats[type_index].bytes_freed += sz;
2563 lcrecord_stats[type_index].instances_in_use++;
2564 lcrecord_stats[type_index].bytes_in_use += sz;
2570 /* Free all unmarked records */
2572 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2574 struct lcrecord_header *header;
2576 /* int total_size = 0; */
2578 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2580 /* First go through and call all the finalize methods.
2581 Then go through and free the objects. There used to
2582 be only one loop here, with the call to the finalizer
2583 occurring directly before the xfree() below. That
2584 is marginally faster but much less safe -- if the
2585 finalize method for an object needs to reference any
2586 other objects contained within it (and many do),
2587 we could easily be screwed by having already freed that
2590 for (header = *prev; header; header = header->next)
2592 struct lrecord_header *h = &(header->lheader);
2594 GC_CHECK_LHEADER_INVARIANTS (h);
2596 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
2598 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2599 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2603 for (header = *prev; header; )
2605 struct lrecord_header *h = &(header->lheader);
2606 if (MARKED_RECORD_HEADER_P (h))
2608 if (! C_READONLY_RECORD_HEADER_P (h))
2609 UNMARK_RECORD_HEADER (h);
2611 /* total_size += n->implementation->size_in_bytes (h);*/
2612 /* #### May modify header->next on a C_READONLY lcrecord */
2613 prev = &(header->next);
2615 tick_lcrecord_stats (h, 0);
2619 struct lcrecord_header *next = header->next;
2621 tick_lcrecord_stats (h, 1);
2622 /* used to call finalizer right here. */
2628 /* *total = total_size; */
2633 sweep_bit_vectors_1 (Lisp_Object *prev,
2634 int *used, int *total, int *storage)
2636 Lisp_Object bit_vector;
2639 int total_storage = 0;
2641 /* BIT_VECTORP fails because the objects are marked, which changes
2642 their implementation */
2643 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2645 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2647 if (MARKED_RECORD_P (bit_vector))
2649 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
2650 UNMARK_RECORD_HEADER (&(v->lheader));
2654 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2655 BIT_VECTOR_LONG_STORAGE (len));
2657 /* #### May modify next on a C_READONLY bitvector */
2658 prev = &(bit_vector_next (v));
2663 Lisp_Object next = bit_vector_next (v);
2670 *total = total_size;
2671 *storage = total_storage;
2674 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2675 to make macros prettier. */
2677 #ifdef ERROR_CHECK_GC
2679 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2681 struct typename##_block *SFTB_current; \
2682 struct typename##_block **SFTB_prev; \
2684 int num_free = 0, num_used = 0; \
2686 for (SFTB_prev = ¤t_##typename##_block, \
2687 SFTB_current = current_##typename##_block, \
2688 SFTB_limit = current_##typename##_block_index; \
2694 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2696 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2698 if (FREE_STRUCT_P (SFTB_victim)) \
2702 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2706 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2709 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2714 UNMARK_##typename (SFTB_victim); \
2717 SFTB_prev = &(SFTB_current->prev); \
2718 SFTB_current = SFTB_current->prev; \
2719 SFTB_limit = countof (current_##typename##_block->block); \
2722 gc_count_num_##typename##_in_use = num_used; \
2723 gc_count_num_##typename##_freelist = num_free; \
2726 #else /* !ERROR_CHECK_GC */
2728 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2730 struct typename##_block *SFTB_current; \
2731 struct typename##_block **SFTB_prev; \
2733 int num_free = 0, num_used = 0; \
2735 typename##_free_list = 0; \
2737 for (SFTB_prev = ¤t_##typename##_block, \
2738 SFTB_current = current_##typename##_block, \
2739 SFTB_limit = current_##typename##_block_index; \
2744 int SFTB_empty = 1; \
2745 obj_type *SFTB_old_free_list = typename##_free_list; \
2747 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2749 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2751 if (FREE_STRUCT_P (SFTB_victim)) \
2754 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2756 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2761 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2764 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2770 UNMARK_##typename (SFTB_victim); \
2775 SFTB_prev = &(SFTB_current->prev); \
2776 SFTB_current = SFTB_current->prev; \
2778 else if (SFTB_current == current_##typename##_block \
2779 && !SFTB_current->prev) \
2781 /* No real point in freeing sole allocation block */ \
2786 struct typename##_block *SFTB_victim_block = SFTB_current; \
2787 if (SFTB_victim_block == current_##typename##_block) \
2788 current_##typename##_block_index \
2789 = countof (current_##typename##_block->block); \
2790 SFTB_current = SFTB_current->prev; \
2792 *SFTB_prev = SFTB_current; \
2793 xfree (SFTB_victim_block); \
2794 /* Restore free list to what it was before victim was swept */ \
2795 typename##_free_list = SFTB_old_free_list; \
2796 num_free -= SFTB_limit; \
2799 SFTB_limit = countof (current_##typename##_block->block); \
2802 gc_count_num_##typename##_in_use = num_used; \
2803 gc_count_num_##typename##_freelist = num_free; \
2806 #endif /* !ERROR_CHECK_GC */
2814 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2815 #define ADDITIONAL_FREE_cons(ptr)
2817 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2820 /* Explicitly free a cons cell. */
2822 free_cons (Lisp_Cons *ptr)
2824 #ifdef ERROR_CHECK_GC
2825 /* If the CAR is not an int, then it will be a pointer, which will
2826 always be four-byte aligned. If this cons cell has already been
2827 placed on the free list, however, its car will probably contain
2828 a chain pointer to the next cons on the list, which has cleverly
2829 had all its 0's and 1's inverted. This allows for a quick
2830 check to make sure we're not freeing something already freed. */
2831 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2832 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2833 #endif /* ERROR_CHECK_GC */
2835 #ifndef ALLOC_NO_POOLS
2836 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2837 #endif /* ALLOC_NO_POOLS */
2840 /* explicitly free a list. You **must make sure** that you have
2841 created all the cons cells that make up this list and that there
2842 are no pointers to any of these cons cells anywhere else. If there
2843 are, you will lose. */
2846 free_list (Lisp_Object list)
2848 Lisp_Object rest, next;
2850 for (rest = list; !NILP (rest); rest = next)
2853 free_cons (XCONS (rest));
2857 /* explicitly free an alist. You **must make sure** that you have
2858 created all the cons cells that make up this alist and that there
2859 are no pointers to any of these cons cells anywhere else. If there
2860 are, you will lose. */
2863 free_alist (Lisp_Object alist)
2865 Lisp_Object rest, next;
2867 for (rest = alist; !NILP (rest); rest = next)
2870 free_cons (XCONS (XCAR (rest)));
2871 free_cons (XCONS (rest));
2876 sweep_compiled_functions (void)
2878 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2879 #define ADDITIONAL_FREE_compiled_function(ptr)
2881 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2885 #ifdef LISP_FLOAT_TYPE
2889 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2890 #define ADDITIONAL_FREE_float(ptr)
2892 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
2894 #endif /* LISP_FLOAT_TYPE */
2897 sweep_symbols (void)
2899 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2900 #define ADDITIONAL_FREE_symbol(ptr)
2902 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
2906 sweep_extents (void)
2908 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2909 #define ADDITIONAL_FREE_extent(ptr)
2911 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2917 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2918 #define ADDITIONAL_FREE_event(ptr)
2920 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
2924 sweep_markers (void)
2926 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2927 #define ADDITIONAL_FREE_marker(ptr) \
2928 do { Lisp_Object tem; \
2929 XSETMARKER (tem, ptr); \
2930 unchain_marker (tem); \
2933 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
2936 /* Explicitly free a marker. */
2938 free_marker (Lisp_Marker *ptr)
2940 /* Perhaps this will catch freeing an already-freed marker. */
2941 gc_checking_assert (ptr->lheader.type = lrecord_type_marker);
2943 #ifndef ALLOC_NO_POOLS
2944 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
2945 #endif /* ALLOC_NO_POOLS */
2949 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2952 verify_string_chars_integrity (void)
2954 struct string_chars_block *sb;
2956 /* Scan each existing string block sequentially, string by string. */
2957 for (sb = first_string_chars_block; sb; sb = sb->next)
2960 /* POS is the index of the next string in the block. */
2961 while (pos < sb->pos)
2963 struct string_chars *s_chars =
2964 (struct string_chars *) &(sb->string_chars[pos]);
2965 Lisp_String *string;
2969 /* If the string_chars struct is marked as free (i.e. the STRING
2970 pointer is 0xFFFFFFFF) then this is an unused chunk of string
2971 storage. (See below.) */
2973 if (FREE_STRUCT_P (s_chars))
2975 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
2980 string = s_chars->string;
2981 /* Must be 32-bit aligned. */
2982 assert ((((int) string) & 3) == 0);
2984 size = string_length (string);
2985 fullsize = STRING_FULLSIZE (size);
2987 assert (!BIG_STRING_FULLSIZE_P (fullsize));
2988 assert (string_data (string) == s_chars->chars);
2991 assert (pos == sb->pos);
2995 #endif /* MULE && ERROR_CHECK_GC */
2997 /* Compactify string chars, relocating the reference to each --
2998 free any empty string_chars_block we see. */
3000 compact_string_chars (void)
3002 struct string_chars_block *to_sb = first_string_chars_block;
3004 struct string_chars_block *from_sb;
3006 /* Scan each existing string block sequentially, string by string. */
3007 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3010 /* FROM_POS is the index of the next string in the block. */
3011 while (from_pos < from_sb->pos)
3013 struct string_chars *from_s_chars =
3014 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3015 struct string_chars *to_s_chars;
3016 Lisp_String *string;
3020 /* If the string_chars struct is marked as free (i.e. the STRING
3021 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3022 storage. This happens under Mule when a string's size changes
3023 in such a way that its fullsize changes. (Strings can change
3024 size because a different-length character can be substituted
3025 for another character.) In this case, after the bogus string
3026 pointer is the "fullsize" of this entry, i.e. how many bytes
3029 if (FREE_STRUCT_P (from_s_chars))
3031 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3032 from_pos += fullsize;
3036 string = from_s_chars->string;
3037 assert (!(FREE_STRUCT_P (string)));
3039 size = string_length (string);
3040 fullsize = STRING_FULLSIZE (size);
3042 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
3044 /* Just skip it if it isn't marked. */
3045 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3047 from_pos += fullsize;
3051 /* If it won't fit in what's left of TO_SB, close TO_SB out
3052 and go on to the next string_chars_block. We know that TO_SB
3053 cannot advance past FROM_SB here since FROM_SB is large enough
3054 to currently contain this string. */
3055 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3057 to_sb->pos = to_pos;
3058 to_sb = to_sb->next;
3062 /* Compute new address of this string
3063 and update TO_POS for the space being used. */
3064 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3066 /* Copy the string_chars to the new place. */
3067 if (from_s_chars != to_s_chars)
3068 memmove (to_s_chars, from_s_chars, fullsize);
3070 /* Relocate FROM_S_CHARS's reference */
3071 set_string_data (string, &(to_s_chars->chars[0]));
3073 from_pos += fullsize;
3078 /* Set current to the last string chars block still used and
3079 free any that follow. */
3081 struct string_chars_block *victim;
3083 for (victim = to_sb->next; victim; )
3085 struct string_chars_block *next = victim->next;
3090 current_string_chars_block = to_sb;
3091 current_string_chars_block->pos = to_pos;
3092 current_string_chars_block->next = 0;
3096 #if 1 /* Hack to debug missing purecopy's */
3097 static int debug_string_purity;
3100 debug_string_purity_print (Lisp_String *p)
3103 Charcount s = string_char_length (p);
3105 for (i = 0; i < s; i++)
3107 Emchar ch = string_char (p, i);
3108 if (ch < 32 || ch >= 126)
3109 stderr_out ("\\%03o", ch);
3110 else if (ch == '\\' || ch == '\"')
3111 stderr_out ("\\%c", ch);
3113 stderr_out ("%c", ch);
3115 stderr_out ("\"\n");
3121 sweep_strings (void)
3123 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3124 int debug = debug_string_purity;
3126 #define UNMARK_string(ptr) do { \
3127 Lisp_String *p = (ptr); \
3128 size_t size = string_length (p); \
3129 UNMARK_RECORD_HEADER (&(p->lheader)); \
3130 num_bytes += size; \
3131 if (!BIG_STRING_SIZE_P (size)) \
3133 num_small_bytes += size; \
3137 debug_string_purity_print (p); \
3139 #define ADDITIONAL_FREE_string(ptr) do { \
3140 size_t size = string_length (ptr); \
3141 if (BIG_STRING_SIZE_P (size)) \
3142 xfree (ptr->data); \
3145 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3147 gc_count_num_short_string_in_use = num_small_used;
3148 gc_count_string_total_size = num_bytes;
3149 gc_count_short_string_total_size = num_small_bytes;
3153 /* I hate duplicating all this crap! */
3155 marked_p (Lisp_Object obj)
3157 /* Checks we used to perform. */
3158 /* if (EQ (obj, Qnull_pointer)) return 1; */
3159 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3160 /* if (PURIFIED (XPNTR (obj))) return 1; */
3162 if (XTYPE (obj) == Lisp_Type_Record)
3164 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3166 GC_CHECK_LHEADER_INVARIANTS (lheader);
3168 return MARKED_RECORD_HEADER_P (lheader);
3176 /* Free all unmarked records. Do this at the very beginning,
3177 before anything else, so that the finalize methods can safely
3178 examine items in the objects. sweep_lcrecords_1() makes
3179 sure to call all the finalize methods *before* freeing anything,
3180 to complete the safety. */
3183 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3186 compact_string_chars ();
3188 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3189 macros) must be *extremely* careful to make sure they're not
3190 referencing freed objects. The only two existing finalize
3191 methods (for strings and markers) pass muster -- the string
3192 finalizer doesn't look at anything but its own specially-
3193 created block, and the marker finalizer only looks at live
3194 buffers (which will never be freed) and at the markers before
3195 and after it in the chain (which, by induction, will never be
3196 freed because if so, they would have already removed themselves
3199 /* Put all unmarked strings on free list, free'ing the string chars
3200 of large unmarked strings */
3203 /* Put all unmarked conses on free list */
3206 /* Free all unmarked bit vectors */
3207 sweep_bit_vectors_1 (&all_bit_vectors,
3208 &gc_count_num_bit_vector_used,
3209 &gc_count_bit_vector_total_size,
3210 &gc_count_bit_vector_storage);
3212 /* Free all unmarked compiled-function objects */
3213 sweep_compiled_functions ();
3215 #ifdef LISP_FLOAT_TYPE
3216 /* Put all unmarked floats on free list */
3220 /* Put all unmarked symbols on free list */
3223 /* Put all unmarked extents on free list */
3226 /* Put all unmarked markers on free list.
3227 Dechain each one first from the buffer into which it points. */
3233 pdump_objects_unmark ();
3237 /* Clearing for disksave. */
3240 disksave_object_finalization (void)
3242 /* It's important that certain information from the environment not get
3243 dumped with the executable (pathnames, environment variables, etc.).
3244 To make it easier to tell when this has happened with strings(1) we
3245 clear some known-to-be-garbage blocks of memory, so that leftover
3246 results of old evaluation don't look like potential problems.
3247 But first we set some notable variables to nil and do one more GC,
3248 to turn those strings into garbage.
3251 /* Yeah, this list is pretty ad-hoc... */
3252 Vprocess_environment = Qnil;
3253 Vexec_directory = Qnil;
3254 Vdata_directory = Qnil;
3255 Vsite_directory = Qnil;
3256 Vdoc_directory = Qnil;
3257 Vconfigure_info_directory = Qnil;
3260 /* Vdump_load_path = Qnil; */
3261 /* Release hash tables for locate_file */
3262 Flocate_file_clear_hashing (Qt);
3263 uncache_home_directory();
3265 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3266 defined(LOADHIST_BUILTIN))
3267 Vload_history = Qnil;
3269 Vshell_file_name = Qnil;
3271 garbage_collect_1 ();
3273 /* Run the disksave finalization methods of all live objects. */
3274 disksave_object_finalization_1 ();
3276 /* Zero out the uninitialized (really, unused) part of the containers
3277 for the live strings. */
3279 struct string_chars_block *scb;
3280 for (scb = first_string_chars_block; scb; scb = scb->next)
3282 int count = sizeof (scb->string_chars) - scb->pos;
3284 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3287 /* from the block's fill ptr to the end */
3288 memset ((scb->string_chars + scb->pos), 0, count);
3293 /* There, that ought to be enough... */
3299 restore_gc_inhibit (Lisp_Object val)
3301 gc_currently_forbidden = XINT (val);
3305 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3306 static int gc_hooks_inhibited;
3310 garbage_collect_1 (void)
3312 #if MAX_SAVE_STACK > 0
3313 char stack_top_variable;
3314 extern char *stack_bottom;
3319 Lisp_Object pre_gc_cursor;
3320 struct gcpro gcpro1;
3323 || gc_currently_forbidden
3325 || preparing_for_armageddon)
3328 /* We used to call selected_frame() here.
3330 The following functions cannot be called inside GC
3331 so we move to after the above tests. */
3334 Lisp_Object device = Fselected_device (Qnil);
3335 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3337 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3339 signal_simple_error ("No frames exist on device", device);
3343 pre_gc_cursor = Qnil;
3346 GCPRO1 (pre_gc_cursor);
3348 /* Very important to prevent GC during any of the following
3349 stuff that might run Lisp code; otherwise, we'll likely
3350 have infinite GC recursion. */
3351 speccount = specpdl_depth ();
3352 record_unwind_protect (restore_gc_inhibit,
3353 make_int (gc_currently_forbidden));
3354 gc_currently_forbidden = 1;
3356 if (!gc_hooks_inhibited)
3357 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3359 /* Now show the GC cursor/message. */
3360 if (!noninteractive)
3362 if (FRAME_WIN_P (f))
3364 Lisp_Object frame = make_frame (f);
3365 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3366 FRAME_SELECTED_WINDOW (f),
3368 pre_gc_cursor = f->pointer;
3369 if (POINTER_IMAGE_INSTANCEP (cursor)
3370 /* don't change if we don't know how to change back. */
3371 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3374 Fset_frame_pointer (frame, cursor);
3378 /* Don't print messages to the stream device. */
3379 if (!cursor_changed && !FRAME_STREAM_P (f))
3381 char *msg = (STRINGP (Vgc_message)
3382 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3384 Lisp_Object args[2], whole_msg;
3385 args[0] = build_string (msg ? msg :
3386 GETTEXT ((const char *) gc_default_message));
3387 args[1] = build_string ("...");
3388 whole_msg = Fconcat (2, args);
3389 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3390 Qgarbage_collecting);
3394 /***** Now we actually start the garbage collection. */
3398 gc_generation_number[0]++;
3400 #if MAX_SAVE_STACK > 0
3402 /* Save a copy of the contents of the stack, for debugging. */
3405 /* Static buffer in which we save a copy of the C stack at each GC. */
3406 static char *stack_copy;
3407 static size_t stack_copy_size;
3409 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3410 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3411 if (stack_size < MAX_SAVE_STACK)
3413 if (stack_copy_size < stack_size)
3415 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3416 stack_copy_size = stack_size;
3420 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3424 #endif /* MAX_SAVE_STACK > 0 */
3426 /* Do some totally ad-hoc resource clearing. */
3427 /* #### generalize this? */
3428 clear_event_resource ();
3429 cleanup_specifiers ();
3431 /* Mark all the special slots that serve as the roots of accessibility. */
3435 for (i = 0; i < staticidx; i++)
3436 mark_object (*(staticvec[i]));
3437 for (i = 0; i < staticidx_nodump; i++)
3438 mark_object (*(staticvec_nodump[i]));
3444 for (tail = gcprolist; tail; tail = tail->next)
3445 for (i = 0; i < tail->nvars; i++)
3446 mark_object (tail->var[i]);
3450 struct specbinding *bind;
3451 for (bind = specpdl; bind != specpdl_ptr; bind++)
3453 mark_object (bind->symbol);
3454 mark_object (bind->old_value);
3459 struct catchtag *catch;
3460 for (catch = catchlist; catch; catch = catch->next)
3462 mark_object (catch->tag);
3463 mark_object (catch->val);
3468 struct backtrace *backlist;
3469 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3471 int nargs = backlist->nargs;
3474 mark_object (*backlist->function);
3475 if (nargs == UNEVALLED || nargs == MANY)
3476 mark_object (backlist->args[0]);
3478 for (i = 0; i < nargs; i++)
3479 mark_object (backlist->args[i]);
3484 mark_profiling_info ();
3486 /* OK, now do the after-mark stuff. This is for things that
3487 are only marked when something else is marked (e.g. weak hash tables).
3488 There may be complex dependencies between such objects -- e.g.
3489 a weak hash table might be unmarked, but after processing a later
3490 weak hash table, the former one might get marked. So we have to
3491 iterate until nothing more gets marked. */
3493 while (finish_marking_weak_hash_tables () > 0 ||
3494 finish_marking_weak_lists () > 0)
3497 /* And prune (this needs to be called after everything else has been
3498 marked and before we do any sweeping). */
3499 /* #### this is somewhat ad-hoc and should probably be an object
3501 prune_weak_hash_tables ();
3502 prune_weak_lists ();
3503 prune_specifiers ();
3504 prune_syntax_tables ();
3508 consing_since_gc = 0;
3509 #ifndef DEBUG_XEMACS
3510 /* Allow you to set it really fucking low if you really want ... */
3511 if (gc_cons_threshold < 10000)
3512 gc_cons_threshold = 10000;
3517 /******* End of garbage collection ********/
3519 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3521 /* Now remove the GC cursor/message */
3522 if (!noninteractive)
3525 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3526 else if (!FRAME_STREAM_P (f))
3528 char *msg = (STRINGP (Vgc_message)
3529 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3532 /* Show "...done" only if the echo area would otherwise be empty. */
3533 if (NILP (clear_echo_area (selected_frame (),
3534 Qgarbage_collecting, 0)))
3536 Lisp_Object args[2], whole_msg;
3537 args[0] = build_string (msg ? msg :
3538 GETTEXT ((const char *)
3539 gc_default_message));
3540 args[1] = build_string ("... done");
3541 whole_msg = Fconcat (2, args);
3542 echo_area_message (selected_frame (), (Bufbyte *) 0,
3544 Qgarbage_collecting);
3549 /* now stop inhibiting GC */
3550 unbind_to (speccount, Qnil);
3552 if (!breathing_space)
3554 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3561 /* Debugging aids. */
3564 gc_plist_hack (const char *name, int value, Lisp_Object tail)
3566 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3567 or portable numeric datatypes, or bit-vectors, or characters, or
3568 arrays, or exceptions, or ...) */
3569 return cons3 (intern (name), make_int (value), tail);
3572 #define HACK_O_MATIC(type, name, pl) do { \
3574 struct type##_block *x = current_##type##_block; \
3575 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3576 (pl) = gc_plist_hack ((name), s, (pl)); \
3579 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3580 Reclaim storage for Lisp objects no longer needed.
3581 Return info on amount of space in use:
3582 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3583 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3585 where `PLIST' is a list of alternating keyword/value pairs providing
3586 more detailed information.
3587 Garbage collection happens automatically if you cons more than
3588 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3592 Lisp_Object pl = Qnil;
3594 int gc_count_vector_total_size = 0;
3596 garbage_collect_1 ();
3598 for (i = 0; i < lrecord_type_count; i++)
3600 if (lcrecord_stats[i].bytes_in_use != 0
3601 || lcrecord_stats[i].bytes_freed != 0
3602 || lcrecord_stats[i].instances_on_free_list != 0)
3605 const char *name = lrecord_implementations_table[i]->name;
3606 int len = strlen (name);
3607 /* save this for the FSFmacs-compatible part of the summary */
3608 if (i == lrecord_vector.lrecord_type_index)
3609 gc_count_vector_total_size =
3610 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3612 sprintf (buf, "%s-storage", name);
3613 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3614 /* Okay, simple pluralization check for `symbol-value-varalias' */
3615 if (name[len-1] == 's')
3616 sprintf (buf, "%ses-freed", name);
3618 sprintf (buf, "%ss-freed", name);
3619 if (lcrecord_stats[i].instances_freed != 0)
3620 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3621 if (name[len-1] == 's')
3622 sprintf (buf, "%ses-on-free-list", name);
3624 sprintf (buf, "%ss-on-free-list", name);
3625 if (lcrecord_stats[i].instances_on_free_list != 0)
3626 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3628 if (name[len-1] == 's')
3629 sprintf (buf, "%ses-used", name);
3631 sprintf (buf, "%ss-used", name);
3632 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3636 HACK_O_MATIC (extent, "extent-storage", pl);
3637 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3638 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3639 HACK_O_MATIC (event, "event-storage", pl);
3640 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3641 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3642 HACK_O_MATIC (marker, "marker-storage", pl);
3643 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3644 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3645 #ifdef LISP_FLOAT_TYPE
3646 HACK_O_MATIC (float, "float-storage", pl);
3647 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3648 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3649 #endif /* LISP_FLOAT_TYPE */
3650 HACK_O_MATIC (string, "string-header-storage", pl);
3651 pl = gc_plist_hack ("long-strings-total-length",
3652 gc_count_string_total_size
3653 - gc_count_short_string_total_size, pl);
3654 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3655 pl = gc_plist_hack ("short-strings-total-length",
3656 gc_count_short_string_total_size, pl);
3657 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3658 pl = gc_plist_hack ("long-strings-used",
3659 gc_count_num_string_in_use
3660 - gc_count_num_short_string_in_use, pl);
3661 pl = gc_plist_hack ("short-strings-used",
3662 gc_count_num_short_string_in_use, pl);
3664 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3665 pl = gc_plist_hack ("compiled-functions-free",
3666 gc_count_num_compiled_function_freelist, pl);
3667 pl = gc_plist_hack ("compiled-functions-used",
3668 gc_count_num_compiled_function_in_use, pl);
3670 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3671 pl = gc_plist_hack ("bit-vectors-total-length",
3672 gc_count_bit_vector_total_size, pl);
3673 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3675 HACK_O_MATIC (symbol, "symbol-storage", pl);
3676 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3677 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3679 HACK_O_MATIC (cons, "cons-storage", pl);
3680 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3681 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3683 /* The things we do for backwards-compatibility */
3685 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3686 make_int (gc_count_num_cons_freelist)),
3687 Fcons (make_int (gc_count_num_symbol_in_use),
3688 make_int (gc_count_num_symbol_freelist)),
3689 Fcons (make_int (gc_count_num_marker_in_use),
3690 make_int (gc_count_num_marker_freelist)),
3691 make_int (gc_count_string_total_size),
3692 make_int (gc_count_vector_total_size),
3697 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3698 Return the number of bytes consed since the last garbage collection.
3699 \"Consed\" is a misnomer in that this actually counts allocation
3700 of all different kinds of objects, not just conses.
3702 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3706 return make_int (consing_since_gc);
3710 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
3711 Return the address of the last byte Emacs has allocated, divided by 1024.
3712 This may be helpful in debugging Emacs's memory usage.
3713 The value is divided by 1024 to make sure it will fit in a lisp integer.
3717 return make_int ((EMACS_INT) sbrk (0) / 1024);
3723 object_dead_p (Lisp_Object obj)
3725 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3726 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3727 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3728 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3729 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3730 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3731 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3734 #ifdef MEMORY_USAGE_STATS
3736 /* Attempt to determine the actual amount of space that is used for
3737 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3739 It seems that the following holds:
3741 1. When using the old allocator (malloc.c):
3743 -- blocks are always allocated in chunks of powers of two. For
3744 each block, there is an overhead of 8 bytes if rcheck is not
3745 defined, 20 bytes if it is defined. In other words, a
3746 one-byte allocation needs 8 bytes of overhead for a total of
3747 9 bytes, and needs to have 16 bytes of memory chunked out for
3750 2. When using the new allocator (gmalloc.c):
3752 -- blocks are always allocated in chunks of powers of two up
3753 to 4096 bytes. Larger blocks are allocated in chunks of
3754 an integral multiple of 4096 bytes. The minimum block
3755 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3756 is defined. There is no per-block overhead, but there
3757 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3760 3. When using the system malloc, anything goes, but they are
3761 generally slower and more space-efficient than the GNU
3762 allocators. One possibly reasonable assumption to make
3763 for want of better data is that sizeof (void *), or maybe
3764 2 * sizeof (void *), is required as overhead and that
3765 blocks are allocated in the minimum required size except
3766 that some minimum block size is imposed (e.g. 16 bytes). */
3769 malloced_storage_size (void *ptr, size_t claimed_size,
3770 struct overhead_stats *stats)
3772 size_t orig_claimed_size = claimed_size;
3776 if (claimed_size < 2 * sizeof (void *))
3777 claimed_size = 2 * sizeof (void *);
3778 # ifdef SUNOS_LOCALTIME_BUG
3779 if (claimed_size < 16)
3782 if (claimed_size < 4096)
3786 /* compute the log base two, more or less, then use it to compute
3787 the block size needed. */
3789 /* It's big, it's heavy, it's wood! */
3790 while ((claimed_size /= 2) != 0)
3793 /* It's better than bad, it's good! */
3799 /* We have to come up with some average about the amount of
3801 if ((size_t) (rand () & 4095) < claimed_size)
3802 claimed_size += 3 * sizeof (void *);
3806 claimed_size += 4095;
3807 claimed_size &= ~4095;
3808 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3811 #elif defined (SYSTEM_MALLOC)
3813 if (claimed_size < 16)
3815 claimed_size += 2 * sizeof (void *);
3817 #else /* old GNU allocator */
3819 # ifdef rcheck /* #### may not be defined here */
3827 /* compute the log base two, more or less, then use it to compute
3828 the block size needed. */
3830 /* It's big, it's heavy, it's wood! */
3831 while ((claimed_size /= 2) != 0)
3834 /* It's better than bad, it's good! */
3842 #endif /* old GNU allocator */
3846 stats->was_requested += orig_claimed_size;
3847 stats->malloc_overhead += claimed_size - orig_claimed_size;
3849 return claimed_size;
3853 fixed_type_block_overhead (size_t size)
3855 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3856 size_t overhead = 0;
3857 size_t storage_size = malloced_storage_size (0, per_block, 0);
3858 while (size >= per_block)
3861 overhead += sizeof (void *) + per_block - storage_size;
3863 if (rand () % per_block < size)
3864 overhead += sizeof (void *) + per_block - storage_size;
3868 #endif /* MEMORY_USAGE_STATS */
3871 /* Initialization */
3873 reinit_alloc_once_early (void)
3875 gc_generation_number[0] = 0;
3876 breathing_space = 0;
3877 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3878 XSETINT (Vgc_message, 0);
3880 ignore_malloc_warnings = 1;
3881 #ifdef DOUG_LEA_MALLOC
3882 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3883 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3884 #if 0 /* Moved to emacs.c */
3885 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3888 init_string_alloc ();
3889 init_string_chars_alloc ();
3891 init_symbol_alloc ();
3892 init_compiled_function_alloc ();
3893 #ifdef LISP_FLOAT_TYPE
3894 init_float_alloc ();
3895 #endif /* LISP_FLOAT_TYPE */
3896 init_marker_alloc ();
3897 init_extent_alloc ();
3898 init_event_alloc ();
3900 ignore_malloc_warnings = 0;
3902 staticidx_nodump = 0;
3906 consing_since_gc = 0;
3908 gc_cons_threshold = 500000; /* XEmacs change */
3910 gc_cons_threshold = 15000; /* debugging */
3912 lrecord_uid_counter = 259;
3913 debug_string_purity = 0;
3916 gc_currently_forbidden = 0;
3917 gc_hooks_inhibited = 0;
3919 #ifdef ERROR_CHECK_TYPECHECK
3920 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3923 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3925 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3927 #endif /* ERROR_CHECK_TYPECHECK */
3931 init_alloc_once_early (void)
3933 reinit_alloc_once_early ();
3937 for (i = 0; i < countof (lrecord_implementations_table); i++)
3938 lrecord_implementations_table[i] = 0;
3941 INIT_LRECORD_IMPLEMENTATION (cons);
3942 INIT_LRECORD_IMPLEMENTATION (vector);
3943 INIT_LRECORD_IMPLEMENTATION (string);
3944 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
3949 int pure_bytes_used = 0;
3958 syms_of_alloc (void)
3960 DEFSYMBOL (Qpre_gc_hook);
3961 DEFSYMBOL (Qpost_gc_hook);
3962 DEFSYMBOL (Qgarbage_collecting);
3967 DEFSUBR (Fbit_vector);
3968 DEFSUBR (Fmake_byte_code);
3969 DEFSUBR (Fmake_list);
3970 DEFSUBR (Fmake_vector);
3971 DEFSUBR (Fmake_bit_vector);
3972 DEFSUBR (Fmake_string);
3974 DEFSUBR (Fmake_symbol);
3975 DEFSUBR (Fmake_marker);
3976 DEFSUBR (Fpurecopy);
3977 DEFSUBR (Fgarbage_collect);
3979 DEFSUBR (Fmemory_limit);
3981 DEFSUBR (Fconsing_since_gc);
3985 vars_of_alloc (void)
3987 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
3988 *Number of bytes of consing between garbage collections.
3989 \"Consing\" is a misnomer in that this actually counts allocation
3990 of all different kinds of objects, not just conses.
3991 Garbage collection can happen automatically once this many bytes have been
3992 allocated since the last garbage collection. All data types count.
3994 Garbage collection happens automatically when `eval' or `funcall' are
3995 called. (Note that `funcall' is called implicitly as part of evaluation.)
3996 By binding this temporarily to a large number, you can effectively
3997 prevent garbage collection during a part of the program.
3999 See also `consing-since-gc'.
4002 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
4003 Number of bytes of sharable Lisp data allocated so far.
4007 DEFVAR_INT ("debug-allocation", &debug_allocation /*
4008 If non-zero, print out information to stderr about all objects allocated.
4009 See also `debug-allocation-backtrace-length'.
4011 debug_allocation = 0;
4013 DEFVAR_INT ("debug-allocation-backtrace-length",
4014 &debug_allocation_backtrace_length /*
4015 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4017 debug_allocation_backtrace_length = 2;
4020 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4021 Non-nil means loading Lisp code in order to dump an executable.
4022 This means that certain objects should be allocated in readonly space.
4025 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4026 Function or functions to be run just before each garbage collection.
4027 Interrupts, garbage collection, and errors are inhibited while this hook
4028 runs, so be extremely careful in what you add here. In particular, avoid
4029 consing, and do not interact with the user.
4031 Vpre_gc_hook = Qnil;
4033 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4034 Function or functions to be run just after each garbage collection.
4035 Interrupts, garbage collection, and errors are inhibited while this hook
4036 runs, so be extremely careful in what you add here. In particular, avoid
4037 consing, and do not interact with the user.
4039 Vpost_gc_hook = Qnil;
4041 DEFVAR_LISP ("gc-message", &Vgc_message /*
4042 String to print to indicate that a garbage collection is in progress.
4043 This is printed in the echo area. If the selected frame is on a
4044 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4045 image instance) in the domain of the selected frame, the mouse pointer
4046 will change instead of this message being printed.
4048 Vgc_message = build_string (gc_default_message);
4050 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4051 Pointer glyph used to indicate that a garbage collection is in progress.
4052 If the selected window is on a window system and this glyph specifies a
4053 value (i.e. a pointer image instance) in the domain of the selected
4054 window, the pointer will be changed as specified during garbage collection.
4055 Otherwise, a message will be printed in the echo area, as controlled
4061 complex_vars_of_alloc (void)
4063 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);