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.
45 #include "backtrace.h"
56 #include "redisplay.h"
57 #include "specifier.h"
63 #ifdef DOUG_LEA_MALLOC
67 EXFUN (Fgarbage_collect, 0);
69 /* Return the true size of a struct with a variable-length array field. */
70 #define STRETCHY_STRUCT_SIZEOF(stretchy_struct_type, \
71 stretchy_array_field, \
72 stretchy_array_length) \
73 (offsetof (stretchy_struct_type, stretchy_array_field) + \
74 (offsetof (stretchy_struct_type, stretchy_array_field[1]) - \
75 offsetof (stretchy_struct_type, stretchy_array_field[0])) * \
76 (stretchy_array_length))
78 #if 0 /* this is _way_ too slow to be part of the standard debug options */
79 #if defined(DEBUG_XEMACS) && defined(MULE)
80 #define VERIFY_STRING_CHARS_INTEGRITY
84 /* Define this to use malloc/free with no freelist for all datatypes,
85 the hope being that some debugging tools may help detect
86 freed memory references */
87 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
89 #define ALLOC_NO_POOLS
93 static int debug_allocation;
94 static int debug_allocation_backtrace_length;
97 /* Number of bytes of consing done since the last gc */
98 EMACS_INT consing_since_gc;
99 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
101 #define debug_allocation_backtrace() \
103 if (debug_allocation_backtrace_length > 0) \
104 debug_short_backtrace (debug_allocation_backtrace_length); \
108 #define INCREMENT_CONS_COUNTER(foosize, type) \
110 if (debug_allocation) \
112 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
113 debug_allocation_backtrace (); \
115 INCREMENT_CONS_COUNTER_1 (foosize); \
117 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
119 if (debug_allocation > 1) \
121 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
122 debug_allocation_backtrace (); \
124 INCREMENT_CONS_COUNTER_1 (foosize); \
127 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
128 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
129 INCREMENT_CONS_COUNTER_1 (size)
132 #define DECREMENT_CONS_COUNTER(size) do { \
133 consing_since_gc -= (size); \
134 if (consing_since_gc < 0) \
135 consing_since_gc = 0; \
138 /* Number of bytes of consing since gc before another gc should be done. */
139 EMACS_INT gc_cons_threshold;
141 /* Nonzero during gc */
144 /* Number of times GC has happened at this level or below.
145 * Level 0 is most volatile, contrary to usual convention.
146 * (Of course, there's only one level at present) */
147 EMACS_INT gc_generation_number[1];
149 /* This is just for use by the printer, to allow things to print uniquely */
150 static int lrecord_uid_counter;
152 /* Nonzero when calling certain hooks or doing other things where
154 int gc_currently_forbidden;
157 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
158 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
160 /* "Garbage collecting" */
161 Lisp_Object Vgc_message;
162 Lisp_Object Vgc_pointer_glyph;
163 static CONST char gc_default_message[] = "Garbage collecting";
164 Lisp_Object Qgarbage_collecting;
166 #ifndef VIRT_ADDR_VARIES
168 #endif /* VIRT_ADDR_VARIES */
169 EMACS_INT malloc_sbrk_used;
171 #ifndef VIRT_ADDR_VARIES
173 #endif /* VIRT_ADDR_VARIES */
174 EMACS_INT malloc_sbrk_unused;
176 /* Non-zero means we're in the process of doing the dump */
179 #ifdef ERROR_CHECK_TYPECHECK
181 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
186 c_readonly (Lisp_Object obj)
188 return POINTER_TYPE_P (XGCTYPE (obj)) && C_READONLY (obj);
192 lisp_readonly (Lisp_Object obj)
194 return POINTER_TYPE_P (XGCTYPE (obj)) && LISP_READONLY (obj);
198 /* Maximum amount of C stack to save when a GC happens. */
200 #ifndef MAX_SAVE_STACK
201 #define MAX_SAVE_STACK 0 /* 16000 */
204 /* Non-zero means ignore malloc warnings. Set during initialization. */
205 int ignore_malloc_warnings;
208 static void *breathing_space;
211 release_breathing_space (void)
215 void *tmp = breathing_space;
221 /* malloc calls this if it finds we are near exhausting storage */
223 malloc_warning (CONST char *str)
225 if (ignore_malloc_warnings)
231 "Killing some buffers may delay running out of memory.\n"
232 "However, certainly by the time you receive the 95%% warning,\n"
233 "you should clean up, kill this Emacs, and start a new one.",
237 /* Called if malloc returns zero */
241 /* Force a GC next time eval is called.
242 It's better to loop garbage-collecting (we might reclaim enough
243 to win) than to loop beeping and barfing "Memory exhausted"
245 consing_since_gc = gc_cons_threshold + 1;
246 release_breathing_space ();
248 /* Flush some histories which might conceivably contain garbalogical
250 if (!NILP (Fboundp (Qvalues)))
251 Fset (Qvalues, Qnil);
252 Vcommand_history = Qnil;
254 error ("Memory exhausted");
257 /* like malloc and realloc but check for no memory left, and block input. */
264 xmalloc (size_t size)
266 void *val = malloc (size);
268 if (!val && (size != 0)) memory_full ();
277 xcalloc (size_t nelem, size_t elsize)
279 void *val = calloc (nelem, elsize);
281 if (!val && (nelem != 0)) memory_full ();
286 xmalloc_and_zero (size_t size)
288 return xcalloc (size, sizeof (char));
296 xrealloc (void *block, size_t size)
298 /* We must call malloc explicitly when BLOCK is 0, since some
299 reallocs don't do this. */
300 void *val = block ? realloc (block, size) : malloc (size);
302 if (!val && (size != 0)) memory_full ();
307 #ifdef ERROR_CHECK_MALLOC
308 xfree_1 (void *block)
313 #ifdef ERROR_CHECK_MALLOC
314 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
315 error until much later on for many system mallocs, such as
316 the one that comes with Solaris 2.3. FMH!! */
317 assert (block != (void *) 0xDEADBEEF);
319 #endif /* ERROR_CHECK_MALLOC */
323 #ifdef ERROR_CHECK_GC
326 typedef unsigned int four_byte_t;
327 #elif SIZEOF_LONG == 4
328 typedef unsigned long four_byte_t;
329 #elif SIZEOF_SHORT == 4
330 typedef unsigned short four_byte_t;
332 What kind of strange-ass system are we running on?
336 deadbeef_memory (void *ptr, size_t size)
338 four_byte_t *ptr4 = (four_byte_t *) ptr;
339 size_t beefs = size >> 2;
341 /* In practice, size will always be a multiple of four. */
343 (*ptr4++) = 0xDEADBEEF;
346 #else /* !ERROR_CHECK_GC */
349 #define deadbeef_memory(ptr, size)
351 #endif /* !ERROR_CHECK_GC */
358 xstrdup (CONST char *str)
360 int len = strlen (str) + 1; /* for stupid terminating 0 */
362 void *val = xmalloc (len);
363 if (val == 0) return 0;
364 memcpy (val, str, len);
370 strdup (CONST char *s)
374 #endif /* NEED_STRDUP */
378 allocate_lisp_storage (size_t size)
380 void *p = xmalloc (size);
385 /* lrecords are chained together through their "next.v" field.
386 * After doing the mark phase, the GC will walk this linked
387 * list and free any record which hasn't been marked.
389 static struct lcrecord_header *all_lcrecords;
392 alloc_lcrecord (size_t size, CONST struct lrecord_implementation *implementation)
394 struct lcrecord_header *lcheader;
396 #ifdef ERROR_CHECK_GC
397 if (implementation->static_size == 0)
398 assert (implementation->size_in_bytes_method);
400 assert (implementation->static_size == size);
403 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
404 set_lheader_implementation (&(lcheader->lheader), implementation);
405 lcheader->next = all_lcrecords;
406 #if 1 /* mly prefers to see small ID numbers */
407 lcheader->uid = lrecord_uid_counter++;
408 #else /* jwz prefers to see real addrs */
409 lcheader->uid = (int) &lcheader;
412 all_lcrecords = lcheader;
413 INCREMENT_CONS_COUNTER (size, implementation->name);
417 #if 0 /* Presently unused */
418 /* Very, very poor man's EGC?
419 * This may be slow and thrash pages all over the place.
420 * Only call it if you really feel you must (and if the
421 * lrecord was fairly recently allocated).
422 * Otherwise, just let the GC do its job -- that's what it's there for
425 free_lcrecord (struct lcrecord_header *lcrecord)
427 if (all_lcrecords == lcrecord)
429 all_lcrecords = lcrecord->next;
433 struct lrecord_header *header = all_lcrecords;
436 struct lrecord_header *next = header->next;
437 if (next == lcrecord)
439 header->next = lrecord->next;
448 if (lrecord->implementation->finalizer)
449 lrecord->implementation->finalizer (lrecord, 0);
457 disksave_object_finalization_1 (void)
459 struct lcrecord_header *header;
461 for (header = all_lcrecords; header; header = header->next)
463 if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
465 ((LHEADER_IMPLEMENTATION(&header->lheader)->finalizer)
471 /* This must not be called -- it just serves as for EQ test
472 * If lheader->implementation->finalizer is this_marks_a_marked_record,
473 * then lrecord has been marked by the GC sweeper
474 * header->implementation is put back to its correct value by
477 this_marks_a_marked_record (void *dummy0, int dummy1)
482 /* Semi-kludge -- lrecord_symbol_value_forward objects get stuck
483 in CONST space and you get SEGV's if you attempt to mark them.
484 This sits in lheader->implementation->marker. */
487 this_one_is_unmarkable (Lisp_Object obj, void (*markobj) (Lisp_Object))
493 /* XGCTYPE for records */
495 gc_record_type_p (Lisp_Object frob, CONST struct lrecord_implementation *type)
497 CONST struct lrecord_implementation *imp;
499 if (XGCTYPE (frob) != Lisp_Type_Record)
502 imp = XRECORD_LHEADER_IMPLEMENTATION (frob);
507 /************************************************************************/
508 /* Debugger support */
509 /************************************************************************/
510 /* Give gdb/dbx enough information to decode Lisp Objects. We make
511 sure certain symbols are always defined, so gdb doesn't complain
512 about expressions in src/gdbinit. See src/gdbinit or src/dbxrc to
513 see how this is used. */
515 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
516 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
518 #ifdef USE_UNION_TYPE
519 unsigned char dbg_USE_UNION_TYPE = 1;
521 unsigned char dbg_USE_UNION_TYPE = 0;
524 unsigned char Lisp_Type_Int = 100;
525 unsigned char Lisp_Type_Cons = 101;
526 unsigned char Lisp_Type_String = 102;
527 unsigned char Lisp_Type_Vector = 103;
528 unsigned char Lisp_Type_Symbol = 104;
531 unsigned char lrecord_char_table_entry;
532 unsigned char lrecord_charset;
534 unsigned char lrecord_coding_system;
538 #ifndef HAVE_TOOLBARS
539 unsigned char lrecord_toolbar_button;
543 unsigned char lrecord_tooltalk_message;
544 unsigned char lrecord_tooltalk_pattern;
547 #ifndef HAVE_DATABASE
548 unsigned char lrecord_database;
551 unsigned char dbg_valbits = VALBITS;
552 unsigned char dbg_gctypebits = GCTYPEBITS;
554 /* Macros turned into functions for ease of debugging.
555 Debuggers don't know about macros! */
556 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
558 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
560 return EQ (obj1, obj2);
564 /************************************************************************/
565 /* Fixed-size type macros */
566 /************************************************************************/
568 /* For fixed-size types that are commonly used, we malloc() large blocks
569 of memory at a time and subdivide them into chunks of the correct
570 size for an object of that type. This is more efficient than
571 malloc()ing each object separately because we save on malloc() time
572 and overhead due to the fewer number of malloc()ed blocks, and
573 also because we don't need any extra pointers within each object
574 to keep them threaded together for GC purposes. For less common
575 (and frequently large-size) types, we use lcrecords, which are
576 malloc()ed individually and chained together through a pointer
577 in the lcrecord header. lcrecords do not need to be fixed-size
578 (i.e. two objects of the same type need not have the same size;
579 however, the size of a particular object cannot vary dynamically).
580 It is also much easier to create a new lcrecord type because no
581 additional code needs to be added to alloc.c. Finally, lcrecords
582 may be more efficient when there are only a small number of them.
584 The types that are stored in these large blocks (or "frob blocks")
585 are cons, float, compiled-function, symbol, marker, extent, event,
588 Note that strings are special in that they are actually stored in
589 two parts: a structure containing information about the string, and
590 the actual data associated with the string. The former structure
591 (a struct Lisp_String) is a fixed-size structure and is managed the
592 same way as all the other such types. This structure contains a
593 pointer to the actual string data, which is stored in structures of
594 type struct string_chars_block. Each string_chars_block consists
595 of a pointer to a struct Lisp_String, followed by the data for that
596 string, followed by another pointer to a struct Lisp_String,
597 followed by the data for that string, etc. At GC time, the data in
598 these blocks is compacted by searching sequentially through all the
599 blocks and compressing out any holes created by unmarked strings.
600 Strings that are more than a certain size (bigger than the size of
601 a string_chars_block, although something like half as big might
602 make more sense) are malloc()ed separately and not stored in
603 string_chars_blocks. Furthermore, no one string stretches across
604 two string_chars_blocks.
606 Vectors are each malloc()ed separately, similar to lcrecords.
608 In the following discussion, we use conses, but it applies equally
609 well to the other fixed-size types.
611 We store cons cells inside of cons_blocks, allocating a new
612 cons_block with malloc() whenever necessary. Cons cells reclaimed
613 by GC are put on a free list to be reallocated before allocating
614 any new cons cells from the latest cons_block. Each cons_block is
615 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
616 the versions in malloc.c and gmalloc.c) really allocates in units
617 of powers of two and uses 4 bytes for its own overhead.
619 What GC actually does is to search through all the cons_blocks,
620 from the most recently allocated to the oldest, and put all
621 cons cells that are not marked (whether or not they're already
622 free) on a cons_free_list. The cons_free_list is a stack, and
623 so the cons cells in the oldest-allocated cons_block end up
624 at the head of the stack and are the first to be reallocated.
625 If any cons_block is entirely free, it is freed with free()
626 and its cons cells removed from the cons_free_list. Because
627 the cons_free_list ends up basically in memory order, we have
628 a high locality of reference (assuming a reasonable turnover
629 of allocating and freeing) and have a reasonable probability
630 of entirely freeing up cons_blocks that have been more recently
631 allocated. This stage is called the "sweep stage" of GC, and
632 is executed after the "mark stage", which involves starting
633 from all places that are known to point to in-use Lisp objects
634 (e.g. the obarray, where are all symbols are stored; the
635 current catches and condition-cases; the backtrace list of
636 currently executing functions; the gcpro list; etc.) and
637 recursively marking all objects that are accessible.
639 At the beginning of the sweep stage, the conses in the cons
640 blocks are in one of three states: in use and marked, in use
641 but not marked, and not in use (already freed). Any conses
642 that are marked have been marked in the mark stage just
643 executed, because as part of the sweep stage we unmark any
644 marked objects. The way we tell whether or not a cons cell
645 is in use is through the FREE_STRUCT_P macro. This basically
646 looks at the first 4 bytes (or however many bytes a pointer
647 fits in) to see if all the bits in those bytes are 1. The
648 resulting value (0xFFFFFFFF) is not a valid pointer and is
649 not a valid Lisp_Object. All current fixed-size types have
650 a pointer or Lisp_Object as their first element with the
651 exception of strings; they have a size value, which can
652 never be less than zero, and so 0xFFFFFFFF is invalid for
653 strings as well. Now assuming that a cons cell is in use,
654 the way we tell whether or not it is marked is to look at
655 the mark bit of its car (each Lisp_Object has one bit
656 reserved as a mark bit, in case it's needed). Note that
657 different types of objects use different fields to indicate
658 whether the object is marked, but the principle is the same.
660 Conses on the free_cons_list are threaded through a pointer
661 stored in the bytes directly after the bytes that are set
662 to 0xFFFFFFFF (we cannot overwrite these because the cons
663 is still in a cons_block and needs to remain marked as
664 not in use for the next time that GC happens). This
665 implies that all fixed-size types must be at least big
666 enough to store two pointers, which is indeed the case
667 for all current fixed-size types.
669 Some types of objects need additional "finalization" done
670 when an object is converted from in use to not in use;
671 this is the purpose of the ADDITIONAL_FREE_type macro.
672 For example, markers need to be removed from the chain
673 of markers that is kept in each buffer. This is because
674 markers in a buffer automatically disappear if the marker
675 is no longer referenced anywhere (the same does not
676 apply to extents, however).
678 WARNING: Things are in an extremely bizarre state when
679 the ADDITIONAL_FREE_type macros are called, so beware!
681 When ERROR_CHECK_GC is defined, we do things differently
682 so as to maximize our chances of catching places where
683 there is insufficient GCPROing. The thing we want to
684 avoid is having an object that we're using but didn't
685 GCPRO get freed by GC and then reallocated while we're
686 in the process of using it -- this will result in something
687 seemingly unrelated getting trashed, and is extremely
688 difficult to track down. If the object gets freed but
689 not reallocated, we can usually catch this because we
690 set all bytes of a freed object to 0xDEADBEEF. (The
691 first four bytes, however, are 0xFFFFFFFF, and the next
692 four are a pointer used to chain freed objects together;
693 we play some tricks with this pointer to make it more
694 bogus, so crashes are more likely to occur right away.)
696 We want freed objects to stay free as long as possible,
697 so instead of doing what we do above, we maintain the
698 free objects in a first-in first-out queue. We also
699 don't recompute the free list each GC, unlike above;
700 this ensures that the queue ordering is preserved.
701 [This means that we are likely to have worse locality
702 of reference, and that we can never free a frob block
703 once it's allocated. (Even if we know that all cells
704 in it are free, there's no easy way to remove all those
705 cells from the free list because the objects on the
706 free list are unlikely to be in memory order.)]
707 Furthermore, we never take objects off the free list
708 unless there's a large number (usually 1000, but
709 varies depending on type) of them already on the list.
710 This way, we ensure that an object that gets freed will
711 remain free for the next 1000 (or whatever) times that
712 an object of that type is allocated.
715 #ifndef MALLOC_OVERHEAD
717 #define MALLOC_OVERHEAD 0
718 #elif defined (rcheck)
719 #define MALLOC_OVERHEAD 20
721 #define MALLOC_OVERHEAD 8
723 #endif /* MALLOC_OVERHEAD */
725 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
726 /* If we released our reserve (due to running out of memory),
727 and we have a fair amount free once again,
728 try to set aside another reserve in case we run out once more.
730 This is called when a relocatable block is freed in ralloc.c. */
731 void refill_memory_reserve (void);
733 refill_memory_reserve ()
735 if (breathing_space == 0)
736 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
740 #ifdef ALLOC_NO_POOLS
741 # define TYPE_ALLOC_SIZE(type, structtype) 1
743 # define TYPE_ALLOC_SIZE(type, structtype) \
744 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
745 / sizeof (structtype))
746 #endif /* ALLOC_NO_POOLS */
748 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
750 struct type##_block \
752 struct type##_block *prev; \
753 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
756 static struct type##_block *current_##type##_block; \
757 static int current_##type##_block_index; \
759 static structtype *type##_free_list; \
760 static structtype *type##_free_list_tail; \
763 init_##type##_alloc (void) \
765 current_##type##_block = 0; \
766 current_##type##_block_index = \
767 countof (current_##type##_block->block); \
768 type##_free_list = 0; \
769 type##_free_list_tail = 0; \
772 static int gc_count_num_##type##_in_use; \
773 static int gc_count_num_##type##_freelist
775 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
776 if (current_##type##_block_index \
777 == countof (current_##type##_block->block)) \
779 struct type##_block *AFTFB_new = (struct type##_block *) \
780 allocate_lisp_storage (sizeof (struct type##_block)); \
781 AFTFB_new->prev = current_##type##_block; \
782 current_##type##_block = AFTFB_new; \
783 current_##type##_block_index = 0; \
786 &(current_##type##_block->block[current_##type##_block_index++]); \
789 /* Allocate an instance of a type that is stored in blocks.
790 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
793 #ifdef ERROR_CHECK_GC
795 /* Note: if you get crashes in this function, suspect incorrect calls
796 to free_cons() and friends. This happened once because the cons
797 cell was not GC-protected and was getting collected before
798 free_cons() was called. */
800 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
803 if (gc_count_num_##type##_freelist > \
804 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
806 result = type##_free_list; \
807 /* Before actually using the chain pointer, we complement all its \
808 bits; see FREE_FIXED_TYPE(). */ \
810 (structtype *) ~(unsigned long) \
811 (* (structtype **) ((char *) result + sizeof (void *))); \
812 gc_count_num_##type##_freelist--; \
815 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
816 MARK_STRUCT_AS_NOT_FREE (result); \
819 #else /* !ERROR_CHECK_GC */
821 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
824 if (type##_free_list) \
826 result = type##_free_list; \
828 * (structtype **) ((char *) result + sizeof (void *)); \
831 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
832 MARK_STRUCT_AS_NOT_FREE (result); \
835 #endif /* !ERROR_CHECK_GC */
837 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
840 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
841 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
844 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
847 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
848 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
851 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
852 to a Lisp object and invalid as an actual Lisp_Object value. We have
853 to make sure that this value cannot be an integer in Lisp_Object form.
854 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
855 On a 32-bit system, the type bits will be non-zero, making the value
856 be a pointer, and the pointer will be misaligned.
858 Even if Emacs is run on some weirdo system that allows and allocates
859 byte-aligned pointers, this pointer is at the very top of the address
860 space and so it's almost inconceivable that it could ever be valid. */
863 # define INVALID_POINTER_VALUE 0xFFFFFFFF
865 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
867 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
869 You have some weird system and need to supply a reasonable value here.
872 #define FREE_STRUCT_P(ptr) \
873 (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
874 #define MARK_STRUCT_AS_FREE(ptr) \
875 (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
876 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
877 (* (void **) ptr = 0)
879 #ifdef ERROR_CHECK_GC
881 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
882 do { if (type##_free_list_tail) \
884 /* When we store the chain pointer, we complement all \
885 its bits; this should significantly increase its \
886 bogosity in case someone tries to use the value, and \
887 should make us dump faster if someone stores something \
888 over the pointer because when it gets un-complemented in \
889 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
890 extremely bogus. */ \
892 ((char *) type##_free_list_tail + sizeof (void *)) = \
893 (structtype *) ~(unsigned long) ptr; \
896 type##_free_list = ptr; \
897 type##_free_list_tail = ptr; \
900 #else /* !ERROR_CHECK_GC */
902 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
903 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
905 type##_free_list = (ptr); \
908 #endif /* !ERROR_CHECK_GC */
910 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
912 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
913 structtype *FFT_ptr = (ptr); \
914 ADDITIONAL_FREE_##type (FFT_ptr); \
915 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
916 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
917 MARK_STRUCT_AS_FREE (FFT_ptr); \
920 /* Like FREE_FIXED_TYPE() but used when we are explicitly
921 freeing a structure through free_cons(), free_marker(), etc.
922 rather than through the normal process of sweeping.
923 We attempt to undo the changes made to the allocation counters
924 as a result of this structure being allocated. This is not
925 completely necessary but helps keep things saner: e.g. this way,
926 repeatedly allocating and freeing a cons will not result in
927 the consing-since-gc counter advancing, which would cause a GC
928 and somewhat defeat the purpose of explicitly freeing. */
930 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
931 do { FREE_FIXED_TYPE (type, structtype, ptr); \
932 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
933 gc_count_num_##type##_freelist++; \
938 /************************************************************************/
939 /* Cons allocation */
940 /************************************************************************/
942 DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons);
943 /* conses are used and freed so often that we set this really high */
944 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
945 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
948 mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object))
950 if (GC_NILP (XCDR (obj)))
953 markobj (XCAR (obj));
958 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
960 while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1))
964 if (! CONSP (ob1) || ! CONSP (ob2))
965 return internal_equal (ob1, ob2, depth + 1);
970 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
971 mark_cons, print_cons, 0,
974 * No `hash' method needed.
975 * internal_hash knows how to
981 DEFUN ("cons", Fcons, 2, 2, 0, /*
982 Create a new cons, give it CAR and CDR as components, and return it.
986 /* This cannot GC. */
990 ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
991 set_lheader_implementation (&(c->lheader), &lrecord_cons);
998 /* This is identical to Fcons() but it used for conses that we're
999 going to free later, and is useful when trying to track down
1002 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
1005 struct Lisp_Cons *c;
1007 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1008 set_lheader_implementation (&(c->lheader), &lrecord_cons);
1015 DEFUN ("list", Flist, 0, MANY, 0, /*
1016 Return a newly created list with specified arguments as elements.
1017 Any number of arguments, even zero arguments, are allowed.
1019 (int nargs, Lisp_Object *args))
1021 Lisp_Object val = Qnil;
1022 Lisp_Object *argp = args + nargs;
1025 val = Fcons (*--argp, val);
1030 list1 (Lisp_Object obj0)
1032 /* This cannot GC. */
1033 return Fcons (obj0, Qnil);
1037 list2 (Lisp_Object obj0, Lisp_Object obj1)
1039 /* This cannot GC. */
1040 return Fcons (obj0, Fcons (obj1, Qnil));
1044 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1046 /* This cannot GC. */
1047 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1051 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1053 /* This cannot GC. */
1054 return Fcons (obj0, Fcons (obj1, obj2));
1058 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1060 return Fcons (Fcons (key, value), alist);
1064 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1066 /* This cannot GC. */
1067 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1071 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1074 /* This cannot GC. */
1075 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1079 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1080 Lisp_Object obj4, Lisp_Object obj5)
1082 /* This cannot GC. */
1083 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1086 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1087 Return a new list of length LENGTH, with each element being INIT.
1091 CHECK_NATNUM (length);
1094 Lisp_Object val = Qnil;
1095 int size = XINT (length);
1098 val = Fcons (init, val);
1104 /************************************************************************/
1105 /* Float allocation */
1106 /************************************************************************/
1108 #ifdef LISP_FLOAT_TYPE
1110 DECLARE_FIXED_TYPE_ALLOC (float, struct Lisp_Float);
1111 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1114 make_float (double float_value)
1117 struct Lisp_Float *f;
1119 ALLOCATE_FIXED_TYPE (float, struct Lisp_Float, f);
1120 set_lheader_implementation (&(f->lheader), &lrecord_float);
1121 float_data (f) = float_value;
1126 #endif /* LISP_FLOAT_TYPE */
1129 /************************************************************************/
1130 /* Vector allocation */
1131 /************************************************************************/
1134 mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
1136 Lisp_Vector *ptr = XVECTOR (obj);
1137 int len = vector_length (ptr);
1140 for (i = 0; i < len - 1; i++)
1141 markobj (ptr->contents[i]);
1142 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1146 size_vector (CONST void *lheader)
1148 return STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents,
1149 ((Lisp_Vector *) lheader)->size);
1153 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1155 int len = XVECTOR_LENGTH (obj1);
1156 if (len != XVECTOR_LENGTH (obj2))
1160 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1161 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1163 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1169 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1170 mark_vector, print_vector, 0,
1173 * No `hash' method needed for
1174 * vectors. internal_hash
1175 * knows how to handle vectors.
1178 size_vector, Lisp_Vector);
1180 /* #### should allocate `small' vectors from a frob-block */
1181 static Lisp_Vector *
1182 make_vector_internal (size_t sizei)
1184 /* no vector_next */
1185 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1186 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1193 make_vector (size_t length, Lisp_Object init)
1195 Lisp_Vector *vecp = make_vector_internal (length);
1196 Lisp_Object *p = vector_data (vecp);
1203 XSETVECTOR (vector, vecp);
1208 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1209 Return a new vector of length LENGTH, with each element being INIT.
1210 See also the function `vector'.
1214 CONCHECK_NATNUM (length);
1215 return make_vector (XINT (length), init);
1218 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1219 Return a newly created vector with specified arguments as elements.
1220 Any number of arguments, even zero arguments, are allowed.
1222 (int nargs, Lisp_Object *args))
1224 Lisp_Vector *vecp = make_vector_internal (nargs);
1225 Lisp_Object *p = vector_data (vecp);
1232 XSETVECTOR (vector, vecp);
1238 vector1 (Lisp_Object obj0)
1240 return Fvector (1, &obj0);
1244 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1246 Lisp_Object args[2];
1249 return Fvector (2, args);
1253 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1255 Lisp_Object args[3];
1259 return Fvector (3, args);
1262 #if 0 /* currently unused */
1265 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1268 Lisp_Object args[4];
1273 return Fvector (4, args);
1277 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1278 Lisp_Object obj3, Lisp_Object obj4)
1280 Lisp_Object args[5];
1286 return Fvector (5, args);
1290 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1291 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1293 Lisp_Object args[6];
1300 return Fvector (6, args);
1304 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1305 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1308 Lisp_Object args[7];
1316 return Fvector (7, args);
1320 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1321 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1322 Lisp_Object obj6, Lisp_Object obj7)
1324 Lisp_Object args[8];
1333 return Fvector (8, args);
1337 /************************************************************************/
1338 /* Bit Vector allocation */
1339 /************************************************************************/
1341 static Lisp_Object all_bit_vectors;
1343 /* #### should allocate `small' bit vectors from a frob-block */
1344 static struct Lisp_Bit_Vector *
1345 make_bit_vector_internal (size_t sizei)
1347 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1348 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1349 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1350 set_lheader_implementation (&(p->lheader), &lrecord_bit_vector);
1352 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1354 bit_vector_length (p) = sizei;
1355 bit_vector_next (p) = all_bit_vectors;
1356 /* make sure the extra bits in the last long are 0; the calling
1357 functions might not set them. */
1358 p->bits[num_longs - 1] = 0;
1359 XSETBIT_VECTOR (all_bit_vectors, p);
1364 make_bit_vector (size_t length, Lisp_Object init)
1366 struct Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1367 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1372 memset (p->bits, 0, num_longs * sizeof (long));
1375 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1376 memset (p->bits, ~0, num_longs * sizeof (long));
1377 /* But we have to make sure that the unused bits in the
1378 last long are 0, so that equal/hash is easy. */
1380 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1384 Lisp_Object bit_vector;
1385 XSETBIT_VECTOR (bit_vector, p);
1391 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1394 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1396 for (i = 0; i < length; i++)
1397 set_bit_vector_bit (p, i, bytevec[i]);
1400 Lisp_Object bit_vector;
1401 XSETBIT_VECTOR (bit_vector, p);
1406 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1407 Return a new bit vector of length LENGTH. with each bit being INIT.
1408 Each element is set to INIT. See also the function `bit-vector'.
1412 CONCHECK_NATNUM (length);
1414 return make_bit_vector (XINT (length), init);
1417 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1418 Return a newly created bit vector with specified arguments as elements.
1419 Any number of arguments, even zero arguments, are allowed.
1421 (int nargs, Lisp_Object *args))
1424 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1426 for (i = 0; i < nargs; i++)
1428 CHECK_BIT (args[i]);
1429 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1433 Lisp_Object bit_vector;
1434 XSETBIT_VECTOR (bit_vector, p);
1440 /************************************************************************/
1441 /* Compiled-function allocation */
1442 /************************************************************************/
1444 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1445 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1448 make_compiled_function (void)
1450 Lisp_Compiled_Function *f;
1453 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1454 set_lheader_implementation (&(f->lheader), &lrecord_compiled_function);
1457 f->specpdl_depth = 0;
1458 f->flags.documentationp = 0;
1459 f->flags.interactivep = 0;
1460 f->flags.domainp = 0; /* I18N3 */
1461 f->instructions = Qzero;
1462 f->constants = Qzero;
1464 f->doc_and_interactive = Qnil;
1465 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1466 f->annotated = Qnil;
1468 XSETCOMPILED_FUNCTION (fun, f);
1472 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1473 Return a new compiled-function object.
1474 Usage: (arglist instructions constants stack-depth
1475 &optional doc-string interactive)
1476 Note that, unlike all other emacs-lisp functions, calling this with five
1477 arguments is NOT the same as calling it with six arguments, the last of
1478 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1479 that this function was defined with `(interactive)'. If the arg is not
1480 specified, then that means the function is not interactive.
1481 This is terrible behavior which is retained for compatibility with old
1482 `.elc' files which expect these semantics.
1484 (int nargs, Lisp_Object *args))
1486 /* In a non-insane world this function would have this arglist...
1487 (arglist instructions constants stack_depth &optional doc_string interactive)
1489 Lisp_Object fun = make_compiled_function ();
1490 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1492 Lisp_Object arglist = args[0];
1493 Lisp_Object instructions = args[1];
1494 Lisp_Object constants = args[2];
1495 Lisp_Object stack_depth = args[3];
1496 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1497 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1499 if (nargs < 4 || nargs > 6)
1500 return Fsignal (Qwrong_number_of_arguments,
1501 list2 (intern ("make-byte-code"), make_int (nargs)));
1503 /* Check for valid formal parameter list now, to allow us to use
1504 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1506 Lisp_Object symbol, tail;
1507 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1509 CHECK_SYMBOL (symbol);
1510 if (EQ (symbol, Qt) ||
1511 EQ (symbol, Qnil) ||
1512 SYMBOL_IS_KEYWORD (symbol))
1513 signal_simple_error_2
1514 ("Invalid constant symbol in formal parameter list",
1518 f->arglist = arglist;
1520 /* `instructions' is a string or a cons (string . int) for a
1521 lazy-loaded function. */
1522 if (CONSP (instructions))
1524 CHECK_STRING (XCAR (instructions));
1525 CHECK_INT (XCDR (instructions));
1529 CHECK_STRING (instructions);
1531 f->instructions = instructions;
1533 if (!NILP (constants))
1534 CHECK_VECTOR (constants);
1535 f->constants = constants;
1537 CHECK_NATNUM (stack_depth);
1538 f->stack_depth = XINT (stack_depth);
1540 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1541 if (!NILP (Vcurrent_compiled_function_annotation))
1542 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1543 else if (!NILP (Vload_file_name_internal_the_purecopy))
1544 f->annotated = Vload_file_name_internal_the_purecopy;
1545 else if (!NILP (Vload_file_name_internal))
1547 struct gcpro gcpro1;
1548 GCPRO1 (fun); /* don't let fun get reaped */
1549 Vload_file_name_internal_the_purecopy =
1550 Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
1551 f->annotated = Vload_file_name_internal_the_purecopy;
1554 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1556 /* doc_string may be nil, string, int, or a cons (string . int).
1557 interactive may be list or string (or unbound). */
1558 f->doc_and_interactive = Qunbound;
1560 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1561 f->doc_and_interactive = Vfile_domain;
1563 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1565 f->doc_and_interactive
1566 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1567 Fcons (interactive, f->doc_and_interactive));
1569 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1571 f->doc_and_interactive
1572 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1573 Fcons (doc_string, f->doc_and_interactive));
1575 if (UNBOUNDP (f->doc_and_interactive))
1576 f->doc_and_interactive = Qnil;
1582 /************************************************************************/
1583 /* Symbol allocation */
1584 /************************************************************************/
1586 DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol);
1587 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1589 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1590 Return a newly allocated uninterned symbol whose name is NAME.
1591 Its value and function definition are void, and its property list is nil.
1596 struct Lisp_Symbol *p;
1598 CHECK_STRING (name);
1600 ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p);
1601 set_lheader_implementation (&(p->lheader), &lrecord_symbol);
1602 p->name = XSTRING (name);
1604 p->value = Qunbound;
1605 p->function = Qunbound;
1606 symbol_next (p) = 0;
1607 XSETSYMBOL (val, p);
1612 /************************************************************************/
1613 /* Extent allocation */
1614 /************************************************************************/
1616 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1617 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1620 allocate_extent (void)
1624 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1625 set_lheader_implementation (&(e->lheader), &lrecord_extent);
1626 extent_object (e) = Qnil;
1627 set_extent_start (e, -1);
1628 set_extent_end (e, -1);
1633 extent_face (e) = Qnil;
1634 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1635 e->flags.detachable = 1;
1641 /************************************************************************/
1642 /* Event allocation */
1643 /************************************************************************/
1645 DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event);
1646 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1649 allocate_event (void)
1652 struct Lisp_Event *e;
1654 ALLOCATE_FIXED_TYPE (event, struct Lisp_Event, e);
1655 set_lheader_implementation (&(e->lheader), &lrecord_event);
1662 /************************************************************************/
1663 /* Marker allocation */
1664 /************************************************************************/
1666 DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker);
1667 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1669 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1670 Return a new marker which does not point at any place.
1675 struct Lisp_Marker *p;
1677 ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1678 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1681 marker_next (p) = 0;
1682 marker_prev (p) = 0;
1683 p->insertion_type = 0;
1684 XSETMARKER (val, p);
1689 noseeum_make_marker (void)
1692 struct Lisp_Marker *p;
1694 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1695 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1698 marker_next (p) = 0;
1699 marker_prev (p) = 0;
1700 p->insertion_type = 0;
1701 XSETMARKER (val, p);
1706 /************************************************************************/
1707 /* String allocation */
1708 /************************************************************************/
1710 /* The data for "short" strings generally resides inside of structs of type
1711 string_chars_block. The Lisp_String structure is allocated just like any
1712 other Lisp object (except for vectors), and these are freelisted when
1713 they get garbage collected. The data for short strings get compacted,
1714 but the data for large strings do not.
1716 Previously Lisp_String structures were relocated, but this caused a lot
1717 of bus-errors because the C code didn't include enough GCPRO's for
1718 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1719 that the reference would get relocated).
1721 This new method makes things somewhat bigger, but it is MUCH safer. */
1723 DECLARE_FIXED_TYPE_ALLOC (string, struct Lisp_String);
1724 /* strings are used and freed quite often */
1725 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1726 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1729 mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object))
1731 struct Lisp_String *ptr = XSTRING (obj);
1733 if (GC_CONSP (ptr->plist) && GC_EXTENT_INFOP (XCAR (ptr->plist)))
1734 flush_cached_extent_info (XCAR (ptr->plist));
1739 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1742 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1743 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1746 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
1747 mark_string, print_string,
1749 * No `finalize', or `hash' methods.
1750 * internal_hash already knows how
1751 * to hash strings and finalization
1753 * ADDITIONAL_FREE_string macro,
1754 * which is the standard way to do
1755 * finalization when using
1756 * SWEEP_FIXED_TYPE_BLOCK().
1759 struct Lisp_String);
1761 /* String blocks contain this many useful bytes. */
1762 #define STRING_CHARS_BLOCK_SIZE \
1763 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1764 ((2 * sizeof (struct string_chars_block *)) \
1765 + sizeof (EMACS_INT))))
1766 /* Block header for small strings. */
1767 struct string_chars_block
1770 struct string_chars_block *next;
1771 struct string_chars_block *prev;
1772 /* Contents of string_chars_block->string_chars are interleaved
1773 string_chars structures (see below) and the actual string data */
1774 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1777 struct string_chars_block *first_string_chars_block;
1778 struct string_chars_block *current_string_chars_block;
1780 /* If SIZE is the length of a string, this returns how many bytes
1781 * the string occupies in string_chars_block->string_chars
1782 * (including alignment padding).
1784 #define STRING_FULLSIZE(s) \
1785 ALIGN_SIZE (((s) + 1 + sizeof (struct Lisp_String *)),\
1786 ALIGNOF (struct Lisp_String *))
1788 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1789 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1791 #define CHARS_TO_STRING_CHAR(x) \
1792 ((struct string_chars *) \
1793 (((char *) (x)) - (slot_offset (struct string_chars, chars[0]))))
1798 struct Lisp_String *string;
1799 unsigned char chars[1];
1802 struct unused_string_chars
1804 struct Lisp_String *string;
1809 init_string_chars_alloc (void)
1811 first_string_chars_block = xnew (struct string_chars_block);
1812 first_string_chars_block->prev = 0;
1813 first_string_chars_block->next = 0;
1814 first_string_chars_block->pos = 0;
1815 current_string_chars_block = first_string_chars_block;
1818 static struct string_chars *
1819 allocate_string_chars_struct (struct Lisp_String *string_it_goes_with,
1822 struct string_chars *s_chars;
1824 /* Allocate the string's actual data */
1825 if (BIG_STRING_FULLSIZE_P (fullsize))
1827 s_chars = (struct string_chars *) xmalloc (fullsize);
1829 else if (fullsize <=
1830 (countof (current_string_chars_block->string_chars)
1831 - current_string_chars_block->pos))
1833 /* This string can fit in the current string chars block */
1834 s_chars = (struct string_chars *)
1835 (current_string_chars_block->string_chars
1836 + current_string_chars_block->pos);
1837 current_string_chars_block->pos += fullsize;
1841 /* Make a new current string chars block */
1842 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1844 current_string_chars_block->next = new_scb;
1845 new_scb->prev = current_string_chars_block;
1847 current_string_chars_block = new_scb;
1848 new_scb->pos = fullsize;
1849 s_chars = (struct string_chars *)
1850 current_string_chars_block->string_chars;
1853 s_chars->string = string_it_goes_with;
1855 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1861 make_uninit_string (Bytecount length)
1863 struct Lisp_String *s;
1864 struct string_chars *s_chars;
1865 EMACS_INT fullsize = STRING_FULLSIZE (length);
1868 if ((length < 0) || (fullsize <= 0))
1871 /* Allocate the string header */
1872 ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
1873 set_lheader_implementation (&(s->lheader), &lrecord_string);
1875 s_chars = allocate_string_chars_struct (s, fullsize);
1877 set_string_data (s, &(s_chars->chars[0]));
1878 set_string_length (s, length);
1881 set_string_byte (s, length, 0);
1883 XSETSTRING (val, s);
1887 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1888 static void verify_string_chars_integrity (void);
1891 /* Resize the string S so that DELTA bytes can be inserted starting
1892 at POS. If DELTA < 0, it means deletion starting at POS. If
1893 POS < 0, resize the string but don't copy any characters. Use
1894 this if you're planning on completely overwriting the string.
1898 resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta)
1900 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1901 verify_string_chars_integrity ();
1904 #ifdef ERROR_CHECK_BUFPOS
1907 assert (pos <= string_length (s));
1909 assert (pos + (-delta) <= string_length (s));
1914 assert ((-delta) <= string_length (s));
1916 #endif /* ERROR_CHECK_BUFPOS */
1918 if (pos >= 0 && delta < 0)
1919 /* If DELTA < 0, the functions below will delete the characters
1920 before POS. We want to delete characters *after* POS, however,
1921 so convert this to the appropriate form. */
1925 /* simplest case: no size change. */
1929 Bytecount oldfullsize = STRING_FULLSIZE (string_length (s));
1930 Bytecount newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1932 if (oldfullsize == newfullsize)
1934 /* next simplest case; size change but the necessary
1935 allocation size won't change (up or down; code somewhere
1936 depends on there not being any unused allocation space,
1937 modulo any alignment constraints). */
1940 Bufbyte *addroff = pos + string_data (s);
1942 memmove (addroff + delta, addroff,
1943 /* +1 due to zero-termination. */
1944 string_length (s) + 1 - pos);
1947 else if (BIG_STRING_FULLSIZE_P (oldfullsize) &&
1948 BIG_STRING_FULLSIZE_P (newfullsize))
1950 /* next simplest case; the string is big enough to be malloc()ed
1951 itself, so we just realloc.
1953 It's important not to let the string get below the threshold
1954 for making big strings and still remain malloc()ed; if that
1955 were the case, repeated calls to this function on the same
1956 string could result in memory leakage. */
1957 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1961 Bufbyte *addroff = pos + string_data (s);
1963 memmove (addroff + delta, addroff,
1964 /* +1 due to zero-termination. */
1965 string_length (s) + 1 - pos);
1970 /* worst case. We make a new string_chars struct and copy
1971 the string's data into it, inserting/deleting the delta
1972 in the process. The old string data will either get
1973 freed by us (if it was malloc()ed) or will be reclaimed
1974 in the normal course of garbage collection. */
1975 struct string_chars *s_chars =
1976 allocate_string_chars_struct (s, newfullsize);
1977 Bufbyte *new_addr = &(s_chars->chars[0]);
1978 Bufbyte *old_addr = string_data (s);
1981 memcpy (new_addr, old_addr, pos);
1982 memcpy (new_addr + pos + delta, old_addr + pos,
1983 string_length (s) + 1 - pos);
1985 set_string_data (s, new_addr);
1986 if (BIG_STRING_FULLSIZE_P (oldfullsize))
1990 /* We need to mark this chunk of the string_chars_block
1991 as unused so that compact_string_chars() doesn't
1993 struct string_chars *old_s_chars =
1994 (struct string_chars *) ((char *) old_addr -
1995 sizeof (struct Lisp_String *));
1996 /* Sanity check to make sure we aren't hosed by strange
1997 alignment/padding. */
1998 assert (old_s_chars->string == s);
1999 MARK_STRUCT_AS_FREE (old_s_chars);
2000 ((struct unused_string_chars *) old_s_chars)->fullsize =
2005 set_string_length (s, string_length (s) + delta);
2006 /* If pos < 0, the string won't be zero-terminated.
2007 Terminate now just to make sure. */
2008 string_data (s)[string_length (s)] = '\0';
2014 XSETSTRING (string, s);
2015 /* We also have to adjust all of the extent indices after the
2016 place we did the change. We say "pos - 1" because
2017 adjust_extents() is exclusive of the starting position
2019 adjust_extents (string, pos - 1, string_length (s),
2024 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2025 verify_string_chars_integrity ();
2032 set_string_char (struct Lisp_String *s, Charcount i, Emchar c)
2034 Bufbyte newstr[MAX_EMCHAR_LEN];
2035 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2036 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2037 Bytecount newlen = set_charptr_emchar (newstr, c);
2039 if (oldlen != newlen)
2040 resize_string (s, bytoff, newlen - oldlen);
2041 /* Remember, string_data (s) might have changed so we can't cache it. */
2042 memcpy (string_data (s) + bytoff, newstr, newlen);
2047 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2048 Return a new string of length LENGTH, with each character being INIT.
2049 LENGTH must be an integer and INIT must be a character.
2053 CHECK_NATNUM (length);
2054 CHECK_CHAR_COERCE_INT (init);
2056 Bufbyte init_str[MAX_EMCHAR_LEN];
2057 int len = set_charptr_emchar (init_str, XCHAR (init));
2058 Lisp_Object val = make_uninit_string (len * XINT (length));
2061 /* Optimize the single-byte case */
2062 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2066 Bufbyte *ptr = XSTRING_DATA (val);
2068 for (i = XINT (length); i; i--)
2070 Bufbyte *init_ptr = init_str;
2074 case 6: *ptr++ = *init_ptr++;
2075 case 5: *ptr++ = *init_ptr++;
2077 case 4: *ptr++ = *init_ptr++;
2078 case 3: *ptr++ = *init_ptr++;
2079 case 2: *ptr++ = *init_ptr++;
2080 case 1: *ptr++ = *init_ptr++;
2088 DEFUN ("string", Fstring, 0, MANY, 0, /*
2089 Concatenate all the argument characters and make the result a string.
2091 (int nargs, Lisp_Object *args))
2093 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2094 Bufbyte *p = storage;
2096 for (; nargs; nargs--, args++)
2098 Lisp_Object lisp_char = *args;
2099 CHECK_CHAR_COERCE_INT (lisp_char);
2100 p += set_charptr_emchar (p, XCHAR (lisp_char));
2102 return make_string (storage, p - storage);
2106 /* Take some raw memory, which MUST already be in internal format,
2107 and package it up into a Lisp string. */
2109 make_string (CONST Bufbyte *contents, Bytecount length)
2113 /* Make sure we find out about bad make_string's when they happen */
2114 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2115 bytecount_to_charcount (contents, length); /* Just for the assertions */
2118 val = make_uninit_string (length);
2119 memcpy (XSTRING_DATA (val), contents, length);
2123 /* Take some raw memory, encoded in some external data format,
2124 and convert it into a Lisp string. */
2126 make_ext_string (CONST Extbyte *contents, EMACS_INT length,
2127 enum external_data_format fmt)
2132 GET_CHARPTR_INT_DATA_ALLOCA (contents, length, fmt, intstr, intlen);
2133 return make_string (intstr, intlen);
2137 build_string (CONST char *str)
2139 /* Some strlen's crash and burn if passed null. */
2140 return make_string ((CONST Bufbyte *) str, (str ? strlen(str) : 0));
2144 build_ext_string (CONST char *str, enum external_data_format fmt)
2146 /* Some strlen's crash and burn if passed null. */
2147 return make_ext_string ((CONST Extbyte *) str, (str ? strlen(str) : 0), fmt);
2151 build_translated_string (CONST char *str)
2153 return build_string (GETTEXT (str));
2157 make_string_nocopy (CONST Bufbyte *contents, Bytecount length)
2159 struct Lisp_String *s;
2162 /* Make sure we find out about bad make_string_nocopy's when they happen */
2163 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2164 bytecount_to_charcount (contents, length); /* Just for the assertions */
2167 /* Allocate the string header */
2168 ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
2169 set_lheader_implementation (&(s->lheader), &lrecord_string);
2170 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2172 set_string_data (s, (Bufbyte *)contents);
2173 set_string_length (s, length);
2175 XSETSTRING (val, s);
2180 /************************************************************************/
2181 /* lcrecord lists */
2182 /************************************************************************/
2184 /* Lcrecord lists are used to manage the allocation of particular
2185 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2186 malloc() and garbage-collection junk) as much as possible.
2187 It is similar to the Blocktype class.
2191 1) Create an lcrecord-list object using make_lcrecord_list().
2192 This is often done at initialization. Remember to staticpro
2193 this object! The arguments to make_lcrecord_list() are the
2194 same as would be passed to alloc_lcrecord().
2195 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2196 and pass the lcrecord-list earlier created.
2197 3) When done with the lcrecord, call free_managed_lcrecord().
2198 The standard freeing caveats apply: ** make sure there are no
2199 pointers to the object anywhere! **
2200 4) Calling free_managed_lcrecord() is just like kissing the
2201 lcrecord goodbye as if it were garbage-collected. This means:
2202 -- the contents of the freed lcrecord are undefined, and the
2203 contents of something produced by allocate_managed_lcrecord()
2204 are undefined, just like for alloc_lcrecord().
2205 -- the mark method for the lcrecord's type will *NEVER* be called
2207 -- the finalize method for the lcrecord's type will be called
2208 at the time that free_managed_lcrecord() is called.
2213 mark_lcrecord_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
2215 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2216 Lisp_Object chain = list->free;
2218 while (!NILP (chain))
2220 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2221 struct free_lcrecord_header *free_header =
2222 (struct free_lcrecord_header *) lheader;
2224 #ifdef ERROR_CHECK_GC
2225 CONST struct lrecord_implementation *implementation
2226 = LHEADER_IMPLEMENTATION(lheader);
2228 /* There should be no other pointers to the free list. */
2229 assert (!MARKED_RECORD_HEADER_P (lheader));
2230 /* Only lcrecords should be here. */
2231 assert (!implementation->basic_p);
2232 /* Only free lcrecords should be here. */
2233 assert (free_header->lcheader.free);
2234 /* The type of the lcrecord must be right. */
2235 assert (implementation == list->implementation);
2236 /* So must the size. */
2237 assert (implementation->static_size == 0
2238 || implementation->static_size == list->size);
2239 #endif /* ERROR_CHECK_GC */
2241 MARK_RECORD_HEADER (lheader);
2242 chain = free_header->chain;
2248 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2249 mark_lcrecord_list, internal_object_printer,
2250 0, 0, 0, struct lcrecord_list);
2252 make_lcrecord_list (size_t size,
2253 CONST struct lrecord_implementation *implementation)
2255 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2256 &lrecord_lcrecord_list);
2259 p->implementation = implementation;
2262 XSETLCRECORD_LIST (val, p);
2267 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2269 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2270 if (!NILP (list->free))
2272 Lisp_Object val = list->free;
2273 struct free_lcrecord_header *free_header =
2274 (struct free_lcrecord_header *) XPNTR (val);
2276 #ifdef ERROR_CHECK_GC
2277 struct lrecord_header *lheader =
2278 (struct lrecord_header *) free_header;
2279 CONST struct lrecord_implementation *implementation
2280 = LHEADER_IMPLEMENTATION (lheader);
2282 /* There should be no other pointers to the free list. */
2283 assert (!MARKED_RECORD_HEADER_P (lheader));
2284 /* Only lcrecords should be here. */
2285 assert (!implementation->basic_p);
2286 /* Only free lcrecords should be here. */
2287 assert (free_header->lcheader.free);
2288 /* The type of the lcrecord must be right. */
2289 assert (implementation == list->implementation);
2290 /* So must the size. */
2291 assert (implementation->static_size == 0
2292 || implementation->static_size == list->size);
2293 #endif /* ERROR_CHECK_GC */
2294 list->free = free_header->chain;
2295 free_header->lcheader.free = 0;
2302 XSETOBJ (val, Lisp_Type_Record,
2303 alloc_lcrecord (list->size, list->implementation));
2309 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2311 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2312 struct free_lcrecord_header *free_header =
2313 (struct free_lcrecord_header *) XPNTR (lcrecord);
2314 struct lrecord_header *lheader =
2315 (struct lrecord_header *) free_header;
2316 CONST struct lrecord_implementation *implementation
2317 = LHEADER_IMPLEMENTATION (lheader);
2319 #ifdef ERROR_CHECK_GC
2320 /* Make sure the size is correct. This will catch, for example,
2321 putting a window configuration on the wrong free list. */
2322 if (implementation->size_in_bytes_method)
2323 assert (implementation->size_in_bytes_method (lheader) == list->size);
2325 assert (implementation->static_size == list->size);
2326 #endif /* ERROR_CHECK_GC */
2328 if (implementation->finalizer)
2329 implementation->finalizer (lheader, 0);
2330 free_header->chain = list->free;
2331 free_header->lcheader.free = 1;
2332 list->free = lcrecord;
2338 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2339 Kept for compatibility, returns its argument.
2341 Make a copy of OBJECT in pure storage.
2342 Recursively copies contents of vectors and cons cells.
2343 Does not copy symbols.
2352 /************************************************************************/
2353 /* Garbage Collection */
2354 /************************************************************************/
2356 /* This will be used more extensively In The Future */
2357 static int last_lrecord_type_index_assigned;
2359 CONST struct lrecord_implementation *lrecord_implementations_table[128];
2360 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
2362 struct gcpro *gcprolist;
2364 /* 415 used Mly 29-Jun-93 */
2365 /* 1327 used slb 28-Feb-98 */
2367 #define NSTATICS 4000
2369 #define NSTATICS 2000
2371 /* Not "static" because of linker lossage on some systems */
2372 Lisp_Object *staticvec[NSTATICS]
2373 /* Force it into data space! */
2375 static int staticidx;
2377 /* Put an entry in staticvec, pointing at the variable whose address is given
2380 staticpro (Lisp_Object *varaddress)
2382 if (staticidx >= countof (staticvec))
2383 /* #### This is now a dubious abort() since this routine may be called */
2384 /* by Lisp attempting to load a DLL. */
2386 staticvec[staticidx++] = varaddress;
2390 /* Mark reference to a Lisp_Object. If the object referred to has not been
2391 seen yet, recursively mark all the references contained in it. */
2394 mark_object (Lisp_Object obj)
2398 #ifdef ERROR_CHECK_GC
2399 assert (! (GC_EQ (obj, Qnull_pointer)));
2401 /* Checks we used to perform */
2402 /* if (EQ (obj, Qnull_pointer)) return; */
2403 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2404 /* if (PURIFIED (XPNTR (obj))) return; */
2406 if (XGCTYPE (obj) == Lisp_Type_Record)
2408 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2409 #if defined (ERROR_CHECK_GC)
2410 assert (lheader->type <= last_lrecord_type_index_assigned);
2412 if (C_READONLY_RECORD_HEADER_P (lheader))
2415 if (! MARKED_RECORD_HEADER_P (lheader) &&
2416 ! UNMARKABLE_RECORD_HEADER_P (lheader))
2418 CONST struct lrecord_implementation *implementation =
2419 LHEADER_IMPLEMENTATION (lheader);
2420 MARK_RECORD_HEADER (lheader);
2421 #ifdef ERROR_CHECK_GC
2422 if (!implementation->basic_p)
2423 assert (! ((struct lcrecord_header *) lheader)->free);
2425 if (implementation->marker)
2427 obj = implementation->marker (obj, mark_object);
2428 if (!GC_NILP (obj)) goto tail_recurse;
2434 /* mark all of the conses in a list and mark the final cdr; but
2435 DO NOT mark the cars.
2437 Use only for internal lists! There should never be other pointers
2438 to the cons cells, because if so, the cars will remain unmarked
2439 even when they maybe should be marked. */
2441 mark_conses_in_list (Lisp_Object obj)
2445 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2447 if (CONS_MARKED_P (XCONS (rest)))
2449 MARK_CONS (XCONS (rest));
2456 /* Find all structures not marked, and free them. */
2458 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2459 static int gc_count_bit_vector_storage;
2460 static int gc_count_num_short_string_in_use;
2461 static int gc_count_string_total_size;
2462 static int gc_count_short_string_total_size;
2464 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2468 lrecord_type_index (CONST struct lrecord_implementation *implementation)
2470 int type_index = *(implementation->lrecord_type_index);
2471 /* Have to do this circuitous validation test because of problems
2472 dumping out initialized variables (ie can't set xxx_type_index to -1
2473 because that would make xxx_type_index read-only in a dumped emacs. */
2474 if (type_index < 0 || type_index > max_lrecord_type
2475 || lrecord_implementations_table[type_index] != implementation)
2477 assert (last_lrecord_type_index_assigned < max_lrecord_type);
2478 type_index = ++last_lrecord_type_index_assigned;
2479 lrecord_implementations_table[type_index] = implementation;
2480 *(implementation->lrecord_type_index) = type_index;
2485 /* stats on lcrecords in use - kinda kludgy */
2489 int instances_in_use;
2491 int instances_freed;
2493 int instances_on_free_list;
2494 } lcrecord_stats [countof (lrecord_implementations_table)];
2497 tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p)
2499 CONST struct lrecord_implementation *implementation =
2500 LHEADER_IMPLEMENTATION (h);
2501 int type_index = lrecord_type_index (implementation);
2503 if (((struct lcrecord_header *) h)->free)
2506 lcrecord_stats[type_index].instances_on_free_list++;
2510 size_t sz = (implementation->size_in_bytes_method
2511 ? implementation->size_in_bytes_method (h)
2512 : implementation->static_size);
2516 lcrecord_stats[type_index].instances_freed++;
2517 lcrecord_stats[type_index].bytes_freed += sz;
2521 lcrecord_stats[type_index].instances_in_use++;
2522 lcrecord_stats[type_index].bytes_in_use += sz;
2528 /* Free all unmarked records */
2530 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2532 struct lcrecord_header *header;
2534 /* int total_size = 0; */
2536 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2538 /* First go through and call all the finalize methods.
2539 Then go through and free the objects. There used to
2540 be only one loop here, with the call to the finalizer
2541 occurring directly before the xfree() below. That
2542 is marginally faster but much less safe -- if the
2543 finalize method for an object needs to reference any
2544 other objects contained within it (and many do),
2545 we could easily be screwed by having already freed that
2548 for (header = *prev; header; header = header->next)
2550 struct lrecord_header *h = &(header->lheader);
2551 if (!C_READONLY_RECORD_HEADER_P(h)
2552 && !MARKED_RECORD_HEADER_P (h)
2553 && ! (header->free))
2555 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2556 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2560 for (header = *prev; header; )
2562 struct lrecord_header *h = &(header->lheader);
2563 if (C_READONLY_RECORD_HEADER_P(h) || MARKED_RECORD_HEADER_P (h))
2565 if (MARKED_RECORD_HEADER_P (h))
2566 UNMARK_RECORD_HEADER (h);
2568 /* total_size += n->implementation->size_in_bytes (h);*/
2569 /* ### May modify header->next on a C_READONLY lcrecord */
2570 prev = &(header->next);
2572 tick_lcrecord_stats (h, 0);
2576 struct lcrecord_header *next = header->next;
2578 tick_lcrecord_stats (h, 1);
2579 /* used to call finalizer right here. */
2585 /* *total = total_size; */
2590 sweep_bit_vectors_1 (Lisp_Object *prev,
2591 int *used, int *total, int *storage)
2593 Lisp_Object bit_vector;
2596 int total_storage = 0;
2598 /* BIT_VECTORP fails because the objects are marked, which changes
2599 their implementation */
2600 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2602 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2604 if (C_READONLY_RECORD_HEADER_P(&(v->lheader)) || MARKED_RECORD_P (bit_vector))
2606 if (MARKED_RECORD_P (bit_vector))
2607 UNMARK_RECORD_HEADER (&(v->lheader));
2611 STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2612 BIT_VECTOR_LONG_STORAGE (len));
2614 /* ### May modify next on a C_READONLY bitvector */
2615 prev = &(bit_vector_next (v));
2620 Lisp_Object next = bit_vector_next (v);
2627 *total = total_size;
2628 *storage = total_storage;
2631 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2632 to make macros prettier. */
2634 #ifdef ERROR_CHECK_GC
2636 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2638 struct typename##_block *SFTB_current; \
2639 struct typename##_block **SFTB_prev; \
2641 int num_free = 0, num_used = 0; \
2643 for (SFTB_prev = ¤t_##typename##_block, \
2644 SFTB_current = current_##typename##_block, \
2645 SFTB_limit = current_##typename##_block_index; \
2651 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2653 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2655 if (FREE_STRUCT_P (SFTB_victim)) \
2659 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2663 else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2666 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2671 UNMARK_##typename (SFTB_victim); \
2674 SFTB_prev = &(SFTB_current->prev); \
2675 SFTB_current = SFTB_current->prev; \
2676 SFTB_limit = countof (current_##typename##_block->block); \
2679 gc_count_num_##typename##_in_use = num_used; \
2680 gc_count_num_##typename##_freelist = num_free; \
2683 #else /* !ERROR_CHECK_GC */
2685 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2687 struct typename##_block *SFTB_current; \
2688 struct typename##_block **SFTB_prev; \
2690 int num_free = 0, num_used = 0; \
2692 typename##_free_list = 0; \
2694 for (SFTB_prev = ¤t_##typename##_block, \
2695 SFTB_current = current_##typename##_block, \
2696 SFTB_limit = current_##typename##_block_index; \
2701 int SFTB_empty = 1; \
2702 obj_type *SFTB_old_free_list = typename##_free_list; \
2704 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2706 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2708 if (FREE_STRUCT_P (SFTB_victim)) \
2711 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2713 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2718 else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2721 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2727 UNMARK_##typename (SFTB_victim); \
2732 SFTB_prev = &(SFTB_current->prev); \
2733 SFTB_current = SFTB_current->prev; \
2735 else if (SFTB_current == current_##typename##_block \
2736 && !SFTB_current->prev) \
2738 /* No real point in freeing sole allocation block */ \
2743 struct typename##_block *SFTB_victim_block = SFTB_current; \
2744 if (SFTB_victim_block == current_##typename##_block) \
2745 current_##typename##_block_index \
2746 = countof (current_##typename##_block->block); \
2747 SFTB_current = SFTB_current->prev; \
2749 *SFTB_prev = SFTB_current; \
2750 xfree (SFTB_victim_block); \
2751 /* Restore free list to what it was before victim was swept */ \
2752 typename##_free_list = SFTB_old_free_list; \
2753 num_free -= SFTB_limit; \
2756 SFTB_limit = countof (current_##typename##_block->block); \
2759 gc_count_num_##typename##_in_use = num_used; \
2760 gc_count_num_##typename##_freelist = num_free; \
2763 #endif /* !ERROR_CHECK_GC */
2771 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2772 #define ADDITIONAL_FREE_cons(ptr)
2774 SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons);
2777 /* Explicitly free a cons cell. */
2779 free_cons (struct Lisp_Cons *ptr)
2781 #ifdef ERROR_CHECK_GC
2782 /* If the CAR is not an int, then it will be a pointer, which will
2783 always be four-byte aligned. If this cons cell has already been
2784 placed on the free list, however, its car will probably contain
2785 a chain pointer to the next cons on the list, which has cleverly
2786 had all its 0's and 1's inverted. This allows for a quick
2787 check to make sure we're not freeing something already freed. */
2788 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2789 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2790 #endif /* ERROR_CHECK_GC */
2792 #ifndef ALLOC_NO_POOLS
2793 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, struct Lisp_Cons, ptr);
2794 #endif /* ALLOC_NO_POOLS */
2797 /* explicitly free a list. You **must make sure** that you have
2798 created all the cons cells that make up this list and that there
2799 are no pointers to any of these cons cells anywhere else. If there
2800 are, you will lose. */
2803 free_list (Lisp_Object list)
2805 Lisp_Object rest, next;
2807 for (rest = list; !NILP (rest); rest = next)
2810 free_cons (XCONS (rest));
2814 /* explicitly free an alist. You **must make sure** that you have
2815 created all the cons cells that make up this alist and that there
2816 are no pointers to any of these cons cells anywhere else. If there
2817 are, you will lose. */
2820 free_alist (Lisp_Object alist)
2822 Lisp_Object rest, next;
2824 for (rest = alist; !NILP (rest); rest = next)
2827 free_cons (XCONS (XCAR (rest)));
2828 free_cons (XCONS (rest));
2833 sweep_compiled_functions (void)
2835 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2836 #define ADDITIONAL_FREE_compiled_function(ptr)
2838 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2842 #ifdef LISP_FLOAT_TYPE
2846 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2847 #define ADDITIONAL_FREE_float(ptr)
2849 SWEEP_FIXED_TYPE_BLOCK (float, struct Lisp_Float);
2851 #endif /* LISP_FLOAT_TYPE */
2854 sweep_symbols (void)
2856 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2857 #define ADDITIONAL_FREE_symbol(ptr)
2859 SWEEP_FIXED_TYPE_BLOCK (symbol, struct Lisp_Symbol);
2863 sweep_extents (void)
2865 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2866 #define ADDITIONAL_FREE_extent(ptr)
2868 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2874 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2875 #define ADDITIONAL_FREE_event(ptr)
2877 SWEEP_FIXED_TYPE_BLOCK (event, struct Lisp_Event);
2881 sweep_markers (void)
2883 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2884 #define ADDITIONAL_FREE_marker(ptr) \
2885 do { Lisp_Object tem; \
2886 XSETMARKER (tem, ptr); \
2887 unchain_marker (tem); \
2890 SWEEP_FIXED_TYPE_BLOCK (marker, struct Lisp_Marker);
2893 /* Explicitly free a marker. */
2895 free_marker (struct Lisp_Marker *ptr)
2897 #ifdef ERROR_CHECK_GC
2898 /* Perhaps this will catch freeing an already-freed marker. */
2900 XSETMARKER (temmy, ptr);
2901 assert (GC_MARKERP (temmy));
2902 #endif /* ERROR_CHECK_GC */
2904 #ifndef ALLOC_NO_POOLS
2905 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr);
2906 #endif /* ALLOC_NO_POOLS */
2910 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2913 verify_string_chars_integrity (void)
2915 struct string_chars_block *sb;
2917 /* Scan each existing string block sequentially, string by string. */
2918 for (sb = first_string_chars_block; sb; sb = sb->next)
2921 /* POS is the index of the next string in the block. */
2922 while (pos < sb->pos)
2924 struct string_chars *s_chars =
2925 (struct string_chars *) &(sb->string_chars[pos]);
2926 struct Lisp_String *string;
2930 /* If the string_chars struct is marked as free (i.e. the STRING
2931 pointer is 0xFFFFFFFF) then this is an unused chunk of string
2932 storage. (See below.) */
2934 if (FREE_STRUCT_P (s_chars))
2936 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
2941 string = s_chars->string;
2942 /* Must be 32-bit aligned. */
2943 assert ((((int) string) & 3) == 0);
2945 size = string_length (string);
2946 fullsize = STRING_FULLSIZE (size);
2948 assert (!BIG_STRING_FULLSIZE_P (fullsize));
2949 assert (string_data (string) == s_chars->chars);
2952 assert (pos == sb->pos);
2956 #endif /* MULE && ERROR_CHECK_GC */
2958 /* Compactify string chars, relocating the reference to each --
2959 free any empty string_chars_block we see. */
2961 compact_string_chars (void)
2963 struct string_chars_block *to_sb = first_string_chars_block;
2965 struct string_chars_block *from_sb;
2967 /* Scan each existing string block sequentially, string by string. */
2968 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
2971 /* FROM_POS is the index of the next string in the block. */
2972 while (from_pos < from_sb->pos)
2974 struct string_chars *from_s_chars =
2975 (struct string_chars *) &(from_sb->string_chars[from_pos]);
2976 struct string_chars *to_s_chars;
2977 struct Lisp_String *string;
2981 /* If the string_chars struct is marked as free (i.e. the STRING
2982 pointer is 0xFFFFFFFF) then this is an unused chunk of string
2983 storage. This happens under Mule when a string's size changes
2984 in such a way that its fullsize changes. (Strings can change
2985 size because a different-length character can be substituted
2986 for another character.) In this case, after the bogus string
2987 pointer is the "fullsize" of this entry, i.e. how many bytes
2990 if (FREE_STRUCT_P (from_s_chars))
2992 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
2993 from_pos += fullsize;
2997 string = from_s_chars->string;
2998 assert (!(FREE_STRUCT_P (string)));
3000 size = string_length (string);
3001 fullsize = STRING_FULLSIZE (size);
3003 if (BIG_STRING_FULLSIZE_P (fullsize))
3006 /* Just skip it if it isn't marked. */
3007 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3009 from_pos += fullsize;
3013 /* If it won't fit in what's left of TO_SB, close TO_SB out
3014 and go on to the next string_chars_block. We know that TO_SB
3015 cannot advance past FROM_SB here since FROM_SB is large enough
3016 to currently contain this string. */
3017 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3019 to_sb->pos = to_pos;
3020 to_sb = to_sb->next;
3024 /* Compute new address of this string
3025 and update TO_POS for the space being used. */
3026 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3028 /* Copy the string_chars to the new place. */
3029 if (from_s_chars != to_s_chars)
3030 memmove (to_s_chars, from_s_chars, fullsize);
3032 /* Relocate FROM_S_CHARS's reference */
3033 set_string_data (string, &(to_s_chars->chars[0]));
3035 from_pos += fullsize;
3040 /* Set current to the last string chars block still used and
3041 free any that follow. */
3043 struct string_chars_block *victim;
3045 for (victim = to_sb->next; victim; )
3047 struct string_chars_block *next = victim->next;
3052 current_string_chars_block = to_sb;
3053 current_string_chars_block->pos = to_pos;
3054 current_string_chars_block->next = 0;
3058 #if 1 /* Hack to debug missing purecopy's */
3059 static int debug_string_purity;
3062 debug_string_purity_print (struct Lisp_String *p)
3065 Charcount s = string_char_length (p);
3066 putc ('\"', stderr);
3067 for (i = 0; i < s; i++)
3069 Emchar ch = string_char (p, i);
3070 if (ch < 32 || ch >= 126)
3071 stderr_out ("\\%03o", ch);
3072 else if (ch == '\\' || ch == '\"')
3073 stderr_out ("\\%c", ch);
3075 stderr_out ("%c", ch);
3077 stderr_out ("\"\n");
3083 sweep_strings (void)
3085 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3086 int debug = debug_string_purity;
3088 #define UNMARK_string(ptr) \
3089 do { struct Lisp_String *p = (ptr); \
3090 int size = string_length (p); \
3091 UNMARK_RECORD_HEADER (&(p->lheader)); \
3092 num_bytes += size; \
3093 if (!BIG_STRING_SIZE_P (size)) \
3094 { num_small_bytes += size; \
3097 if (debug) debug_string_purity_print (p); \
3099 #define ADDITIONAL_FREE_string(p) \
3100 do { int size = string_length (p); \
3101 if (BIG_STRING_SIZE_P (size)) \
3102 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
3105 SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String);
3107 gc_count_num_short_string_in_use = num_small_used;
3108 gc_count_string_total_size = num_bytes;
3109 gc_count_short_string_total_size = num_small_bytes;
3113 /* I hate duplicating all this crap! */
3115 marked_p (Lisp_Object obj)
3117 #ifdef ERROR_CHECK_GC
3118 assert (! (GC_EQ (obj, Qnull_pointer)));
3120 /* Checks we used to perform. */
3121 /* if (EQ (obj, Qnull_pointer)) return 1; */
3122 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3123 /* if (PURIFIED (XPNTR (obj))) return 1; */
3125 if (XGCTYPE (obj) == Lisp_Type_Record)
3127 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3128 #if defined (ERROR_CHECK_GC)
3129 assert (lheader->type <= last_lrecord_type_index_assigned);
3131 return C_READONLY_RECORD_HEADER_P (lheader) || MARKED_RECORD_HEADER_P (lheader);
3139 /* Free all unmarked records. Do this at the very beginning,
3140 before anything else, so that the finalize methods can safely
3141 examine items in the objects. sweep_lcrecords_1() makes
3142 sure to call all the finalize methods *before* freeing anything,
3143 to complete the safety. */
3146 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3149 compact_string_chars ();
3151 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3152 macros) must be *extremely* careful to make sure they're not
3153 referencing freed objects. The only two existing finalize
3154 methods (for strings and markers) pass muster -- the string
3155 finalizer doesn't look at anything but its own specially-
3156 created block, and the marker finalizer only looks at live
3157 buffers (which will never be freed) and at the markers before
3158 and after it in the chain (which, by induction, will never be
3159 freed because if so, they would have already removed themselves
3162 /* Put all unmarked strings on free list, free'ing the string chars
3163 of large unmarked strings */
3166 /* Put all unmarked conses on free list */
3169 /* Free all unmarked bit vectors */
3170 sweep_bit_vectors_1 (&all_bit_vectors,
3171 &gc_count_num_bit_vector_used,
3172 &gc_count_bit_vector_total_size,
3173 &gc_count_bit_vector_storage);
3175 /* Free all unmarked compiled-function objects */
3176 sweep_compiled_functions ();
3178 #ifdef LISP_FLOAT_TYPE
3179 /* Put all unmarked floats on free list */
3183 /* Put all unmarked symbols on free list */
3186 /* Put all unmarked extents on free list */
3189 /* Put all unmarked markers on free list.
3190 Dechain each one first from the buffer into which it points. */
3197 /* Clearing for disksave. */
3200 disksave_object_finalization (void)
3202 /* It's important that certain information from the environment not get
3203 dumped with the executable (pathnames, environment variables, etc.).
3204 To make it easier to tell when this has happened with strings(1) we
3205 clear some known-to-be-garbage blocks of memory, so that leftover
3206 results of old evaluation don't look like potential problems.
3207 But first we set some notable variables to nil and do one more GC,
3208 to turn those strings into garbage.
3211 /* Yeah, this list is pretty ad-hoc... */
3212 Vprocess_environment = Qnil;
3213 Vexec_directory = Qnil;
3214 Vdata_directory = Qnil;
3215 Vsite_directory = Qnil;
3216 Vdoc_directory = Qnil;
3217 Vconfigure_info_directory = Qnil;
3220 /* Vdump_load_path = Qnil; */
3221 /* Release hash tables for locate_file */
3222 Flocate_file_clear_hashing (Qt);
3223 uncache_home_directory();
3225 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3226 defined(LOADHIST_BUILTIN))
3227 Vload_history = Qnil;
3229 Vshell_file_name = Qnil;
3231 garbage_collect_1 ();
3233 /* Run the disksave finalization methods of all live objects. */
3234 disksave_object_finalization_1 ();
3236 /* Zero out the uninitialized (really, unused) part of the containers
3237 for the live strings. */
3239 struct string_chars_block *scb;
3240 for (scb = first_string_chars_block; scb; scb = scb->next)
3242 int count = sizeof (scb->string_chars) - scb->pos;
3244 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3246 /* from the block's fill ptr to the end */
3247 memset ((scb->string_chars + scb->pos), 0, count);
3252 /* There, that ought to be enough... */
3258 restore_gc_inhibit (Lisp_Object val)
3260 gc_currently_forbidden = XINT (val);
3264 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3265 static int gc_hooks_inhibited;
3269 garbage_collect_1 (void)
3271 #if MAX_SAVE_STACK > 0
3272 char stack_top_variable;
3273 extern char *stack_bottom;
3278 Lisp_Object pre_gc_cursor;
3279 struct gcpro gcpro1;
3282 || gc_currently_forbidden
3284 || preparing_for_armageddon)
3287 /* We used to call selected_frame() here.
3289 The following functions cannot be called inside GC
3290 so we move to after the above tests. */
3293 Lisp_Object device = Fselected_device (Qnil);
3294 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3296 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3298 signal_simple_error ("No frames exist on device", device);
3302 pre_gc_cursor = Qnil;
3305 GCPRO1 (pre_gc_cursor);
3307 /* Very important to prevent GC during any of the following
3308 stuff that might run Lisp code; otherwise, we'll likely
3309 have infinite GC recursion. */
3310 speccount = specpdl_depth ();
3311 record_unwind_protect (restore_gc_inhibit,
3312 make_int (gc_currently_forbidden));
3313 gc_currently_forbidden = 1;
3315 if (!gc_hooks_inhibited)
3316 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3318 /* Now show the GC cursor/message. */
3319 if (!noninteractive)
3321 if (FRAME_WIN_P (f))
3323 Lisp_Object frame = make_frame (f);
3324 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3325 FRAME_SELECTED_WINDOW (f),
3327 pre_gc_cursor = f->pointer;
3328 if (POINTER_IMAGE_INSTANCEP (cursor)
3329 /* don't change if we don't know how to change back. */
3330 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3333 Fset_frame_pointer (frame, cursor);
3337 /* Don't print messages to the stream device. */
3338 if (!cursor_changed && !FRAME_STREAM_P (f))
3340 char *msg = (STRINGP (Vgc_message)
3341 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3343 Lisp_Object args[2], whole_msg;
3344 args[0] = build_string (msg ? msg :
3345 GETTEXT ((CONST char *) gc_default_message));
3346 args[1] = build_string ("...");
3347 whole_msg = Fconcat (2, args);
3348 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3349 Qgarbage_collecting);
3353 /***** Now we actually start the garbage collection. */
3357 gc_generation_number[0]++;
3359 #if MAX_SAVE_STACK > 0
3361 /* Save a copy of the contents of the stack, for debugging. */
3364 /* Static buffer in which we save a copy of the C stack at each GC. */
3365 static char *stack_copy;
3366 static size_t stack_copy_size;
3368 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3369 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3370 if (stack_size < MAX_SAVE_STACK)
3372 if (stack_copy_size < stack_size)
3374 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3375 stack_copy_size = stack_size;
3379 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3383 #endif /* MAX_SAVE_STACK > 0 */
3385 /* Do some totally ad-hoc resource clearing. */
3386 /* #### generalize this? */
3387 clear_event_resource ();
3388 cleanup_specifiers ();
3390 /* Mark all the special slots that serve as the roots of accessibility. */
3394 for (i = 0; i < staticidx; i++)
3395 mark_object (*(staticvec[i]));
3401 for (tail = gcprolist; tail; tail = tail->next)
3402 for (i = 0; i < tail->nvars; i++)
3403 mark_object (tail->var[i]);
3407 struct specbinding *bind;
3408 for (bind = specpdl; bind != specpdl_ptr; bind++)
3410 mark_object (bind->symbol);
3411 mark_object (bind->old_value);
3416 struct catchtag *catch;
3417 for (catch = catchlist; catch; catch = catch->next)
3419 mark_object (catch->tag);
3420 mark_object (catch->val);
3425 struct backtrace *backlist;
3426 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3428 int nargs = backlist->nargs;
3431 mark_object (*backlist->function);
3432 if (nargs == UNEVALLED || nargs == MANY)
3433 mark_object (backlist->args[0]);
3435 for (i = 0; i < nargs; i++)
3436 mark_object (backlist->args[i]);
3440 mark_redisplay (mark_object);
3441 mark_profiling_info (mark_object);
3443 /* OK, now do the after-mark stuff. This is for things that
3444 are only marked when something else is marked (e.g. weak hash tables).
3445 There may be complex dependencies between such objects -- e.g.
3446 a weak hash table might be unmarked, but after processing a later
3447 weak hash table, the former one might get marked. So we have to
3448 iterate until nothing more gets marked. */
3450 while (finish_marking_weak_hash_tables (marked_p, mark_object) > 0 ||
3451 finish_marking_weak_lists (marked_p, mark_object) > 0)
3454 /* And prune (this needs to be called after everything else has been
3455 marked and before we do any sweeping). */
3456 /* #### this is somewhat ad-hoc and should probably be an object
3458 prune_weak_hash_tables (marked_p);
3459 prune_weak_lists (marked_p);
3460 prune_specifiers (marked_p);
3461 prune_syntax_tables (marked_p);
3465 consing_since_gc = 0;
3466 #ifndef DEBUG_XEMACS
3467 /* Allow you to set it really fucking low if you really want ... */
3468 if (gc_cons_threshold < 10000)
3469 gc_cons_threshold = 10000;
3474 /******* End of garbage collection ********/
3476 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3478 /* Now remove the GC cursor/message */
3479 if (!noninteractive)
3482 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3483 else if (!FRAME_STREAM_P (f))
3485 char *msg = (STRINGP (Vgc_message)
3486 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3489 /* Show "...done" only if the echo area would otherwise be empty. */
3490 if (NILP (clear_echo_area (selected_frame (),
3491 Qgarbage_collecting, 0)))
3493 Lisp_Object args[2], whole_msg;
3494 args[0] = build_string (msg ? msg :
3495 GETTEXT ((CONST char *)
3496 gc_default_message));
3497 args[1] = build_string ("... done");
3498 whole_msg = Fconcat (2, args);
3499 echo_area_message (selected_frame (), (Bufbyte *) 0,
3501 Qgarbage_collecting);
3506 /* now stop inhibiting GC */
3507 unbind_to (speccount, Qnil);
3509 if (!breathing_space)
3511 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3518 /* Debugging aids. */
3521 gc_plist_hack (CONST char *name, int value, Lisp_Object tail)
3523 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3524 or portable numeric datatypes, or bit-vectors, or characters, or
3525 arrays, or exceptions, or ...) */
3526 return cons3 (intern (name), make_int (value), tail);
3529 #define HACK_O_MATIC(type, name, pl) do { \
3531 struct type##_block *x = current_##type##_block; \
3532 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3533 (pl) = gc_plist_hack ((name), s, (pl)); \
3536 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3537 Reclaim storage for Lisp objects no longer needed.
3538 Return info on amount of space in use:
3539 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3540 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3542 where `PLIST' is a list of alternating keyword/value pairs providing
3543 more detailed information.
3544 Garbage collection happens automatically if you cons more than
3545 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3549 Lisp_Object pl = Qnil;
3551 int gc_count_vector_total_size = 0;
3553 garbage_collect_1 ();
3555 for (i = 0; i < last_lrecord_type_index_assigned; i++)
3557 if (lcrecord_stats[i].bytes_in_use != 0
3558 || lcrecord_stats[i].bytes_freed != 0
3559 || lcrecord_stats[i].instances_on_free_list != 0)
3562 CONST char *name = lrecord_implementations_table[i]->name;
3563 int len = strlen (name);
3564 /* save this for the FSFmacs-compatible part of the summary */
3565 if (i == *lrecord_vector.lrecord_type_index)
3566 gc_count_vector_total_size =
3567 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3569 sprintf (buf, "%s-storage", name);
3570 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3571 /* Okay, simple pluralization check for `symbol-value-varalias' */
3572 if (name[len-1] == 's')
3573 sprintf (buf, "%ses-freed", name);
3575 sprintf (buf, "%ss-freed", name);
3576 if (lcrecord_stats[i].instances_freed != 0)
3577 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3578 if (name[len-1] == 's')
3579 sprintf (buf, "%ses-on-free-list", name);
3581 sprintf (buf, "%ss-on-free-list", name);
3582 if (lcrecord_stats[i].instances_on_free_list != 0)
3583 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3585 if (name[len-1] == 's')
3586 sprintf (buf, "%ses-used", name);
3588 sprintf (buf, "%ss-used", name);
3589 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3593 HACK_O_MATIC (extent, "extent-storage", pl);
3594 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3595 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3596 HACK_O_MATIC (event, "event-storage", pl);
3597 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3598 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3599 HACK_O_MATIC (marker, "marker-storage", pl);
3600 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3601 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3602 #ifdef LISP_FLOAT_TYPE
3603 HACK_O_MATIC (float, "float-storage", pl);
3604 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3605 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3606 #endif /* LISP_FLOAT_TYPE */
3607 HACK_O_MATIC (string, "string-header-storage", pl);
3608 pl = gc_plist_hack ("long-strings-total-length",
3609 gc_count_string_total_size
3610 - gc_count_short_string_total_size, pl);
3611 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3612 pl = gc_plist_hack ("short-strings-total-length",
3613 gc_count_short_string_total_size, pl);
3614 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3615 pl = gc_plist_hack ("long-strings-used",
3616 gc_count_num_string_in_use
3617 - gc_count_num_short_string_in_use, pl);
3618 pl = gc_plist_hack ("short-strings-used",
3619 gc_count_num_short_string_in_use, pl);
3621 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3622 pl = gc_plist_hack ("compiled-functions-free",
3623 gc_count_num_compiled_function_freelist, pl);
3624 pl = gc_plist_hack ("compiled-functions-used",
3625 gc_count_num_compiled_function_in_use, pl);
3627 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3628 pl = gc_plist_hack ("bit-vectors-total-length",
3629 gc_count_bit_vector_total_size, pl);
3630 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3632 HACK_O_MATIC (symbol, "symbol-storage", pl);
3633 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3634 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3636 HACK_O_MATIC (cons, "cons-storage", pl);
3637 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3638 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3640 /* The things we do for backwards-compatibility */
3642 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3643 make_int (gc_count_num_cons_freelist)),
3644 Fcons (make_int (gc_count_num_symbol_in_use),
3645 make_int (gc_count_num_symbol_freelist)),
3646 Fcons (make_int (gc_count_num_marker_in_use),
3647 make_int (gc_count_num_marker_freelist)),
3648 make_int (gc_count_string_total_size),
3649 make_int (gc_count_vector_total_size),
3654 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3655 Return the number of bytes consed since the last garbage collection.
3656 \"Consed\" is a misnomer in that this actually counts allocation
3657 of all different kinds of objects, not just conses.
3659 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3663 return make_int (consing_since_gc);
3666 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
3667 Return the address of the last byte Emacs has allocated, divided by 1024.
3668 This may be helpful in debugging Emacs's memory usage.
3669 The value is divided by 1024 to make sure it will fit in a lisp integer.
3673 return make_int ((EMACS_INT) sbrk (0) / 1024);
3679 object_dead_p (Lisp_Object obj)
3681 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3682 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3683 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3684 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3685 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3686 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3687 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3690 #ifdef MEMORY_USAGE_STATS
3692 /* Attempt to determine the actual amount of space that is used for
3693 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3695 It seems that the following holds:
3697 1. When using the old allocator (malloc.c):
3699 -- blocks are always allocated in chunks of powers of two. For
3700 each block, there is an overhead of 8 bytes if rcheck is not
3701 defined, 20 bytes if it is defined. In other words, a
3702 one-byte allocation needs 8 bytes of overhead for a total of
3703 9 bytes, and needs to have 16 bytes of memory chunked out for
3706 2. When using the new allocator (gmalloc.c):
3708 -- blocks are always allocated in chunks of powers of two up
3709 to 4096 bytes. Larger blocks are allocated in chunks of
3710 an integral multiple of 4096 bytes. The minimum block
3711 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3712 is defined. There is no per-block overhead, but there
3713 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3716 3. When using the system malloc, anything goes, but they are
3717 generally slower and more space-efficient than the GNU
3718 allocators. One possibly reasonable assumption to make
3719 for want of better data is that sizeof (void *), or maybe
3720 2 * sizeof (void *), is required as overhead and that
3721 blocks are allocated in the minimum required size except
3722 that some minimum block size is imposed (e.g. 16 bytes). */
3725 malloced_storage_size (void *ptr, size_t claimed_size,
3726 struct overhead_stats *stats)
3728 size_t orig_claimed_size = claimed_size;
3732 if (claimed_size < 2 * sizeof (void *))
3733 claimed_size = 2 * sizeof (void *);
3734 # ifdef SUNOS_LOCALTIME_BUG
3735 if (claimed_size < 16)
3738 if (claimed_size < 4096)
3742 /* compute the log base two, more or less, then use it to compute
3743 the block size needed. */
3745 /* It's big, it's heavy, it's wood! */
3746 while ((claimed_size /= 2) != 0)
3749 /* It's better than bad, it's good! */
3755 /* We have to come up with some average about the amount of
3757 if ((size_t) (rand () & 4095) < claimed_size)
3758 claimed_size += 3 * sizeof (void *);
3762 claimed_size += 4095;
3763 claimed_size &= ~4095;
3764 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3767 #elif defined (SYSTEM_MALLOC)
3769 if (claimed_size < 16)
3771 claimed_size += 2 * sizeof (void *);
3773 #else /* old GNU allocator */
3775 # ifdef rcheck /* #### may not be defined here */
3783 /* compute the log base two, more or less, then use it to compute
3784 the block size needed. */
3786 /* It's big, it's heavy, it's wood! */
3787 while ((claimed_size /= 2) != 0)
3790 /* It's better than bad, it's good! */
3798 #endif /* old GNU allocator */
3802 stats->was_requested += orig_claimed_size;
3803 stats->malloc_overhead += claimed_size - orig_claimed_size;
3805 return claimed_size;
3809 fixed_type_block_overhead (size_t size)
3811 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3812 size_t overhead = 0;
3813 size_t storage_size = malloced_storage_size (0, per_block, 0);
3814 while (size >= per_block)
3817 overhead += sizeof (void *) + per_block - storage_size;
3819 if (rand () % per_block < size)
3820 overhead += sizeof (void *) + per_block - storage_size;
3824 #endif /* MEMORY_USAGE_STATS */
3827 /* Initialization */
3829 init_alloc_once_early (void)
3833 last_lrecord_type_index_assigned = -1;
3834 for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
3836 lrecord_implementations_table[iii] = 0;
3841 * defined subr lrecords were initialized with lheader->type == 0.
3842 * See subr_lheader_initializer in lisp.h. Force type index 0 to be
3843 * assigned to lrecord_subr so that those predefined indexes match
3846 lrecord_type_index (&lrecord_subr);
3847 assert (*(lrecord_subr.lrecord_type_index) == 0);
3849 * The same is true for symbol_value_forward objects, except the
3852 lrecord_type_index (&lrecord_symbol_value_forward);
3853 assert (*(lrecord_symbol_value_forward.lrecord_type_index) == 1);
3855 gc_generation_number[0] = 0;
3856 /* purify_flag 1 is correct even if CANNOT_DUMP.
3857 * loadup.el will set to nil at end. */
3859 breathing_space = 0;
3860 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3861 XSETINT (Vgc_message, 0);
3863 ignore_malloc_warnings = 1;
3864 #ifdef DOUG_LEA_MALLOC
3865 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3866 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3867 #if 0 /* Moved to emacs.c */
3868 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3871 init_string_alloc ();
3872 init_string_chars_alloc ();
3874 init_symbol_alloc ();
3875 init_compiled_function_alloc ();
3876 #ifdef LISP_FLOAT_TYPE
3877 init_float_alloc ();
3878 #endif /* LISP_FLOAT_TYPE */
3879 init_marker_alloc ();
3880 init_extent_alloc ();
3881 init_event_alloc ();
3883 ignore_malloc_warnings = 0;
3885 consing_since_gc = 0;
3887 gc_cons_threshold = 500000; /* XEmacs change */
3889 gc_cons_threshold = 15000; /* debugging */
3891 #ifdef VIRT_ADDR_VARIES
3892 malloc_sbrk_unused = 1<<22; /* A large number */
3893 malloc_sbrk_used = 100000; /* as reasonable as any number */
3894 #endif /* VIRT_ADDR_VARIES */
3895 lrecord_uid_counter = 259;
3896 debug_string_purity = 0;
3899 gc_currently_forbidden = 0;
3900 gc_hooks_inhibited = 0;
3902 #ifdef ERROR_CHECK_TYPECHECK
3903 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3906 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3908 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3910 #endif /* ERROR_CHECK_TYPECHECK */
3913 int pure_bytes_used = 0;
3922 syms_of_alloc (void)
3924 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
3925 defsymbol (&Qpost_gc_hook, "post-gc-hook");
3926 defsymbol (&Qgarbage_collecting, "garbage-collecting");
3931 DEFSUBR (Fbit_vector);
3932 DEFSUBR (Fmake_byte_code);
3933 DEFSUBR (Fmake_list);
3934 DEFSUBR (Fmake_vector);
3935 DEFSUBR (Fmake_bit_vector);
3936 DEFSUBR (Fmake_string);
3938 DEFSUBR (Fmake_symbol);
3939 DEFSUBR (Fmake_marker);
3940 DEFSUBR (Fpurecopy);
3941 DEFSUBR (Fgarbage_collect);
3942 DEFSUBR (Fmemory_limit);
3943 DEFSUBR (Fconsing_since_gc);
3947 vars_of_alloc (void)
3949 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
3950 *Number of bytes of consing between garbage collections.
3951 \"Consing\" is a misnomer in that this actually counts allocation
3952 of all different kinds of objects, not just conses.
3953 Garbage collection can happen automatically once this many bytes have been
3954 allocated since the last garbage collection. All data types count.
3956 Garbage collection happens automatically when `eval' or `funcall' are
3957 called. (Note that `funcall' is called implicitly as part of evaluation.)
3958 By binding this temporarily to a large number, you can effectively
3959 prevent garbage collection during a part of the program.
3961 See also `consing-since-gc'.
3964 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
3965 Number of bytes of sharable Lisp data allocated so far.
3969 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
3970 Number of bytes of unshared memory allocated in this session.
3973 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
3974 Number of bytes of unshared memory remaining available in this session.
3979 DEFVAR_INT ("debug-allocation", &debug_allocation /*
3980 If non-zero, print out information to stderr about all objects allocated.
3981 See also `debug-allocation-backtrace-length'.
3983 debug_allocation = 0;
3985 DEFVAR_INT ("debug-allocation-backtrace-length",
3986 &debug_allocation_backtrace_length /*
3987 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
3989 debug_allocation_backtrace_length = 2;
3992 DEFVAR_BOOL ("purify-flag", &purify_flag /*
3993 Non-nil means loading Lisp code in order to dump an executable.
3994 This means that certain objects should be allocated in readonly space.
3997 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
3998 Function or functions to be run just before each garbage collection.
3999 Interrupts, garbage collection, and errors are inhibited while this hook
4000 runs, so be extremely careful in what you add here. In particular, avoid
4001 consing, and do not interact with the user.
4003 Vpre_gc_hook = Qnil;
4005 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4006 Function or functions to be run just after each garbage collection.
4007 Interrupts, garbage collection, and errors are inhibited while this hook
4008 runs, so be extremely careful in what you add here. In particular, avoid
4009 consing, and do not interact with the user.
4011 Vpost_gc_hook = Qnil;
4013 DEFVAR_LISP ("gc-message", &Vgc_message /*
4014 String to print to indicate that a garbage collection is in progress.
4015 This is printed in the echo area. If the selected frame is on a
4016 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4017 image instance) in the domain of the selected frame, the mouse pointer
4018 will change instead of this message being printed.
4020 Vgc_message = make_string_nocopy ((CONST Bufbyte *) gc_default_message,
4021 countof (gc_default_message) - 1);
4023 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4024 Pointer glyph used to indicate that a garbage collection is in progress.
4025 If the selected window is on a window system and this glyph specifies a
4026 value (i.e. a pointer image instance) in the domain of the selected
4027 window, the pointer will be changed as specified during garbage collection.
4028 Otherwise, a message will be printed in the echo area, as controlled
4034 complex_vars_of_alloc (void)
4036 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);