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 OBJECT.
1013 CHECK_NATNUM (length);
1016 Lisp_Object val = Qnil;
1017 size_t size = XINT (length);
1020 val = Fcons (object, 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 object)
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 OBJECT.
1148 See also the function `vector'.
1152 CONCHECK_NATNUM (length);
1153 return make_vector (XINT (length), object);
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 bit)
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 set to BIT.
1346 BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
1350 CONCHECK_NATNUM (length);
1352 return make_bit_vector (XINT (length), bit);
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.
1358 Each argument must be one of the integers 0 or 1.
1360 (int nargs, Lisp_Object *args))
1363 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1365 for (i = 0; i < nargs; i++)
1367 CHECK_BIT (args[i]);
1368 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1372 Lisp_Object bit_vector;
1373 XSETBIT_VECTOR (bit_vector, p);
1379 /************************************************************************/
1380 /* Compiled-function allocation */
1381 /************************************************************************/
1383 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1384 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1387 make_compiled_function (void)
1389 Lisp_Compiled_Function *f;
1392 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1393 set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
1396 f->specpdl_depth = 0;
1397 f->flags.documentationp = 0;
1398 f->flags.interactivep = 0;
1399 f->flags.domainp = 0; /* I18N3 */
1400 f->instructions = Qzero;
1401 f->constants = Qzero;
1403 f->doc_and_interactive = Qnil;
1404 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1405 f->annotated = Qnil;
1407 XSETCOMPILED_FUNCTION (fun, f);
1411 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1412 Return a new compiled-function object.
1413 Usage: (arglist instructions constants stack-depth
1414 &optional doc-string interactive)
1415 Note that, unlike all other emacs-lisp functions, calling this with five
1416 arguments is NOT the same as calling it with six arguments, the last of
1417 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1418 that this function was defined with `(interactive)'. If the arg is not
1419 specified, then that means the function is not interactive.
1420 This is terrible behavior which is retained for compatibility with old
1421 `.elc' files which expect these semantics.
1423 (int nargs, Lisp_Object *args))
1425 /* In a non-insane world this function would have this arglist...
1426 (arglist instructions constants stack_depth &optional doc_string interactive)
1428 Lisp_Object fun = make_compiled_function ();
1429 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1431 Lisp_Object arglist = args[0];
1432 Lisp_Object instructions = args[1];
1433 Lisp_Object constants = args[2];
1434 Lisp_Object stack_depth = args[3];
1435 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1436 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1438 if (nargs < 4 || nargs > 6)
1439 return Fsignal (Qwrong_number_of_arguments,
1440 list2 (intern ("make-byte-code"), make_int (nargs)));
1442 /* Check for valid formal parameter list now, to allow us to use
1443 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1445 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1447 CHECK_SYMBOL (symbol);
1448 if (EQ (symbol, Qt) ||
1449 EQ (symbol, Qnil) ||
1450 SYMBOL_IS_KEYWORD (symbol))
1451 signal_simple_error_2
1452 ("Invalid constant symbol in formal parameter list",
1456 f->arglist = arglist;
1458 /* `instructions' is a string or a cons (string . int) for a
1459 lazy-loaded function. */
1460 if (CONSP (instructions))
1462 CHECK_STRING (XCAR (instructions));
1463 CHECK_INT (XCDR (instructions));
1467 CHECK_STRING (instructions);
1469 f->instructions = instructions;
1471 if (!NILP (constants))
1472 CHECK_VECTOR (constants);
1473 f->constants = constants;
1475 CHECK_NATNUM (stack_depth);
1476 f->stack_depth = (unsigned short) XINT (stack_depth);
1478 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1479 if (!NILP (Vcurrent_compiled_function_annotation))
1480 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1481 else if (!NILP (Vload_file_name_internal_the_purecopy))
1482 f->annotated = Vload_file_name_internal_the_purecopy;
1483 else if (!NILP (Vload_file_name_internal))
1485 struct gcpro gcpro1;
1486 GCPRO1 (fun); /* don't let fun get reaped */
1487 Vload_file_name_internal_the_purecopy =
1488 Ffile_name_nondirectory (Vload_file_name_internal);
1489 f->annotated = Vload_file_name_internal_the_purecopy;
1492 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1494 /* doc_string may be nil, string, int, or a cons (string . int).
1495 interactive may be list or string (or unbound). */
1496 f->doc_and_interactive = Qunbound;
1498 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1499 f->doc_and_interactive = Vfile_domain;
1501 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1503 f->doc_and_interactive
1504 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1505 Fcons (interactive, f->doc_and_interactive));
1507 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1509 f->doc_and_interactive
1510 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1511 Fcons (doc_string, f->doc_and_interactive));
1513 if (UNBOUNDP (f->doc_and_interactive))
1514 f->doc_and_interactive = Qnil;
1520 /************************************************************************/
1521 /* Symbol allocation */
1522 /************************************************************************/
1524 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1525 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1527 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1528 Return a newly allocated uninterned symbol whose name is NAME.
1529 Its value and function definition are void, and its property list is nil.
1536 CHECK_STRING (name);
1538 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1539 set_lheader_implementation (&p->lheader, &lrecord_symbol);
1540 p->name = XSTRING (name);
1542 p->value = Qunbound;
1543 p->function = Qunbound;
1544 symbol_next (p) = 0;
1545 XSETSYMBOL (val, p);
1550 /************************************************************************/
1551 /* Extent allocation */
1552 /************************************************************************/
1554 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1555 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1558 allocate_extent (void)
1562 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1563 set_lheader_implementation (&e->lheader, &lrecord_extent);
1564 extent_object (e) = Qnil;
1565 set_extent_start (e, -1);
1566 set_extent_end (e, -1);
1571 extent_face (e) = Qnil;
1572 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1573 e->flags.detachable = 1;
1579 /************************************************************************/
1580 /* Event allocation */
1581 /************************************************************************/
1583 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1584 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1587 allocate_event (void)
1592 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1593 set_lheader_implementation (&e->lheader, &lrecord_event);
1600 /************************************************************************/
1601 /* Marker allocation */
1602 /************************************************************************/
1604 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1605 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1607 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1608 Return a new marker which does not point at any place.
1615 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1616 set_lheader_implementation (&p->lheader, &lrecord_marker);
1619 marker_next (p) = 0;
1620 marker_prev (p) = 0;
1621 p->insertion_type = 0;
1622 XSETMARKER (val, p);
1627 noseeum_make_marker (void)
1632 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1633 set_lheader_implementation (&p->lheader, &lrecord_marker);
1636 marker_next (p) = 0;
1637 marker_prev (p) = 0;
1638 p->insertion_type = 0;
1639 XSETMARKER (val, p);
1644 /************************************************************************/
1645 /* String allocation */
1646 /************************************************************************/
1648 /* The data for "short" strings generally resides inside of structs of type
1649 string_chars_block. The Lisp_String structure is allocated just like any
1650 other Lisp object (except for vectors), and these are freelisted when
1651 they get garbage collected. The data for short strings get compacted,
1652 but the data for large strings do not.
1654 Previously Lisp_String structures were relocated, but this caused a lot
1655 of bus-errors because the C code didn't include enough GCPRO's for
1656 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1657 that the reference would get relocated).
1659 This new method makes things somewhat bigger, but it is MUCH safer. */
1661 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1662 /* strings are used and freed quite often */
1663 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1664 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1667 mark_string (Lisp_Object obj)
1669 Lisp_String *ptr = XSTRING (obj);
1671 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1672 flush_cached_extent_info (XCAR (ptr->plist));
1677 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1680 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1681 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1684 static const struct lrecord_description string_description[] = {
1685 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1686 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1687 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1691 /* We store the string's extent info as the first element of the string's
1692 property list; and the string's MODIFF as the first or second element
1693 of the string's property list (depending on whether the extent info
1694 is present), but only if the string has been modified. This is ugly
1695 but it reduces the memory allocated for the string in the vast
1696 majority of cases, where the string is never modified and has no
1699 #### This means you can't use an int as a key in a string's plist. */
1701 static Lisp_Object *
1702 string_plist_ptr (Lisp_Object string)
1704 Lisp_Object *ptr = &XSTRING (string)->plist;
1706 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
1708 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
1714 string_getprop (Lisp_Object string, Lisp_Object property)
1716 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
1720 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
1722 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
1727 string_remprop (Lisp_Object string, Lisp_Object property)
1729 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
1733 string_plist (Lisp_Object string)
1735 return *string_plist_ptr (string);
1738 /* No `finalize', or `hash' methods.
1739 internal_hash() already knows how to hash strings and finalization
1740 is done with the ADDITIONAL_FREE_string macro, which is the
1741 standard way to do finalization when using
1742 SWEEP_FIXED_TYPE_BLOCK(). */
1743 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
1744 mark_string, print_string,
1753 /* String blocks contain this many useful bytes. */
1754 #define STRING_CHARS_BLOCK_SIZE \
1755 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1756 ((2 * sizeof (struct string_chars_block *)) \
1757 + sizeof (EMACS_INT))))
1758 /* Block header for small strings. */
1759 struct string_chars_block
1762 struct string_chars_block *next;
1763 struct string_chars_block *prev;
1764 /* Contents of string_chars_block->string_chars are interleaved
1765 string_chars structures (see below) and the actual string data */
1766 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1769 static struct string_chars_block *first_string_chars_block;
1770 static struct string_chars_block *current_string_chars_block;
1772 /* If SIZE is the length of a string, this returns how many bytes
1773 * the string occupies in string_chars_block->string_chars
1774 * (including alignment padding).
1776 #define STRING_FULLSIZE(size) \
1777 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1778 ALIGNOF (Lisp_String *))
1780 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1781 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1785 Lisp_String *string;
1786 unsigned char chars[1];
1789 struct unused_string_chars
1791 Lisp_String *string;
1796 init_string_chars_alloc (void)
1798 first_string_chars_block = xnew (struct string_chars_block);
1799 first_string_chars_block->prev = 0;
1800 first_string_chars_block->next = 0;
1801 first_string_chars_block->pos = 0;
1802 current_string_chars_block = first_string_chars_block;
1805 static struct string_chars *
1806 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1809 struct string_chars *s_chars;
1812 (countof (current_string_chars_block->string_chars)
1813 - current_string_chars_block->pos))
1815 /* This string can fit in the current string chars block */
1816 s_chars = (struct string_chars *)
1817 (current_string_chars_block->string_chars
1818 + current_string_chars_block->pos);
1819 current_string_chars_block->pos += fullsize;
1823 /* Make a new current string chars block */
1824 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1826 current_string_chars_block->next = new_scb;
1827 new_scb->prev = current_string_chars_block;
1829 current_string_chars_block = new_scb;
1830 new_scb->pos = fullsize;
1831 s_chars = (struct string_chars *)
1832 current_string_chars_block->string_chars;
1835 s_chars->string = string_it_goes_with;
1837 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1843 make_uninit_string (Bytecount length)
1846 EMACS_INT fullsize = STRING_FULLSIZE (length);
1849 assert (length >= 0 && fullsize > 0);
1851 /* Allocate the string header */
1852 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1853 set_lheader_implementation (&s->lheader, &lrecord_string);
1855 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1856 ? xnew_array (Bufbyte, length + 1)
1857 : allocate_string_chars_struct (s, fullsize)->chars);
1859 set_string_length (s, length);
1862 set_string_byte (s, length, 0);
1864 XSETSTRING (val, s);
1868 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1869 static void verify_string_chars_integrity (void);
1872 /* Resize the string S so that DELTA bytes can be inserted starting
1873 at POS. If DELTA < 0, it means deletion starting at POS. If
1874 POS < 0, resize the string but don't copy any characters. Use
1875 this if you're planning on completely overwriting the string.
1879 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
1881 Bytecount oldfullsize, newfullsize;
1882 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1883 verify_string_chars_integrity ();
1886 #ifdef ERROR_CHECK_BUFPOS
1889 assert (pos <= string_length (s));
1891 assert (pos + (-delta) <= string_length (s));
1896 assert ((-delta) <= string_length (s));
1898 #endif /* ERROR_CHECK_BUFPOS */
1901 /* simplest case: no size change. */
1904 if (pos >= 0 && delta < 0)
1905 /* If DELTA < 0, the functions below will delete the characters
1906 before POS. We want to delete characters *after* POS, however,
1907 so convert this to the appropriate form. */
1910 oldfullsize = STRING_FULLSIZE (string_length (s));
1911 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1913 if (BIG_STRING_FULLSIZE_P (oldfullsize))
1915 if (BIG_STRING_FULLSIZE_P (newfullsize))
1917 /* Both strings are big. We can just realloc().
1918 But careful! If the string is shrinking, we have to
1919 memmove() _before_ realloc(), and if growing, we have to
1920 memmove() _after_ realloc() - otherwise the access is
1921 illegal, and we might crash. */
1922 Bytecount len = string_length (s) + 1 - pos;
1924 if (delta < 0 && pos >= 0)
1925 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1926 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1927 string_length (s) + delta + 1));
1928 if (delta > 0 && pos >= 0)
1929 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1931 else /* String has been demoted from BIG_STRING. */
1934 allocate_string_chars_struct (s, newfullsize)->chars;
1935 Bufbyte *old_data = string_data (s);
1939 memcpy (new_data, old_data, pos);
1940 memcpy (new_data + pos + delta, old_data + pos,
1941 string_length (s) + 1 - pos);
1943 set_string_data (s, new_data);
1947 else /* old string is small */
1949 if (oldfullsize == newfullsize)
1951 /* special case; size change but the necessary
1952 allocation size won't change (up or down; code
1953 somewhere depends on there not being any unused
1954 allocation space, modulo any alignment
1958 Bufbyte *addroff = pos + string_data (s);
1960 memmove (addroff + delta, addroff,
1961 /* +1 due to zero-termination. */
1962 string_length (s) + 1 - pos);
1967 Bufbyte *old_data = string_data (s);
1969 BIG_STRING_FULLSIZE_P (newfullsize)
1970 ? xnew_array (Bufbyte, string_length (s) + delta + 1)
1971 : allocate_string_chars_struct (s, newfullsize)->chars;
1975 memcpy (new_data, old_data, pos);
1976 memcpy (new_data + pos + delta, old_data + pos,
1977 string_length (s) + 1 - pos);
1979 set_string_data (s, new_data);
1982 /* We need to mark this chunk of the string_chars_block
1983 as unused so that compact_string_chars() doesn't
1985 struct string_chars *old_s_chars = (struct string_chars *)
1986 ((char *) old_data - offsetof (struct string_chars, chars));
1987 /* Sanity check to make sure we aren't hosed by strange
1988 alignment/padding. */
1989 assert (old_s_chars->string == s);
1990 MARK_STRUCT_AS_FREE (old_s_chars);
1991 ((struct unused_string_chars *) old_s_chars)->fullsize =
1997 set_string_length (s, string_length (s) + delta);
1998 /* If pos < 0, the string won't be zero-terminated.
1999 Terminate now just to make sure. */
2000 string_data (s)[string_length (s)] = '\0';
2006 XSETSTRING (string, s);
2007 /* We also have to adjust all of the extent indices after the
2008 place we did the change. We say "pos - 1" because
2009 adjust_extents() is exclusive of the starting position
2011 adjust_extents (string, pos - 1, string_length (s),
2015 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2016 verify_string_chars_integrity ();
2023 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2025 Bufbyte newstr[MAX_EMCHAR_LEN];
2026 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2027 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2028 Bytecount newlen = set_charptr_emchar (newstr, c);
2030 if (oldlen != newlen)
2031 resize_string (s, bytoff, newlen - oldlen);
2032 /* Remember, string_data (s) might have changed so we can't cache it. */
2033 memcpy (string_data (s) + bytoff, newstr, newlen);
2038 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2039 Return a new string consisting of LENGTH copies of CHARACTER.
2040 LENGTH must be a non-negative integer.
2042 (length, character))
2044 CHECK_NATNUM (length);
2045 CHECK_CHAR_COERCE_INT (character);
2047 Bufbyte init_str[MAX_EMCHAR_LEN];
2048 int len = set_charptr_emchar (init_str, XCHAR (character));
2049 Lisp_Object val = make_uninit_string (len * XINT (length));
2052 /* Optimize the single-byte case */
2053 memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val));
2057 Bufbyte *ptr = XSTRING_DATA (val);
2059 for (i = XINT (length); i; i--)
2061 Bufbyte *init_ptr = init_str;
2064 case 4: *ptr++ = *init_ptr++;
2065 case 3: *ptr++ = *init_ptr++;
2066 case 2: *ptr++ = *init_ptr++;
2067 case 1: *ptr++ = *init_ptr++;
2075 DEFUN ("string", Fstring, 0, MANY, 0, /*
2076 Concatenate all the argument characters and make the result a string.
2078 (int nargs, Lisp_Object *args))
2080 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2081 Bufbyte *p = storage;
2083 for (; nargs; nargs--, args++)
2085 Lisp_Object lisp_char = *args;
2086 CHECK_CHAR_COERCE_INT (lisp_char);
2087 p += set_charptr_emchar (p, XCHAR (lisp_char));
2089 return make_string (storage, p - storage);
2093 /* Take some raw memory, which MUST already be in internal format,
2094 and package it up into a Lisp string. */
2096 make_string (const Bufbyte *contents, Bytecount length)
2100 /* Make sure we find out about bad make_string's when they happen */
2101 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2102 bytecount_to_charcount (contents, length); /* Just for the assertions */
2105 val = make_uninit_string (length);
2106 memcpy (XSTRING_DATA (val), contents, length);
2110 /* Take some raw memory, encoded in some external data format,
2111 and convert it into a Lisp string. */
2113 make_ext_string (const Extbyte *contents, EMACS_INT length,
2114 Lisp_Object coding_system)
2117 TO_INTERNAL_FORMAT (DATA, (contents, length),
2118 LISP_STRING, string,
2124 build_string (const char *str)
2126 /* Some strlen's crash and burn if passed null. */
2127 return make_string ((const Bufbyte *) str, (str ? strlen(str) : 0));
2131 build_ext_string (const char *str, Lisp_Object coding_system)
2133 /* Some strlen's crash and burn if passed null. */
2134 return make_ext_string ((const Extbyte *) str, (str ? strlen(str) : 0),
2139 build_translated_string (const char *str)
2141 return build_string (GETTEXT (str));
2145 make_string_nocopy (const Bufbyte *contents, Bytecount length)
2150 /* Make sure we find out about bad make_string_nocopy's when they happen */
2151 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2152 bytecount_to_charcount (contents, length); /* Just for the assertions */
2155 /* Allocate the string header */
2156 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2157 set_lheader_implementation (&s->lheader, &lrecord_string);
2158 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2160 set_string_data (s, (Bufbyte *)contents);
2161 set_string_length (s, length);
2163 XSETSTRING (val, s);
2168 /************************************************************************/
2169 /* lcrecord lists */
2170 /************************************************************************/
2172 /* Lcrecord lists are used to manage the allocation of particular
2173 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2174 malloc() and garbage-collection junk) as much as possible.
2175 It is similar to the Blocktype class.
2179 1) Create an lcrecord-list object using make_lcrecord_list().
2180 This is often done at initialization. Remember to staticpro_nodump
2181 this object! The arguments to make_lcrecord_list() are the
2182 same as would be passed to alloc_lcrecord().
2183 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2184 and pass the lcrecord-list earlier created.
2185 3) When done with the lcrecord, call free_managed_lcrecord().
2186 The standard freeing caveats apply: ** make sure there are no
2187 pointers to the object anywhere! **
2188 4) Calling free_managed_lcrecord() is just like kissing the
2189 lcrecord goodbye as if it were garbage-collected. This means:
2190 -- the contents of the freed lcrecord are undefined, and the
2191 contents of something produced by allocate_managed_lcrecord()
2192 are undefined, just like for alloc_lcrecord().
2193 -- the mark method for the lcrecord's type will *NEVER* be called
2195 -- the finalize method for the lcrecord's type will be called
2196 at the time that free_managed_lcrecord() is called.
2201 mark_lcrecord_list (Lisp_Object obj)
2203 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2204 Lisp_Object chain = list->free;
2206 while (!NILP (chain))
2208 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2209 struct free_lcrecord_header *free_header =
2210 (struct free_lcrecord_header *) lheader;
2213 (/* There should be no other pointers to the free list. */
2214 ! MARKED_RECORD_HEADER_P (lheader)
2216 /* Only lcrecords should be here. */
2217 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
2219 /* Only free lcrecords should be here. */
2220 free_header->lcheader.free
2222 /* The type of the lcrecord must be right. */
2223 LHEADER_IMPLEMENTATION (lheader) == list->implementation
2225 /* So must the size. */
2226 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2227 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
2230 MARK_RECORD_HEADER (lheader);
2231 chain = free_header->chain;
2237 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2238 mark_lcrecord_list, internal_object_printer,
2239 0, 0, 0, 0, struct lcrecord_list);
2241 make_lcrecord_list (size_t size,
2242 const struct lrecord_implementation *implementation)
2244 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2245 &lrecord_lcrecord_list);
2248 p->implementation = implementation;
2251 XSETLCRECORD_LIST (val, p);
2256 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2258 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2259 if (!NILP (list->free))
2261 Lisp_Object val = list->free;
2262 struct free_lcrecord_header *free_header =
2263 (struct free_lcrecord_header *) XPNTR (val);
2265 #ifdef ERROR_CHECK_GC
2266 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2268 /* There should be no other pointers to the free list. */
2269 assert (! MARKED_RECORD_HEADER_P (lheader));
2270 /* Only lcrecords should be here. */
2271 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
2272 /* Only free lcrecords should be here. */
2273 assert (free_header->lcheader.free);
2274 /* The type of the lcrecord must be right. */
2275 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
2276 /* So must the size. */
2277 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2278 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
2279 #endif /* ERROR_CHECK_GC */
2281 list->free = free_header->chain;
2282 free_header->lcheader.free = 0;
2289 XSETOBJ (val, alloc_lcrecord (list->size, list->implementation));
2295 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2297 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2298 struct free_lcrecord_header *free_header =
2299 (struct free_lcrecord_header *) XPNTR (lcrecord);
2300 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2301 const struct lrecord_implementation *implementation
2302 = LHEADER_IMPLEMENTATION (lheader);
2304 /* Make sure the size is correct. This will catch, for example,
2305 putting a window configuration on the wrong free list. */
2306 gc_checking_assert ((implementation->size_in_bytes_method ?
2307 implementation->size_in_bytes_method (lheader) :
2308 implementation->static_size)
2311 if (implementation->finalizer)
2312 implementation->finalizer (lheader, 0);
2313 free_header->chain = list->free;
2314 free_header->lcheader.free = 1;
2315 list->free = lcrecord;
2321 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2322 Kept for compatibility, returns its argument.
2324 Make a copy of OBJECT in pure storage.
2325 Recursively copies contents of vectors and cons cells.
2326 Does not copy symbols.
2334 /************************************************************************/
2335 /* Garbage Collection */
2336 /************************************************************************/
2338 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
2339 Additional ones may be defined by a module (none yet). We leave some
2340 room in `lrecord_implementations_table' for such new lisp object types. */
2341 const struct lrecord_implementation *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT];
2342 unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
2343 /* Object marker functions are in the lrecord_implementation structure.
2344 But copying them to a parallel array is much more cache-friendly.
2345 This hack speeds up (garbage-collect) by about 5%. */
2346 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
2348 struct gcpro *gcprolist;
2350 /* 415 used Mly 29-Jun-93 */
2351 /* 1327 used slb 28-Feb-98 */
2352 /* 1328 used og 03-Oct-99 (moving slowly, heh?) */
2354 #define NSTATICS 4000
2356 #define NSTATICS 2000
2359 /* Not "static" because used by dumper.c */
2360 Lisp_Object *staticvec[NSTATICS];
2363 /* Put an entry in staticvec, pointing at the variable whose address is given
2366 staticpro (Lisp_Object *varaddress)
2368 /* #### This is now a dubious assert() since this routine may be called */
2369 /* by Lisp attempting to load a DLL. */
2370 assert (staticidx < countof (staticvec));
2371 staticvec[staticidx++] = varaddress;
2375 Lisp_Object *staticvec_nodump[200];
2376 int staticidx_nodump;
2378 /* Put an entry in staticvec_nodump, pointing at the variable whose address is given
2381 staticpro_nodump (Lisp_Object *varaddress)
2383 /* #### This is now a dubious assert() since this routine may be called */
2384 /* by Lisp attempting to load a DLL. */
2385 assert (staticidx_nodump < countof (staticvec_nodump));
2386 staticvec_nodump[staticidx_nodump++] = varaddress;
2390 struct pdump_dumpstructinfo dumpstructvec[200];
2393 /* Put an entry in dumpstructvec, pointing at the variable whose address is given
2396 dumpstruct (void *varaddress, const struct struct_description *desc)
2398 assert (dumpstructidx < countof (dumpstructvec));
2399 dumpstructvec[dumpstructidx].data = varaddress;
2400 dumpstructvec[dumpstructidx].desc = desc;
2404 struct pdump_dumpopaqueinfo dumpopaquevec[250];
2407 /* Put an entry in dumpopaquevec, pointing at the variable whose address is given
2410 dumpopaque (void *varaddress, size_t size)
2412 assert (dumpopaqueidx < countof (dumpopaquevec));
2414 dumpopaquevec[dumpopaqueidx].data = varaddress;
2415 dumpopaquevec[dumpopaqueidx].size = size;
2419 Lisp_Object *pdump_wirevec[50];
2422 /* Put an entry in pdump_wirevec, pointing at the variable whose address is given
2425 pdump_wire (Lisp_Object *varaddress)
2427 assert (pdump_wireidx < countof (pdump_wirevec));
2428 pdump_wirevec[pdump_wireidx++] = varaddress;
2432 Lisp_Object *pdump_wirevec_list[50];
2433 int pdump_wireidx_list;
2435 /* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given
2438 pdump_wire_list (Lisp_Object *varaddress)
2440 assert (pdump_wireidx_list < countof (pdump_wirevec_list));
2441 pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
2444 #ifdef ERROR_CHECK_GC
2445 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
2446 struct lrecord_header * GCLI_lh = (lheader); \
2447 assert (GCLI_lh != 0); \
2448 assert (GCLI_lh->type < lrecord_type_count); \
2449 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
2450 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
2451 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
2454 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
2458 /* Mark reference to a Lisp_Object. If the object referred to has not been
2459 seen yet, recursively mark all the references contained in it. */
2462 mark_object (Lisp_Object obj)
2466 /* Checks we used to perform */
2467 /* if (EQ (obj, Qnull_pointer)) return; */
2468 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2469 /* if (PURIFIED (XPNTR (obj))) return; */
2471 if (XTYPE (obj) == Lisp_Type_Record)
2473 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2475 GC_CHECK_LHEADER_INVARIANTS (lheader);
2477 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
2478 ! ((struct lcrecord_header *) lheader)->free);
2480 /* All c_readonly objects have their mark bit set,
2481 so that we only need to check the mark bit here. */
2482 if (! MARKED_RECORD_HEADER_P (lheader))
2484 MARK_RECORD_HEADER (lheader);
2486 if (RECORD_MARKER (lheader))
2488 obj = RECORD_MARKER (lheader) (obj);
2489 if (!NILP (obj)) goto tail_recurse;
2495 /* mark all of the conses in a list and mark the final cdr; but
2496 DO NOT mark the cars.
2498 Use only for internal lists! There should never be other pointers
2499 to the cons cells, because if so, the cars will remain unmarked
2500 even when they maybe should be marked. */
2502 mark_conses_in_list (Lisp_Object obj)
2506 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2508 if (CONS_MARKED_P (XCONS (rest)))
2510 MARK_CONS (XCONS (rest));
2517 /* Find all structures not marked, and free them. */
2519 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2520 static int gc_count_bit_vector_storage;
2521 static int gc_count_num_short_string_in_use;
2522 static int gc_count_string_total_size;
2523 static int gc_count_short_string_total_size;
2525 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2528 /* stats on lcrecords in use - kinda kludgy */
2532 int instances_in_use;
2534 int instances_freed;
2536 int instances_on_free_list;
2537 } lcrecord_stats [countof (lrecord_implementations_table)];
2540 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
2542 unsigned int type_index = h->type;
2544 if (((struct lcrecord_header *) h)->free)
2546 gc_checking_assert (!free_p);
2547 lcrecord_stats[type_index].instances_on_free_list++;
2551 const struct lrecord_implementation *implementation =
2552 LHEADER_IMPLEMENTATION (h);
2554 size_t sz = (implementation->size_in_bytes_method ?
2555 implementation->size_in_bytes_method (h) :
2556 implementation->static_size);
2559 lcrecord_stats[type_index].instances_freed++;
2560 lcrecord_stats[type_index].bytes_freed += sz;
2564 lcrecord_stats[type_index].instances_in_use++;
2565 lcrecord_stats[type_index].bytes_in_use += sz;
2571 /* Free all unmarked records */
2573 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2575 struct lcrecord_header *header;
2577 /* int total_size = 0; */
2579 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2581 /* First go through and call all the finalize methods.
2582 Then go through and free the objects. There used to
2583 be only one loop here, with the call to the finalizer
2584 occurring directly before the xfree() below. That
2585 is marginally faster but much less safe -- if the
2586 finalize method for an object needs to reference any
2587 other objects contained within it (and many do),
2588 we could easily be screwed by having already freed that
2591 for (header = *prev; header; header = header->next)
2593 struct lrecord_header *h = &(header->lheader);
2595 GC_CHECK_LHEADER_INVARIANTS (h);
2597 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
2599 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2600 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2604 for (header = *prev; header; )
2606 struct lrecord_header *h = &(header->lheader);
2607 if (MARKED_RECORD_HEADER_P (h))
2609 if (! C_READONLY_RECORD_HEADER_P (h))
2610 UNMARK_RECORD_HEADER (h);
2612 /* total_size += n->implementation->size_in_bytes (h);*/
2613 /* #### May modify header->next on a C_READONLY lcrecord */
2614 prev = &(header->next);
2616 tick_lcrecord_stats (h, 0);
2620 struct lcrecord_header *next = header->next;
2622 tick_lcrecord_stats (h, 1);
2623 /* used to call finalizer right here. */
2629 /* *total = total_size; */
2634 sweep_bit_vectors_1 (Lisp_Object *prev,
2635 int *used, int *total, int *storage)
2637 Lisp_Object bit_vector;
2640 int total_storage = 0;
2642 /* BIT_VECTORP fails because the objects are marked, which changes
2643 their implementation */
2644 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2646 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2648 if (MARKED_RECORD_P (bit_vector))
2650 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
2651 UNMARK_RECORD_HEADER (&(v->lheader));
2655 FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2656 BIT_VECTOR_LONG_STORAGE (len));
2658 /* #### May modify next on a C_READONLY bitvector */
2659 prev = &(bit_vector_next (v));
2664 Lisp_Object next = bit_vector_next (v);
2671 *total = total_size;
2672 *storage = total_storage;
2675 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2676 to make macros prettier. */
2678 #ifdef ERROR_CHECK_GC
2680 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2682 struct typename##_block *SFTB_current; \
2684 int num_free = 0, num_used = 0; \
2686 for (SFTB_current = current_##typename##_block, \
2687 SFTB_limit = current_##typename##_block_index; \
2693 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2695 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2697 if (FREE_STRUCT_P (SFTB_victim)) \
2701 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2705 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2708 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2713 UNMARK_##typename (SFTB_victim); \
2716 SFTB_current = SFTB_current->prev; \
2717 SFTB_limit = countof (current_##typename##_block->block); \
2720 gc_count_num_##typename##_in_use = num_used; \
2721 gc_count_num_##typename##_freelist = num_free; \
2724 #else /* !ERROR_CHECK_GC */
2726 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2728 struct typename##_block *SFTB_current; \
2729 struct typename##_block **SFTB_prev; \
2731 int num_free = 0, num_used = 0; \
2733 typename##_free_list = 0; \
2735 for (SFTB_prev = ¤t_##typename##_block, \
2736 SFTB_current = current_##typename##_block, \
2737 SFTB_limit = current_##typename##_block_index; \
2742 int SFTB_empty = 1; \
2743 obj_type *SFTB_old_free_list = typename##_free_list; \
2745 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2747 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2749 if (FREE_STRUCT_P (SFTB_victim)) \
2752 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2754 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2759 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2762 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2768 UNMARK_##typename (SFTB_victim); \
2773 SFTB_prev = &(SFTB_current->prev); \
2774 SFTB_current = SFTB_current->prev; \
2776 else if (SFTB_current == current_##typename##_block \
2777 && !SFTB_current->prev) \
2779 /* No real point in freeing sole allocation block */ \
2784 struct typename##_block *SFTB_victim_block = SFTB_current; \
2785 if (SFTB_victim_block == current_##typename##_block) \
2786 current_##typename##_block_index \
2787 = countof (current_##typename##_block->block); \
2788 SFTB_current = SFTB_current->prev; \
2790 *SFTB_prev = SFTB_current; \
2791 xfree (SFTB_victim_block); \
2792 /* Restore free list to what it was before victim was swept */ \
2793 typename##_free_list = SFTB_old_free_list; \
2794 num_free -= SFTB_limit; \
2797 SFTB_limit = countof (current_##typename##_block->block); \
2800 gc_count_num_##typename##_in_use = num_used; \
2801 gc_count_num_##typename##_freelist = num_free; \
2804 #endif /* !ERROR_CHECK_GC */
2812 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2813 #define ADDITIONAL_FREE_cons(ptr)
2815 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2818 /* Explicitly free a cons cell. */
2820 free_cons (Lisp_Cons *ptr)
2822 #ifdef ERROR_CHECK_GC
2823 /* If the CAR is not an int, then it will be a pointer, which will
2824 always be four-byte aligned. If this cons cell has already been
2825 placed on the free list, however, its car will probably contain
2826 a chain pointer to the next cons on the list, which has cleverly
2827 had all its 0's and 1's inverted. This allows for a quick
2828 check to make sure we're not freeing something already freed. */
2829 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2830 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2831 #endif /* ERROR_CHECK_GC */
2833 #ifndef ALLOC_NO_POOLS
2834 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2835 #endif /* ALLOC_NO_POOLS */
2838 /* explicitly free a list. You **must make sure** that you have
2839 created all the cons cells that make up this list and that there
2840 are no pointers to any of these cons cells anywhere else. If there
2841 are, you will lose. */
2844 free_list (Lisp_Object list)
2846 Lisp_Object rest, next;
2848 for (rest = list; !NILP (rest); rest = next)
2851 free_cons (XCONS (rest));
2855 /* explicitly free an alist. You **must make sure** that you have
2856 created all the cons cells that make up this alist and that there
2857 are no pointers to any of these cons cells anywhere else. If there
2858 are, you will lose. */
2861 free_alist (Lisp_Object alist)
2863 Lisp_Object rest, next;
2865 for (rest = alist; !NILP (rest); rest = next)
2868 free_cons (XCONS (XCAR (rest)));
2869 free_cons (XCONS (rest));
2874 sweep_compiled_functions (void)
2876 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2877 #define ADDITIONAL_FREE_compiled_function(ptr)
2879 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2883 #ifdef LISP_FLOAT_TYPE
2887 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2888 #define ADDITIONAL_FREE_float(ptr)
2890 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
2892 #endif /* LISP_FLOAT_TYPE */
2895 sweep_symbols (void)
2897 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2898 #define ADDITIONAL_FREE_symbol(ptr)
2900 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
2904 sweep_extents (void)
2906 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2907 #define ADDITIONAL_FREE_extent(ptr)
2909 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2915 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2916 #define ADDITIONAL_FREE_event(ptr)
2918 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
2922 sweep_markers (void)
2924 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2925 #define ADDITIONAL_FREE_marker(ptr) \
2926 do { Lisp_Object tem; \
2927 XSETMARKER (tem, ptr); \
2928 unchain_marker (tem); \
2931 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
2934 /* Explicitly free a marker. */
2936 free_marker (Lisp_Marker *ptr)
2938 /* Perhaps this will catch freeing an already-freed marker. */
2939 gc_checking_assert (ptr->lheader.type == lrecord_type_marker);
2941 #ifndef ALLOC_NO_POOLS
2942 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
2943 #endif /* ALLOC_NO_POOLS */
2947 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2950 verify_string_chars_integrity (void)
2952 struct string_chars_block *sb;
2954 /* Scan each existing string block sequentially, string by string. */
2955 for (sb = first_string_chars_block; sb; sb = sb->next)
2958 /* POS is the index of the next string in the block. */
2959 while (pos < sb->pos)
2961 struct string_chars *s_chars =
2962 (struct string_chars *) &(sb->string_chars[pos]);
2963 Lisp_String *string;
2967 /* If the string_chars struct is marked as free (i.e. the STRING
2968 pointer is 0xFFFFFFFF) then this is an unused chunk of string
2969 storage. (See below.) */
2971 if (FREE_STRUCT_P (s_chars))
2973 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
2978 string = s_chars->string;
2979 /* Must be 32-bit aligned. */
2980 assert ((((int) string) & 3) == 0);
2982 size = string_length (string);
2983 fullsize = STRING_FULLSIZE (size);
2985 assert (!BIG_STRING_FULLSIZE_P (fullsize));
2986 assert (string_data (string) == s_chars->chars);
2989 assert (pos == sb->pos);
2993 #endif /* MULE && ERROR_CHECK_GC */
2995 /* Compactify string chars, relocating the reference to each --
2996 free any empty string_chars_block we see. */
2998 compact_string_chars (void)
3000 struct string_chars_block *to_sb = first_string_chars_block;
3002 struct string_chars_block *from_sb;
3004 /* Scan each existing string block sequentially, string by string. */
3005 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3008 /* FROM_POS is the index of the next string in the block. */
3009 while (from_pos < from_sb->pos)
3011 struct string_chars *from_s_chars =
3012 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3013 struct string_chars *to_s_chars;
3014 Lisp_String *string;
3018 /* If the string_chars struct is marked as free (i.e. the STRING
3019 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3020 storage. This happens under Mule when a string's size changes
3021 in such a way that its fullsize changes. (Strings can change
3022 size because a different-length character can be substituted
3023 for another character.) In this case, after the bogus string
3024 pointer is the "fullsize" of this entry, i.e. how many bytes
3027 if (FREE_STRUCT_P (from_s_chars))
3029 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3030 from_pos += fullsize;
3034 string = from_s_chars->string;
3035 assert (!(FREE_STRUCT_P (string)));
3037 size = string_length (string);
3038 fullsize = STRING_FULLSIZE (size);
3040 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
3042 /* Just skip it if it isn't marked. */
3043 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3045 from_pos += fullsize;
3049 /* If it won't fit in what's left of TO_SB, close TO_SB out
3050 and go on to the next string_chars_block. We know that TO_SB
3051 cannot advance past FROM_SB here since FROM_SB is large enough
3052 to currently contain this string. */
3053 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3055 to_sb->pos = to_pos;
3056 to_sb = to_sb->next;
3060 /* Compute new address of this string
3061 and update TO_POS for the space being used. */
3062 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3064 /* Copy the string_chars to the new place. */
3065 if (from_s_chars != to_s_chars)
3066 memmove (to_s_chars, from_s_chars, fullsize);
3068 /* Relocate FROM_S_CHARS's reference */
3069 set_string_data (string, &(to_s_chars->chars[0]));
3071 from_pos += fullsize;
3076 /* Set current to the last string chars block still used and
3077 free any that follow. */
3079 struct string_chars_block *victim;
3081 for (victim = to_sb->next; victim; )
3083 struct string_chars_block *next = victim->next;
3088 current_string_chars_block = to_sb;
3089 current_string_chars_block->pos = to_pos;
3090 current_string_chars_block->next = 0;
3094 #if 1 /* Hack to debug missing purecopy's */
3095 static int debug_string_purity;
3098 debug_string_purity_print (Lisp_String *p)
3101 Charcount s = string_char_length (p);
3103 for (i = 0; i < s; i++)
3105 Emchar ch = string_char (p, i);
3106 if (ch < 32 || ch >= 126)
3107 stderr_out ("\\%03o", ch);
3108 else if (ch == '\\' || ch == '\"')
3109 stderr_out ("\\%c", ch);
3111 stderr_out ("%c", ch);
3113 stderr_out ("\"\n");
3119 sweep_strings (void)
3121 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3122 int debug = debug_string_purity;
3124 #define UNMARK_string(ptr) do { \
3125 Lisp_String *p = (ptr); \
3126 size_t size = string_length (p); \
3127 UNMARK_RECORD_HEADER (&(p->lheader)); \
3128 num_bytes += size; \
3129 if (!BIG_STRING_SIZE_P (size)) \
3131 num_small_bytes += size; \
3135 debug_string_purity_print (p); \
3137 #define ADDITIONAL_FREE_string(ptr) do { \
3138 size_t size = string_length (ptr); \
3139 if (BIG_STRING_SIZE_P (size)) \
3140 xfree (ptr->data); \
3143 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3145 gc_count_num_short_string_in_use = num_small_used;
3146 gc_count_string_total_size = num_bytes;
3147 gc_count_short_string_total_size = num_small_bytes;
3151 /* I hate duplicating all this crap! */
3153 marked_p (Lisp_Object obj)
3155 /* Checks we used to perform. */
3156 /* if (EQ (obj, Qnull_pointer)) return 1; */
3157 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3158 /* if (PURIFIED (XPNTR (obj))) return 1; */
3160 if (XTYPE (obj) == Lisp_Type_Record)
3162 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3164 GC_CHECK_LHEADER_INVARIANTS (lheader);
3166 return MARKED_RECORD_HEADER_P (lheader);
3174 /* Free all unmarked records. Do this at the very beginning,
3175 before anything else, so that the finalize methods can safely
3176 examine items in the objects. sweep_lcrecords_1() makes
3177 sure to call all the finalize methods *before* freeing anything,
3178 to complete the safety. */
3181 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3184 compact_string_chars ();
3186 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3187 macros) must be *extremely* careful to make sure they're not
3188 referencing freed objects. The only two existing finalize
3189 methods (for strings and markers) pass muster -- the string
3190 finalizer doesn't look at anything but its own specially-
3191 created block, and the marker finalizer only looks at live
3192 buffers (which will never be freed) and at the markers before
3193 and after it in the chain (which, by induction, will never be
3194 freed because if so, they would have already removed themselves
3197 /* Put all unmarked strings on free list, free'ing the string chars
3198 of large unmarked strings */
3201 /* Put all unmarked conses on free list */
3204 /* Free all unmarked bit vectors */
3205 sweep_bit_vectors_1 (&all_bit_vectors,
3206 &gc_count_num_bit_vector_used,
3207 &gc_count_bit_vector_total_size,
3208 &gc_count_bit_vector_storage);
3210 /* Free all unmarked compiled-function objects */
3211 sweep_compiled_functions ();
3213 #ifdef LISP_FLOAT_TYPE
3214 /* Put all unmarked floats on free list */
3218 /* Put all unmarked symbols on free list */
3221 /* Put all unmarked extents on free list */
3224 /* Put all unmarked markers on free list.
3225 Dechain each one first from the buffer into which it points. */
3231 pdump_objects_unmark ();
3235 /* Clearing for disksave. */
3238 disksave_object_finalization (void)
3240 /* It's important that certain information from the environment not get
3241 dumped with the executable (pathnames, environment variables, etc.).
3242 To make it easier to tell when this has happened with strings(1) we
3243 clear some known-to-be-garbage blocks of memory, so that leftover
3244 results of old evaluation don't look like potential problems.
3245 But first we set some notable variables to nil and do one more GC,
3246 to turn those strings into garbage.
3249 /* Yeah, this list is pretty ad-hoc... */
3250 Vprocess_environment = Qnil;
3251 Vexec_directory = Qnil;
3252 Vdata_directory = Qnil;
3253 Vsite_directory = Qnil;
3254 Vdoc_directory = Qnil;
3255 Vconfigure_info_directory = Qnil;
3258 /* Vdump_load_path = Qnil; */
3259 /* Release hash tables for locate_file */
3260 Flocate_file_clear_hashing (Qt);
3261 uncache_home_directory();
3263 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3264 defined(LOADHIST_BUILTIN))
3265 Vload_history = Qnil;
3267 Vshell_file_name = Qnil;
3269 garbage_collect_1 ();
3271 /* Run the disksave finalization methods of all live objects. */
3272 disksave_object_finalization_1 ();
3274 /* Zero out the uninitialized (really, unused) part of the containers
3275 for the live strings. */
3277 struct string_chars_block *scb;
3278 for (scb = first_string_chars_block; scb; scb = scb->next)
3280 int count = sizeof (scb->string_chars) - scb->pos;
3282 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3285 /* from the block's fill ptr to the end */
3286 memset ((scb->string_chars + scb->pos), 0, count);
3291 /* There, that ought to be enough... */
3297 restore_gc_inhibit (Lisp_Object val)
3299 gc_currently_forbidden = XINT (val);
3303 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3304 static int gc_hooks_inhibited;
3308 garbage_collect_1 (void)
3310 #if MAX_SAVE_STACK > 0
3311 char stack_top_variable;
3312 extern char *stack_bottom;
3317 Lisp_Object pre_gc_cursor;
3318 struct gcpro gcpro1;
3321 || gc_currently_forbidden
3323 || preparing_for_armageddon)
3326 /* We used to call selected_frame() here.
3328 The following functions cannot be called inside GC
3329 so we move to after the above tests. */
3332 Lisp_Object device = Fselected_device (Qnil);
3333 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3335 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3337 signal_simple_error ("No frames exist on device", device);
3341 pre_gc_cursor = Qnil;
3344 GCPRO1 (pre_gc_cursor);
3346 /* Very important to prevent GC during any of the following
3347 stuff that might run Lisp code; otherwise, we'll likely
3348 have infinite GC recursion. */
3349 speccount = specpdl_depth ();
3350 record_unwind_protect (restore_gc_inhibit,
3351 make_int (gc_currently_forbidden));
3352 gc_currently_forbidden = 1;
3354 if (!gc_hooks_inhibited)
3355 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3357 /* Now show the GC cursor/message. */
3358 if (!noninteractive)
3360 if (FRAME_WIN_P (f))
3362 Lisp_Object frame = make_frame (f);
3363 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3364 FRAME_SELECTED_WINDOW (f),
3366 pre_gc_cursor = f->pointer;
3367 if (POINTER_IMAGE_INSTANCEP (cursor)
3368 /* don't change if we don't know how to change back. */
3369 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3372 Fset_frame_pointer (frame, cursor);
3376 /* Don't print messages to the stream device. */
3377 if (!cursor_changed && !FRAME_STREAM_P (f))
3379 char *msg = (STRINGP (Vgc_message)
3380 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3382 Lisp_Object args[2], whole_msg;
3383 args[0] = build_string (msg ? msg :
3384 GETTEXT ((const char *) gc_default_message));
3385 args[1] = build_string ("...");
3386 whole_msg = Fconcat (2, args);
3387 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3388 Qgarbage_collecting);
3392 /***** Now we actually start the garbage collection. */
3396 gc_generation_number[0]++;
3398 #if MAX_SAVE_STACK > 0
3400 /* Save a copy of the contents of the stack, for debugging. */
3403 /* Static buffer in which we save a copy of the C stack at each GC. */
3404 static char *stack_copy;
3405 static size_t stack_copy_size;
3407 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3408 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3409 if (stack_size < MAX_SAVE_STACK)
3411 if (stack_copy_size < stack_size)
3413 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3414 stack_copy_size = stack_size;
3418 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3422 #endif /* MAX_SAVE_STACK > 0 */
3424 /* Do some totally ad-hoc resource clearing. */
3425 /* #### generalize this? */
3426 clear_event_resource ();
3427 cleanup_specifiers ();
3429 /* Mark all the special slots that serve as the roots of accessibility. */
3433 for (i = 0; i < staticidx; i++)
3434 mark_object (*(staticvec[i]));
3435 for (i = 0; i < staticidx_nodump; i++)
3436 mark_object (*(staticvec_nodump[i]));
3442 for (tail = gcprolist; tail; tail = tail->next)
3443 for (i = 0; i < tail->nvars; i++)
3444 mark_object (tail->var[i]);
3448 struct specbinding *bind;
3449 for (bind = specpdl; bind != specpdl_ptr; bind++)
3451 mark_object (bind->symbol);
3452 mark_object (bind->old_value);
3457 struct catchtag *catch;
3458 for (catch = catchlist; catch; catch = catch->next)
3460 mark_object (catch->tag);
3461 mark_object (catch->val);
3466 struct backtrace *backlist;
3467 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3469 int nargs = backlist->nargs;
3472 mark_object (*backlist->function);
3473 if (nargs == UNEVALLED || nargs == MANY)
3474 mark_object (backlist->args[0]);
3476 for (i = 0; i < nargs; i++)
3477 mark_object (backlist->args[i]);
3482 mark_profiling_info ();
3484 /* OK, now do the after-mark stuff. This is for things that
3485 are only marked when something else is marked (e.g. weak hash tables).
3486 There may be complex dependencies between such objects -- e.g.
3487 a weak hash table might be unmarked, but after processing a later
3488 weak hash table, the former one might get marked. So we have to
3489 iterate until nothing more gets marked. */
3491 while (finish_marking_weak_hash_tables () > 0 ||
3492 finish_marking_weak_lists () > 0)
3495 /* And prune (this needs to be called after everything else has been
3496 marked and before we do any sweeping). */
3497 /* #### this is somewhat ad-hoc and should probably be an object
3499 prune_weak_hash_tables ();
3500 prune_weak_lists ();
3501 prune_specifiers ();
3502 prune_syntax_tables ();
3506 consing_since_gc = 0;
3507 #ifndef DEBUG_XEMACS
3508 /* Allow you to set it really fucking low if you really want ... */
3509 if (gc_cons_threshold < 10000)
3510 gc_cons_threshold = 10000;
3515 /******* End of garbage collection ********/
3517 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3519 /* Now remove the GC cursor/message */
3520 if (!noninteractive)
3523 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3524 else if (!FRAME_STREAM_P (f))
3526 char *msg = (STRINGP (Vgc_message)
3527 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3530 /* Show "...done" only if the echo area would otherwise be empty. */
3531 if (NILP (clear_echo_area (selected_frame (),
3532 Qgarbage_collecting, 0)))
3534 Lisp_Object args[2], whole_msg;
3535 args[0] = build_string (msg ? msg :
3536 GETTEXT ((const char *)
3537 gc_default_message));
3538 args[1] = build_string ("... done");
3539 whole_msg = Fconcat (2, args);
3540 echo_area_message (selected_frame (), (Bufbyte *) 0,
3542 Qgarbage_collecting);
3547 /* now stop inhibiting GC */
3548 unbind_to (speccount, Qnil);
3550 if (!breathing_space)
3552 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3559 /* Debugging aids. */
3562 gc_plist_hack (const char *name, int value, Lisp_Object tail)
3564 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3565 or portable numeric datatypes, or bit-vectors, or characters, or
3566 arrays, or exceptions, or ...) */
3567 return cons3 (intern (name), make_int (value), tail);
3570 #define HACK_O_MATIC(type, name, pl) do { \
3572 struct type##_block *x = current_##type##_block; \
3573 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3574 (pl) = gc_plist_hack ((name), s, (pl)); \
3577 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3578 Reclaim storage for Lisp objects no longer needed.
3579 Return info on amount of space in use:
3580 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3581 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3583 where `PLIST' is a list of alternating keyword/value pairs providing
3584 more detailed information.
3585 Garbage collection happens automatically if you cons more than
3586 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3590 Lisp_Object pl = Qnil;
3592 int gc_count_vector_total_size = 0;
3594 garbage_collect_1 ();
3596 for (i = 0; i < lrecord_type_count; i++)
3598 if (lcrecord_stats[i].bytes_in_use != 0
3599 || lcrecord_stats[i].bytes_freed != 0
3600 || lcrecord_stats[i].instances_on_free_list != 0)
3603 const char *name = lrecord_implementations_table[i]->name;
3604 int len = strlen (name);
3605 /* save this for the FSFmacs-compatible part of the summary */
3606 if (i == lrecord_vector.lrecord_type_index)
3607 gc_count_vector_total_size =
3608 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3610 sprintf (buf, "%s-storage", name);
3611 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3612 /* Okay, simple pluralization check for `symbol-value-varalias' */
3613 if (name[len-1] == 's')
3614 sprintf (buf, "%ses-freed", name);
3616 sprintf (buf, "%ss-freed", name);
3617 if (lcrecord_stats[i].instances_freed != 0)
3618 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3619 if (name[len-1] == 's')
3620 sprintf (buf, "%ses-on-free-list", name);
3622 sprintf (buf, "%ss-on-free-list", name);
3623 if (lcrecord_stats[i].instances_on_free_list != 0)
3624 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3626 if (name[len-1] == 's')
3627 sprintf (buf, "%ses-used", name);
3629 sprintf (buf, "%ss-used", name);
3630 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3634 HACK_O_MATIC (extent, "extent-storage", pl);
3635 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3636 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3637 HACK_O_MATIC (event, "event-storage", pl);
3638 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3639 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3640 HACK_O_MATIC (marker, "marker-storage", pl);
3641 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3642 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3643 #ifdef LISP_FLOAT_TYPE
3644 HACK_O_MATIC (float, "float-storage", pl);
3645 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3646 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3647 #endif /* LISP_FLOAT_TYPE */
3648 HACK_O_MATIC (string, "string-header-storage", pl);
3649 pl = gc_plist_hack ("long-strings-total-length",
3650 gc_count_string_total_size
3651 - gc_count_short_string_total_size, pl);
3652 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3653 pl = gc_plist_hack ("short-strings-total-length",
3654 gc_count_short_string_total_size, pl);
3655 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3656 pl = gc_plist_hack ("long-strings-used",
3657 gc_count_num_string_in_use
3658 - gc_count_num_short_string_in_use, pl);
3659 pl = gc_plist_hack ("short-strings-used",
3660 gc_count_num_short_string_in_use, pl);
3662 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3663 pl = gc_plist_hack ("compiled-functions-free",
3664 gc_count_num_compiled_function_freelist, pl);
3665 pl = gc_plist_hack ("compiled-functions-used",
3666 gc_count_num_compiled_function_in_use, pl);
3668 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3669 pl = gc_plist_hack ("bit-vectors-total-length",
3670 gc_count_bit_vector_total_size, pl);
3671 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3673 HACK_O_MATIC (symbol, "symbol-storage", pl);
3674 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3675 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3677 HACK_O_MATIC (cons, "cons-storage", pl);
3678 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3679 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3681 /* The things we do for backwards-compatibility */
3683 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3684 make_int (gc_count_num_cons_freelist)),
3685 Fcons (make_int (gc_count_num_symbol_in_use),
3686 make_int (gc_count_num_symbol_freelist)),
3687 Fcons (make_int (gc_count_num_marker_in_use),
3688 make_int (gc_count_num_marker_freelist)),
3689 make_int (gc_count_string_total_size),
3690 make_int (gc_count_vector_total_size),
3695 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3696 Return the number of bytes consed since the last garbage collection.
3697 \"Consed\" is a misnomer in that this actually counts allocation
3698 of all different kinds of objects, not just conses.
3700 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3704 return make_int (consing_since_gc);
3708 DEFUN ("memory-limit", Fmemory_limit, 0, 0, 0, /*
3709 Return the address of the last byte Emacs has allocated, divided by 1024.
3710 This may be helpful in debugging Emacs's memory usage.
3711 The value is divided by 1024 to make sure it will fit in a lisp integer.
3715 return make_int ((EMACS_INT) sbrk (0) / 1024);
3721 object_dead_p (Lisp_Object obj)
3723 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3724 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3725 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3726 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3727 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3728 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3729 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3732 #ifdef MEMORY_USAGE_STATS
3734 /* Attempt to determine the actual amount of space that is used for
3735 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3737 It seems that the following holds:
3739 1. When using the old allocator (malloc.c):
3741 -- blocks are always allocated in chunks of powers of two. For
3742 each block, there is an overhead of 8 bytes if rcheck is not
3743 defined, 20 bytes if it is defined. In other words, a
3744 one-byte allocation needs 8 bytes of overhead for a total of
3745 9 bytes, and needs to have 16 bytes of memory chunked out for
3748 2. When using the new allocator (gmalloc.c):
3750 -- blocks are always allocated in chunks of powers of two up
3751 to 4096 bytes. Larger blocks are allocated in chunks of
3752 an integral multiple of 4096 bytes. The minimum block
3753 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3754 is defined. There is no per-block overhead, but there
3755 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3758 3. When using the system malloc, anything goes, but they are
3759 generally slower and more space-efficient than the GNU
3760 allocators. One possibly reasonable assumption to make
3761 for want of better data is that sizeof (void *), or maybe
3762 2 * sizeof (void *), is required as overhead and that
3763 blocks are allocated in the minimum required size except
3764 that some minimum block size is imposed (e.g. 16 bytes). */
3767 malloced_storage_size (void *ptr, size_t claimed_size,
3768 struct overhead_stats *stats)
3770 size_t orig_claimed_size = claimed_size;
3774 if (claimed_size < 2 * sizeof (void *))
3775 claimed_size = 2 * sizeof (void *);
3776 # ifdef SUNOS_LOCALTIME_BUG
3777 if (claimed_size < 16)
3780 if (claimed_size < 4096)
3784 /* compute the log base two, more or less, then use it to compute
3785 the block size needed. */
3787 /* It's big, it's heavy, it's wood! */
3788 while ((claimed_size /= 2) != 0)
3791 /* It's better than bad, it's good! */
3797 /* We have to come up with some average about the amount of
3799 if ((size_t) (rand () & 4095) < claimed_size)
3800 claimed_size += 3 * sizeof (void *);
3804 claimed_size += 4095;
3805 claimed_size &= ~4095;
3806 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3809 #elif defined (SYSTEM_MALLOC)
3811 if (claimed_size < 16)
3813 claimed_size += 2 * sizeof (void *);
3815 #else /* old GNU allocator */
3817 # ifdef rcheck /* #### may not be defined here */
3825 /* compute the log base two, more or less, then use it to compute
3826 the block size needed. */
3828 /* It's big, it's heavy, it's wood! */
3829 while ((claimed_size /= 2) != 0)
3832 /* It's better than bad, it's good! */
3840 #endif /* old GNU allocator */
3844 stats->was_requested += orig_claimed_size;
3845 stats->malloc_overhead += claimed_size - orig_claimed_size;
3847 return claimed_size;
3851 fixed_type_block_overhead (size_t size)
3853 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3854 size_t overhead = 0;
3855 size_t storage_size = malloced_storage_size (0, per_block, 0);
3856 while (size >= per_block)
3859 overhead += sizeof (void *) + per_block - storage_size;
3861 if (rand () % per_block < size)
3862 overhead += sizeof (void *) + per_block - storage_size;
3866 #endif /* MEMORY_USAGE_STATS */
3869 /* Initialization */
3871 reinit_alloc_once_early (void)
3873 gc_generation_number[0] = 0;
3874 breathing_space = 0;
3875 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3876 XSETINT (Vgc_message, 0);
3878 ignore_malloc_warnings = 1;
3879 #ifdef DOUG_LEA_MALLOC
3880 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3881 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3882 #if 0 /* Moved to emacs.c */
3883 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3886 init_string_alloc ();
3887 init_string_chars_alloc ();
3889 init_symbol_alloc ();
3890 init_compiled_function_alloc ();
3891 #ifdef LISP_FLOAT_TYPE
3892 init_float_alloc ();
3893 #endif /* LISP_FLOAT_TYPE */
3894 init_marker_alloc ();
3895 init_extent_alloc ();
3896 init_event_alloc ();
3898 ignore_malloc_warnings = 0;
3900 staticidx_nodump = 0;
3904 consing_since_gc = 0;
3906 gc_cons_threshold = 500000; /* XEmacs change */
3908 gc_cons_threshold = 15000; /* debugging */
3910 lrecord_uid_counter = 259;
3911 debug_string_purity = 0;
3914 gc_currently_forbidden = 0;
3915 gc_hooks_inhibited = 0;
3917 #ifdef ERROR_CHECK_TYPECHECK
3918 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3921 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3923 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3925 #endif /* ERROR_CHECK_TYPECHECK */
3929 init_alloc_once_early (void)
3931 reinit_alloc_once_early ();
3935 for (i = 0; i < countof (lrecord_implementations_table); i++)
3936 lrecord_implementations_table[i] = 0;
3939 INIT_LRECORD_IMPLEMENTATION (cons);
3940 INIT_LRECORD_IMPLEMENTATION (vector);
3941 INIT_LRECORD_IMPLEMENTATION (string);
3942 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
3947 int pure_bytes_used = 0;
3956 syms_of_alloc (void)
3958 DEFSYMBOL (Qpre_gc_hook);
3959 DEFSYMBOL (Qpost_gc_hook);
3960 DEFSYMBOL (Qgarbage_collecting);
3965 DEFSUBR (Fbit_vector);
3966 DEFSUBR (Fmake_byte_code);
3967 DEFSUBR (Fmake_list);
3968 DEFSUBR (Fmake_vector);
3969 DEFSUBR (Fmake_bit_vector);
3970 DEFSUBR (Fmake_string);
3972 DEFSUBR (Fmake_symbol);
3973 DEFSUBR (Fmake_marker);
3974 DEFSUBR (Fpurecopy);
3975 DEFSUBR (Fgarbage_collect);
3977 DEFSUBR (Fmemory_limit);
3979 DEFSUBR (Fconsing_since_gc);
3983 vars_of_alloc (void)
3985 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
3986 *Number of bytes of consing between garbage collections.
3987 \"Consing\" is a misnomer in that this actually counts allocation
3988 of all different kinds of objects, not just conses.
3989 Garbage collection can happen automatically once this many bytes have been
3990 allocated since the last garbage collection. All data types count.
3992 Garbage collection happens automatically when `eval' or `funcall' are
3993 called. (Note that `funcall' is called implicitly as part of evaluation.)
3994 By binding this temporarily to a large number, you can effectively
3995 prevent garbage collection during a part of the program.
3997 See also `consing-since-gc'.
4000 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
4001 Number of bytes of sharable Lisp data allocated so far.
4005 DEFVAR_INT ("debug-allocation", &debug_allocation /*
4006 If non-zero, print out information to stderr about all objects allocated.
4007 See also `debug-allocation-backtrace-length'.
4009 debug_allocation = 0;
4011 DEFVAR_INT ("debug-allocation-backtrace-length",
4012 &debug_allocation_backtrace_length /*
4013 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4015 debug_allocation_backtrace_length = 2;
4018 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4019 Non-nil means loading Lisp code in order to dump an executable.
4020 This means that certain objects should be allocated in readonly space.
4023 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4024 Function or functions to be run just before each garbage collection.
4025 Interrupts, garbage collection, and errors are inhibited while this hook
4026 runs, so be extremely careful in what you add here. In particular, avoid
4027 consing, and do not interact with the user.
4029 Vpre_gc_hook = Qnil;
4031 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4032 Function or functions to be run just after each garbage collection.
4033 Interrupts, garbage collection, and errors are inhibited while this hook
4034 runs, so be extremely careful in what you add here. In particular, avoid
4035 consing, and do not interact with the user.
4037 Vpost_gc_hook = Qnil;
4039 DEFVAR_LISP ("gc-message", &Vgc_message /*
4040 String to print to indicate that a garbage collection is in progress.
4041 This is printed in the echo area. If the selected frame is on a
4042 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4043 image instance) in the domain of the selected frame, the mouse pointer
4044 will change instead of this message being printed.
4046 Vgc_message = build_string (gc_default_message);
4048 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4049 Pointer glyph used to indicate that a garbage collection is in progress.
4050 If the selected window is on a window system and this glyph specifies a
4051 value (i.e. a pointer image instance) in the domain of the selected
4052 window, the pointer will be changed as specified during garbage collection.
4053 Otherwise, a message will be printed in the echo area, as controlled
4059 complex_vars_of_alloc (void)
4061 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);