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;
2073 case 4: *ptr++ = *init_ptr++;
2074 case 3: *ptr++ = *init_ptr++;
2075 case 2: *ptr++ = *init_ptr++;
2076 case 1: *ptr++ = *init_ptr++;
2084 DEFUN ("string", Fstring, 0, MANY, 0, /*
2085 Concatenate all the argument characters and make the result a string.
2087 (int nargs, Lisp_Object *args))
2089 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2090 Bufbyte *p = storage;
2092 for (; nargs; nargs--, args++)
2094 Lisp_Object lisp_char = *args;
2095 CHECK_CHAR_COERCE_INT (lisp_char);
2096 p += set_charptr_emchar (p, XCHAR (lisp_char));
2098 return make_string (storage, p - storage);
2102 /* Take some raw memory, which MUST already be in internal format,
2103 and package it up into a Lisp string. */
2105 make_string (CONST Bufbyte *contents, Bytecount length)
2109 /* Make sure we find out about bad make_string's when they happen */
2110 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2111 bytecount_to_charcount (contents, length); /* Just for the assertions */
2114 val = make_uninit_string (length);
2115 memcpy (XSTRING_DATA (val), contents, length);
2119 /* Take some raw memory, encoded in some external data format,
2120 and convert it into a Lisp string. */
2122 make_ext_string (CONST Extbyte *contents, EMACS_INT length,
2123 enum external_data_format fmt)
2128 GET_CHARPTR_INT_DATA_ALLOCA (contents, length, fmt, intstr, intlen);
2129 return make_string (intstr, intlen);
2133 build_string (CONST char *str)
2135 /* Some strlen's crash and burn if passed null. */
2136 return make_string ((CONST Bufbyte *) str, (str ? strlen(str) : 0));
2140 build_ext_string (CONST char *str, enum external_data_format fmt)
2142 /* Some strlen's crash and burn if passed null. */
2143 return make_ext_string ((CONST Extbyte *) str, (str ? strlen(str) : 0), fmt);
2147 build_translated_string (CONST char *str)
2149 return build_string (GETTEXT (str));
2153 make_string_nocopy (CONST Bufbyte *contents, Bytecount length)
2155 struct Lisp_String *s;
2158 /* Make sure we find out about bad make_string_nocopy's when they happen */
2159 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2160 bytecount_to_charcount (contents, length); /* Just for the assertions */
2163 /* Allocate the string header */
2164 ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
2165 set_lheader_implementation (&(s->lheader), &lrecord_string);
2166 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2168 set_string_data (s, (Bufbyte *)contents);
2169 set_string_length (s, length);
2171 XSETSTRING (val, s);
2176 /************************************************************************/
2177 /* lcrecord lists */
2178 /************************************************************************/
2180 /* Lcrecord lists are used to manage the allocation of particular
2181 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2182 malloc() and garbage-collection junk) as much as possible.
2183 It is similar to the Blocktype class.
2187 1) Create an lcrecord-list object using make_lcrecord_list().
2188 This is often done at initialization. Remember to staticpro
2189 this object! The arguments to make_lcrecord_list() are the
2190 same as would be passed to alloc_lcrecord().
2191 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2192 and pass the lcrecord-list earlier created.
2193 3) When done with the lcrecord, call free_managed_lcrecord().
2194 The standard freeing caveats apply: ** make sure there are no
2195 pointers to the object anywhere! **
2196 4) Calling free_managed_lcrecord() is just like kissing the
2197 lcrecord goodbye as if it were garbage-collected. This means:
2198 -- the contents of the freed lcrecord are undefined, and the
2199 contents of something produced by allocate_managed_lcrecord()
2200 are undefined, just like for alloc_lcrecord().
2201 -- the mark method for the lcrecord's type will *NEVER* be called
2203 -- the finalize method for the lcrecord's type will be called
2204 at the time that free_managed_lcrecord() is called.
2209 mark_lcrecord_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
2211 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2212 Lisp_Object chain = list->free;
2214 while (!NILP (chain))
2216 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2217 struct free_lcrecord_header *free_header =
2218 (struct free_lcrecord_header *) lheader;
2220 #ifdef ERROR_CHECK_GC
2221 CONST struct lrecord_implementation *implementation
2222 = LHEADER_IMPLEMENTATION(lheader);
2224 /* There should be no other pointers to the free list. */
2225 assert (!MARKED_RECORD_HEADER_P (lheader));
2226 /* Only lcrecords should be here. */
2227 assert (!implementation->basic_p);
2228 /* Only free lcrecords should be here. */
2229 assert (free_header->lcheader.free);
2230 /* The type of the lcrecord must be right. */
2231 assert (implementation == list->implementation);
2232 /* So must the size. */
2233 assert (implementation->static_size == 0
2234 || implementation->static_size == list->size);
2235 #endif /* ERROR_CHECK_GC */
2237 MARK_RECORD_HEADER (lheader);
2238 chain = free_header->chain;
2244 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2245 mark_lcrecord_list, internal_object_printer,
2246 0, 0, 0, struct lcrecord_list);
2248 make_lcrecord_list (size_t size,
2249 CONST struct lrecord_implementation *implementation)
2251 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2252 &lrecord_lcrecord_list);
2255 p->implementation = implementation;
2258 XSETLCRECORD_LIST (val, p);
2263 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2265 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2266 if (!NILP (list->free))
2268 Lisp_Object val = list->free;
2269 struct free_lcrecord_header *free_header =
2270 (struct free_lcrecord_header *) XPNTR (val);
2272 #ifdef ERROR_CHECK_GC
2273 struct lrecord_header *lheader =
2274 (struct lrecord_header *) free_header;
2275 CONST struct lrecord_implementation *implementation
2276 = LHEADER_IMPLEMENTATION (lheader);
2278 /* There should be no other pointers to the free list. */
2279 assert (!MARKED_RECORD_HEADER_P (lheader));
2280 /* Only lcrecords should be here. */
2281 assert (!implementation->basic_p);
2282 /* Only free lcrecords should be here. */
2283 assert (free_header->lcheader.free);
2284 /* The type of the lcrecord must be right. */
2285 assert (implementation == list->implementation);
2286 /* So must the size. */
2287 assert (implementation->static_size == 0
2288 || implementation->static_size == list->size);
2289 #endif /* ERROR_CHECK_GC */
2290 list->free = free_header->chain;
2291 free_header->lcheader.free = 0;
2298 XSETOBJ (val, Lisp_Type_Record,
2299 alloc_lcrecord (list->size, list->implementation));
2305 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2307 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2308 struct free_lcrecord_header *free_header =
2309 (struct free_lcrecord_header *) XPNTR (lcrecord);
2310 struct lrecord_header *lheader =
2311 (struct lrecord_header *) free_header;
2312 CONST struct lrecord_implementation *implementation
2313 = LHEADER_IMPLEMENTATION (lheader);
2315 #ifdef ERROR_CHECK_GC
2316 /* Make sure the size is correct. This will catch, for example,
2317 putting a window configuration on the wrong free list. */
2318 if (implementation->size_in_bytes_method)
2319 assert (implementation->size_in_bytes_method (lheader) == list->size);
2321 assert (implementation->static_size == list->size);
2322 #endif /* ERROR_CHECK_GC */
2324 if (implementation->finalizer)
2325 implementation->finalizer (lheader, 0);
2326 free_header->chain = list->free;
2327 free_header->lcheader.free = 1;
2328 list->free = lcrecord;
2334 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2335 Kept for compatibility, returns its argument.
2337 Make a copy of OBJECT in pure storage.
2338 Recursively copies contents of vectors and cons cells.
2339 Does not copy symbols.
2348 /************************************************************************/
2349 /* Garbage Collection */
2350 /************************************************************************/
2352 /* This will be used more extensively In The Future */
2353 static int last_lrecord_type_index_assigned;
2355 CONST struct lrecord_implementation *lrecord_implementations_table[128];
2356 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
2358 struct gcpro *gcprolist;
2360 /* 415 used Mly 29-Jun-93 */
2361 /* 1327 used slb 28-Feb-98 */
2363 #define NSTATICS 4000
2365 #define NSTATICS 2000
2367 /* Not "static" because of linker lossage on some systems */
2368 Lisp_Object *staticvec[NSTATICS]
2369 /* Force it into data space! */
2371 static int staticidx;
2373 /* Put an entry in staticvec, pointing at the variable whose address is given
2376 staticpro (Lisp_Object *varaddress)
2378 if (staticidx >= countof (staticvec))
2379 /* #### This is now a dubious abort() since this routine may be called */
2380 /* by Lisp attempting to load a DLL. */
2382 staticvec[staticidx++] = varaddress;
2386 /* Mark reference to a Lisp_Object. If the object referred to has not been
2387 seen yet, recursively mark all the references contained in it. */
2390 mark_object (Lisp_Object obj)
2394 #ifdef ERROR_CHECK_GC
2395 assert (! (GC_EQ (obj, Qnull_pointer)));
2397 /* Checks we used to perform */
2398 /* if (EQ (obj, Qnull_pointer)) return; */
2399 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2400 /* if (PURIFIED (XPNTR (obj))) return; */
2402 if (XGCTYPE (obj) == Lisp_Type_Record)
2404 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2405 #if defined (ERROR_CHECK_GC)
2406 assert (lheader->type <= last_lrecord_type_index_assigned);
2408 if (C_READONLY_RECORD_HEADER_P (lheader))
2411 if (! MARKED_RECORD_HEADER_P (lheader) &&
2412 ! UNMARKABLE_RECORD_HEADER_P (lheader))
2414 CONST struct lrecord_implementation *implementation =
2415 LHEADER_IMPLEMENTATION (lheader);
2416 MARK_RECORD_HEADER (lheader);
2417 #ifdef ERROR_CHECK_GC
2418 if (!implementation->basic_p)
2419 assert (! ((struct lcrecord_header *) lheader)->free);
2421 if (implementation->marker)
2423 obj = implementation->marker (obj, mark_object);
2424 if (!GC_NILP (obj)) goto tail_recurse;
2430 /* mark all of the conses in a list and mark the final cdr; but
2431 DO NOT mark the cars.
2433 Use only for internal lists! There should never be other pointers
2434 to the cons cells, because if so, the cars will remain unmarked
2435 even when they maybe should be marked. */
2437 mark_conses_in_list (Lisp_Object obj)
2441 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2443 if (CONS_MARKED_P (XCONS (rest)))
2445 MARK_CONS (XCONS (rest));
2452 /* Find all structures not marked, and free them. */
2454 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2455 static int gc_count_bit_vector_storage;
2456 static int gc_count_num_short_string_in_use;
2457 static int gc_count_string_total_size;
2458 static int gc_count_short_string_total_size;
2460 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2464 lrecord_type_index (CONST struct lrecord_implementation *implementation)
2466 int type_index = *(implementation->lrecord_type_index);
2467 /* Have to do this circuitous validation test because of problems
2468 dumping out initialized variables (ie can't set xxx_type_index to -1
2469 because that would make xxx_type_index read-only in a dumped emacs. */
2470 if (type_index < 0 || type_index > max_lrecord_type
2471 || lrecord_implementations_table[type_index] != implementation)
2473 assert (last_lrecord_type_index_assigned < max_lrecord_type);
2474 type_index = ++last_lrecord_type_index_assigned;
2475 lrecord_implementations_table[type_index] = implementation;
2476 *(implementation->lrecord_type_index) = type_index;
2481 /* stats on lcrecords in use - kinda kludgy */
2485 int instances_in_use;
2487 int instances_freed;
2489 int instances_on_free_list;
2490 } lcrecord_stats [countof (lrecord_implementations_table)];
2493 tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p)
2495 CONST struct lrecord_implementation *implementation =
2496 LHEADER_IMPLEMENTATION (h);
2497 int type_index = lrecord_type_index (implementation);
2499 if (((struct lcrecord_header *) h)->free)
2502 lcrecord_stats[type_index].instances_on_free_list++;
2506 size_t sz = (implementation->size_in_bytes_method
2507 ? implementation->size_in_bytes_method (h)
2508 : implementation->static_size);
2512 lcrecord_stats[type_index].instances_freed++;
2513 lcrecord_stats[type_index].bytes_freed += sz;
2517 lcrecord_stats[type_index].instances_in_use++;
2518 lcrecord_stats[type_index].bytes_in_use += sz;
2524 /* Free all unmarked records */
2526 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2528 struct lcrecord_header *header;
2530 /* int total_size = 0; */
2532 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2534 /* First go through and call all the finalize methods.
2535 Then go through and free the objects. There used to
2536 be only one loop here, with the call to the finalizer
2537 occurring directly before the xfree() below. That
2538 is marginally faster but much less safe -- if the
2539 finalize method for an object needs to reference any
2540 other objects contained within it (and many do),
2541 we could easily be screwed by having already freed that
2544 for (header = *prev; header; header = header->next)
2546 struct lrecord_header *h = &(header->lheader);
2547 if (!C_READONLY_RECORD_HEADER_P(h)
2548 && !MARKED_RECORD_HEADER_P (h)
2549 && ! (header->free))
2551 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2552 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2556 for (header = *prev; header; )
2558 struct lrecord_header *h = &(header->lheader);
2559 if (C_READONLY_RECORD_HEADER_P(h) || MARKED_RECORD_HEADER_P (h))
2561 if (MARKED_RECORD_HEADER_P (h))
2562 UNMARK_RECORD_HEADER (h);
2564 /* total_size += n->implementation->size_in_bytes (h);*/
2565 /* ### May modify header->next on a C_READONLY lcrecord */
2566 prev = &(header->next);
2568 tick_lcrecord_stats (h, 0);
2572 struct lcrecord_header *next = header->next;
2574 tick_lcrecord_stats (h, 1);
2575 /* used to call finalizer right here. */
2581 /* *total = total_size; */
2586 sweep_bit_vectors_1 (Lisp_Object *prev,
2587 int *used, int *total, int *storage)
2589 Lisp_Object bit_vector;
2592 int total_storage = 0;
2594 /* BIT_VECTORP fails because the objects are marked, which changes
2595 their implementation */
2596 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2598 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2600 if (C_READONLY_RECORD_HEADER_P(&(v->lheader)) || MARKED_RECORD_P (bit_vector))
2602 if (MARKED_RECORD_P (bit_vector))
2603 UNMARK_RECORD_HEADER (&(v->lheader));
2607 STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2608 BIT_VECTOR_LONG_STORAGE (len));
2610 /* ### May modify next on a C_READONLY bitvector */
2611 prev = &(bit_vector_next (v));
2616 Lisp_Object next = bit_vector_next (v);
2623 *total = total_size;
2624 *storage = total_storage;
2627 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2628 to make macros prettier. */
2630 #ifdef ERROR_CHECK_GC
2632 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2634 struct typename##_block *SFTB_current; \
2635 struct typename##_block **SFTB_prev; \
2637 int num_free = 0, num_used = 0; \
2639 for (SFTB_prev = ¤t_##typename##_block, \
2640 SFTB_current = current_##typename##_block, \
2641 SFTB_limit = current_##typename##_block_index; \
2647 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2649 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2651 if (FREE_STRUCT_P (SFTB_victim)) \
2655 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2659 else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2662 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2667 UNMARK_##typename (SFTB_victim); \
2670 SFTB_prev = &(SFTB_current->prev); \
2671 SFTB_current = SFTB_current->prev; \
2672 SFTB_limit = countof (current_##typename##_block->block); \
2675 gc_count_num_##typename##_in_use = num_used; \
2676 gc_count_num_##typename##_freelist = num_free; \
2679 #else /* !ERROR_CHECK_GC */
2681 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2683 struct typename##_block *SFTB_current; \
2684 struct typename##_block **SFTB_prev; \
2686 int num_free = 0, num_used = 0; \
2688 typename##_free_list = 0; \
2690 for (SFTB_prev = ¤t_##typename##_block, \
2691 SFTB_current = current_##typename##_block, \
2692 SFTB_limit = current_##typename##_block_index; \
2697 int SFTB_empty = 1; \
2698 obj_type *SFTB_old_free_list = typename##_free_list; \
2700 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2702 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2704 if (FREE_STRUCT_P (SFTB_victim)) \
2707 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2709 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2714 else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2717 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2723 UNMARK_##typename (SFTB_victim); \
2728 SFTB_prev = &(SFTB_current->prev); \
2729 SFTB_current = SFTB_current->prev; \
2731 else if (SFTB_current == current_##typename##_block \
2732 && !SFTB_current->prev) \
2734 /* No real point in freeing sole allocation block */ \
2739 struct typename##_block *SFTB_victim_block = SFTB_current; \
2740 if (SFTB_victim_block == current_##typename##_block) \
2741 current_##typename##_block_index \
2742 = countof (current_##typename##_block->block); \
2743 SFTB_current = SFTB_current->prev; \
2745 *SFTB_prev = SFTB_current; \
2746 xfree (SFTB_victim_block); \
2747 /* Restore free list to what it was before victim was swept */ \
2748 typename##_free_list = SFTB_old_free_list; \
2749 num_free -= SFTB_limit; \
2752 SFTB_limit = countof (current_##typename##_block->block); \
2755 gc_count_num_##typename##_in_use = num_used; \
2756 gc_count_num_##typename##_freelist = num_free; \
2759 #endif /* !ERROR_CHECK_GC */
2767 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2768 #define ADDITIONAL_FREE_cons(ptr)
2770 SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons);
2773 /* Explicitly free a cons cell. */
2775 free_cons (struct Lisp_Cons *ptr)
2777 #ifdef ERROR_CHECK_GC
2778 /* If the CAR is not an int, then it will be a pointer, which will
2779 always be four-byte aligned. If this cons cell has already been
2780 placed on the free list, however, its car will probably contain
2781 a chain pointer to the next cons on the list, which has cleverly
2782 had all its 0's and 1's inverted. This allows for a quick
2783 check to make sure we're not freeing something already freed. */
2784 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2785 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2786 #endif /* ERROR_CHECK_GC */
2788 #ifndef ALLOC_NO_POOLS
2789 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, struct Lisp_Cons, ptr);
2790 #endif /* ALLOC_NO_POOLS */
2793 /* explicitly free a list. You **must make sure** that you have
2794 created all the cons cells that make up this list and that there
2795 are no pointers to any of these cons cells anywhere else. If there
2796 are, you will lose. */
2799 free_list (Lisp_Object list)
2801 Lisp_Object rest, next;
2803 for (rest = list; !NILP (rest); rest = next)
2806 free_cons (XCONS (rest));
2810 /* explicitly free an alist. You **must make sure** that you have
2811 created all the cons cells that make up this alist and that there
2812 are no pointers to any of these cons cells anywhere else. If there
2813 are, you will lose. */
2816 free_alist (Lisp_Object alist)
2818 Lisp_Object rest, next;
2820 for (rest = alist; !NILP (rest); rest = next)
2823 free_cons (XCONS (XCAR (rest)));
2824 free_cons (XCONS (rest));
2829 sweep_compiled_functions (void)
2831 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2832 #define ADDITIONAL_FREE_compiled_function(ptr)
2834 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2838 #ifdef LISP_FLOAT_TYPE
2842 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2843 #define ADDITIONAL_FREE_float(ptr)
2845 SWEEP_FIXED_TYPE_BLOCK (float, struct Lisp_Float);
2847 #endif /* LISP_FLOAT_TYPE */
2850 sweep_symbols (void)
2852 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2853 #define ADDITIONAL_FREE_symbol(ptr)
2855 SWEEP_FIXED_TYPE_BLOCK (symbol, struct Lisp_Symbol);
2859 sweep_extents (void)
2861 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2862 #define ADDITIONAL_FREE_extent(ptr)
2864 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2870 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2871 #define ADDITIONAL_FREE_event(ptr)
2873 SWEEP_FIXED_TYPE_BLOCK (event, struct Lisp_Event);
2877 sweep_markers (void)
2879 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2880 #define ADDITIONAL_FREE_marker(ptr) \
2881 do { Lisp_Object tem; \
2882 XSETMARKER (tem, ptr); \
2883 unchain_marker (tem); \
2886 SWEEP_FIXED_TYPE_BLOCK (marker, struct Lisp_Marker);
2889 /* Explicitly free a marker. */
2891 free_marker (struct Lisp_Marker *ptr)
2893 #ifdef ERROR_CHECK_GC
2894 /* Perhaps this will catch freeing an already-freed marker. */
2896 XSETMARKER (temmy, ptr);
2897 assert (GC_MARKERP (temmy));
2898 #endif /* ERROR_CHECK_GC */
2900 #ifndef ALLOC_NO_POOLS
2901 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr);
2902 #endif /* ALLOC_NO_POOLS */
2906 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2909 verify_string_chars_integrity (void)
2911 struct string_chars_block *sb;
2913 /* Scan each existing string block sequentially, string by string. */
2914 for (sb = first_string_chars_block; sb; sb = sb->next)
2917 /* POS is the index of the next string in the block. */
2918 while (pos < sb->pos)
2920 struct string_chars *s_chars =
2921 (struct string_chars *) &(sb->string_chars[pos]);
2922 struct Lisp_String *string;
2926 /* If the string_chars struct is marked as free (i.e. the STRING
2927 pointer is 0xFFFFFFFF) then this is an unused chunk of string
2928 storage. (See below.) */
2930 if (FREE_STRUCT_P (s_chars))
2932 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
2937 string = s_chars->string;
2938 /* Must be 32-bit aligned. */
2939 assert ((((int) string) & 3) == 0);
2941 size = string_length (string);
2942 fullsize = STRING_FULLSIZE (size);
2944 assert (!BIG_STRING_FULLSIZE_P (fullsize));
2945 assert (string_data (string) == s_chars->chars);
2948 assert (pos == sb->pos);
2952 #endif /* MULE && ERROR_CHECK_GC */
2954 /* Compactify string chars, relocating the reference to each --
2955 free any empty string_chars_block we see. */
2957 compact_string_chars (void)
2959 struct string_chars_block *to_sb = first_string_chars_block;
2961 struct string_chars_block *from_sb;
2963 /* Scan each existing string block sequentially, string by string. */
2964 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
2967 /* FROM_POS is the index of the next string in the block. */
2968 while (from_pos < from_sb->pos)
2970 struct string_chars *from_s_chars =
2971 (struct string_chars *) &(from_sb->string_chars[from_pos]);
2972 struct string_chars *to_s_chars;
2973 struct Lisp_String *string;
2977 /* If the string_chars struct is marked as free (i.e. the STRING
2978 pointer is 0xFFFFFFFF) then this is an unused chunk of string
2979 storage. This happens under Mule when a string's size changes
2980 in such a way that its fullsize changes. (Strings can change
2981 size because a different-length character can be substituted
2982 for another character.) In this case, after the bogus string
2983 pointer is the "fullsize" of this entry, i.e. how many bytes
2986 if (FREE_STRUCT_P (from_s_chars))
2988 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
2989 from_pos += fullsize;
2993 string = from_s_chars->string;
2994 assert (!(FREE_STRUCT_P (string)));
2996 size = string_length (string);
2997 fullsize = STRING_FULLSIZE (size);
2999 if (BIG_STRING_FULLSIZE_P (fullsize))
3002 /* Just skip it if it isn't marked. */
3003 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3005 from_pos += fullsize;
3009 /* If it won't fit in what's left of TO_SB, close TO_SB out
3010 and go on to the next string_chars_block. We know that TO_SB
3011 cannot advance past FROM_SB here since FROM_SB is large enough
3012 to currently contain this string. */
3013 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3015 to_sb->pos = to_pos;
3016 to_sb = to_sb->next;
3020 /* Compute new address of this string
3021 and update TO_POS for the space being used. */
3022 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3024 /* Copy the string_chars to the new place. */
3025 if (from_s_chars != to_s_chars)
3026 memmove (to_s_chars, from_s_chars, fullsize);
3028 /* Relocate FROM_S_CHARS's reference */
3029 set_string_data (string, &(to_s_chars->chars[0]));
3031 from_pos += fullsize;
3036 /* Set current to the last string chars block still used and
3037 free any that follow. */
3039 struct string_chars_block *victim;
3041 for (victim = to_sb->next; victim; )
3043 struct string_chars_block *next = victim->next;
3048 current_string_chars_block = to_sb;
3049 current_string_chars_block->pos = to_pos;
3050 current_string_chars_block->next = 0;
3054 #if 1 /* Hack to debug missing purecopy's */
3055 static int debug_string_purity;
3058 debug_string_purity_print (struct Lisp_String *p)
3061 Charcount s = string_char_length (p);
3062 putc ('\"', stderr);
3063 for (i = 0; i < s; i++)
3065 Emchar ch = string_char (p, i);
3066 if (ch < 32 || ch >= 126)
3067 stderr_out ("\\%03o", ch);
3068 else if (ch == '\\' || ch == '\"')
3069 stderr_out ("\\%c", ch);
3071 stderr_out ("%c", ch);
3073 stderr_out ("\"\n");
3079 sweep_strings (void)
3081 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3082 int debug = debug_string_purity;
3084 #define UNMARK_string(ptr) \
3085 do { struct Lisp_String *p = (ptr); \
3086 int size = string_length (p); \
3087 UNMARK_RECORD_HEADER (&(p->lheader)); \
3088 num_bytes += size; \
3089 if (!BIG_STRING_SIZE_P (size)) \
3090 { num_small_bytes += size; \
3093 if (debug) debug_string_purity_print (p); \
3095 #define ADDITIONAL_FREE_string(p) \
3096 do { int size = string_length (p); \
3097 if (BIG_STRING_SIZE_P (size)) \
3098 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
3101 SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String);
3103 gc_count_num_short_string_in_use = num_small_used;
3104 gc_count_string_total_size = num_bytes;
3105 gc_count_short_string_total_size = num_small_bytes;
3109 /* I hate duplicating all this crap! */
3111 marked_p (Lisp_Object obj)
3113 #ifdef ERROR_CHECK_GC
3114 assert (! (GC_EQ (obj, Qnull_pointer)));
3116 /* Checks we used to perform. */
3117 /* if (EQ (obj, Qnull_pointer)) return 1; */
3118 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3119 /* if (PURIFIED (XPNTR (obj))) return 1; */
3121 if (XGCTYPE (obj) == Lisp_Type_Record)
3123 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3124 #if defined (ERROR_CHECK_GC)
3125 assert (lheader->type <= last_lrecord_type_index_assigned);
3127 return C_READONLY_RECORD_HEADER_P (lheader) || MARKED_RECORD_HEADER_P (lheader);
3135 /* Free all unmarked records. Do this at the very beginning,
3136 before anything else, so that the finalize methods can safely
3137 examine items in the objects. sweep_lcrecords_1() makes
3138 sure to call all the finalize methods *before* freeing anything,
3139 to complete the safety. */
3142 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3145 compact_string_chars ();
3147 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3148 macros) must be *extremely* careful to make sure they're not
3149 referencing freed objects. The only two existing finalize
3150 methods (for strings and markers) pass muster -- the string
3151 finalizer doesn't look at anything but its own specially-
3152 created block, and the marker finalizer only looks at live
3153 buffers (which will never be freed) and at the markers before
3154 and after it in the chain (which, by induction, will never be
3155 freed because if so, they would have already removed themselves
3158 /* Put all unmarked strings on free list, free'ing the string chars
3159 of large unmarked strings */
3162 /* Put all unmarked conses on free list */
3165 /* Free all unmarked bit vectors */
3166 sweep_bit_vectors_1 (&all_bit_vectors,
3167 &gc_count_num_bit_vector_used,
3168 &gc_count_bit_vector_total_size,
3169 &gc_count_bit_vector_storage);
3171 /* Free all unmarked compiled-function objects */
3172 sweep_compiled_functions ();
3174 #ifdef LISP_FLOAT_TYPE
3175 /* Put all unmarked floats on free list */
3179 /* Put all unmarked symbols on free list */
3182 /* Put all unmarked extents on free list */
3185 /* Put all unmarked markers on free list.
3186 Dechain each one first from the buffer into which it points. */
3193 /* Clearing for disksave. */
3196 disksave_object_finalization (void)
3198 /* It's important that certain information from the environment not get
3199 dumped with the executable (pathnames, environment variables, etc.).
3200 To make it easier to tell when this has happened with strings(1) we
3201 clear some known-to-be-garbage blocks of memory, so that leftover
3202 results of old evaluation don't look like potential problems.
3203 But first we set some notable variables to nil and do one more GC,
3204 to turn those strings into garbage.
3207 /* Yeah, this list is pretty ad-hoc... */
3208 Vprocess_environment = Qnil;
3209 Vexec_directory = Qnil;
3210 Vdata_directory = Qnil;
3211 Vsite_directory = Qnil;
3212 Vdoc_directory = Qnil;
3213 Vconfigure_info_directory = Qnil;
3216 /* Vdump_load_path = Qnil; */
3217 /* Release hash tables for locate_file */
3218 Flocate_file_clear_hashing (Qt);
3219 uncache_home_directory();
3221 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3222 defined(LOADHIST_BUILTIN))
3223 Vload_history = Qnil;
3225 Vshell_file_name = Qnil;
3227 garbage_collect_1 ();
3229 /* Run the disksave finalization methods of all live objects. */
3230 disksave_object_finalization_1 ();
3232 /* Zero out the uninitialized (really, unused) part of the containers
3233 for the live strings. */
3235 struct string_chars_block *scb;
3236 for (scb = first_string_chars_block; scb; scb = scb->next)
3238 int count = sizeof (scb->string_chars) - scb->pos;
3240 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3242 /* from the block's fill ptr to the end */
3243 memset ((scb->string_chars + scb->pos), 0, count);
3248 /* There, that ought to be enough... */
3254 restore_gc_inhibit (Lisp_Object val)
3256 gc_currently_forbidden = XINT (val);
3260 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3261 static int gc_hooks_inhibited;
3265 garbage_collect_1 (void)
3267 #if MAX_SAVE_STACK > 0
3268 char stack_top_variable;
3269 extern char *stack_bottom;
3274 Lisp_Object pre_gc_cursor;
3275 struct gcpro gcpro1;
3278 || gc_currently_forbidden
3280 || preparing_for_armageddon)
3283 /* We used to call selected_frame() here.
3285 The following functions cannot be called inside GC
3286 so we move to after the above tests. */
3289 Lisp_Object device = Fselected_device (Qnil);
3290 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3292 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3294 signal_simple_error ("No frames exist on device", device);
3298 pre_gc_cursor = Qnil;
3301 GCPRO1 (pre_gc_cursor);
3303 /* Very important to prevent GC during any of the following
3304 stuff that might run Lisp code; otherwise, we'll likely
3305 have infinite GC recursion. */
3306 speccount = specpdl_depth ();
3307 record_unwind_protect (restore_gc_inhibit,
3308 make_int (gc_currently_forbidden));
3309 gc_currently_forbidden = 1;
3311 if (!gc_hooks_inhibited)
3312 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3314 /* Now show the GC cursor/message. */
3315 if (!noninteractive)
3317 if (FRAME_WIN_P (f))
3319 Lisp_Object frame = make_frame (f);
3320 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3321 FRAME_SELECTED_WINDOW (f),
3323 pre_gc_cursor = f->pointer;
3324 if (POINTER_IMAGE_INSTANCEP (cursor)
3325 /* don't change if we don't know how to change back. */
3326 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3329 Fset_frame_pointer (frame, cursor);
3333 /* Don't print messages to the stream device. */
3334 if (!cursor_changed && !FRAME_STREAM_P (f))
3336 char *msg = (STRINGP (Vgc_message)
3337 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3339 Lisp_Object args[2], whole_msg;
3340 args[0] = build_string (msg ? msg :
3341 GETTEXT ((CONST char *) gc_default_message));
3342 args[1] = build_string ("...");
3343 whole_msg = Fconcat (2, args);
3344 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3345 Qgarbage_collecting);
3349 /***** Now we actually start the garbage collection. */
3353 gc_generation_number[0]++;
3355 #if MAX_SAVE_STACK > 0
3357 /* Save a copy of the contents of the stack, for debugging. */
3360 /* Static buffer in which we save a copy of the C stack at each GC. */
3361 static char *stack_copy;
3362 static size_t stack_copy_size;
3364 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3365 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3366 if (stack_size < MAX_SAVE_STACK)
3368 if (stack_copy_size < stack_size)
3370 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3371 stack_copy_size = stack_size;
3375 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3379 #endif /* MAX_SAVE_STACK > 0 */
3381 /* Do some totally ad-hoc resource clearing. */
3382 /* #### generalize this? */
3383 clear_event_resource ();
3384 cleanup_specifiers ();
3386 /* Mark all the special slots that serve as the roots of accessibility. */
3390 for (i = 0; i < staticidx; i++)
3391 mark_object (*(staticvec[i]));
3397 for (tail = gcprolist; tail; tail = tail->next)
3398 for (i = 0; i < tail->nvars; i++)
3399 mark_object (tail->var[i]);
3403 struct specbinding *bind;
3404 for (bind = specpdl; bind != specpdl_ptr; bind++)
3406 mark_object (bind->symbol);
3407 mark_object (bind->old_value);
3412 struct catchtag *catch;
3413 for (catch = catchlist; catch; catch = catch->next)
3415 mark_object (catch->tag);
3416 mark_object (catch->val);
3421 struct backtrace *backlist;
3422 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3424 int nargs = backlist->nargs;
3427 mark_object (*backlist->function);
3428 if (nargs == UNEVALLED || nargs == MANY)
3429 mark_object (backlist->args[0]);
3431 for (i = 0; i < nargs; i++)
3432 mark_object (backlist->args[i]);
3436 mark_redisplay (mark_object);
3437 mark_profiling_info (mark_object);
3439 /* OK, now do the after-mark stuff. This is for things that
3440 are only marked when something else is marked (e.g. weak hash tables).
3441 There may be complex dependencies between such objects -- e.g.
3442 a weak hash table might be unmarked, but after processing a later
3443 weak hash table, the former one might get marked. So we have to
3444 iterate until nothing more gets marked. */
3446 while (finish_marking_weak_hash_tables (marked_p, mark_object) > 0 ||
3447 finish_marking_weak_lists (marked_p, mark_object) > 0)
3450 /* And prune (this needs to be called after everything else has been
3451 marked and before we do any sweeping). */
3452 /* #### this is somewhat ad-hoc and should probably be an object
3454 prune_weak_hash_tables (marked_p);
3455 prune_weak_lists (marked_p);
3456 prune_specifiers (marked_p);
3457 prune_syntax_tables (marked_p);
3461 consing_since_gc = 0;
3462 #ifndef DEBUG_XEMACS
3463 /* Allow you to set it really fucking low if you really want ... */
3464 if (gc_cons_threshold < 10000)
3465 gc_cons_threshold = 10000;
3470 /******* End of garbage collection ********/
3472 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3474 /* Now remove the GC cursor/message */
3475 if (!noninteractive)
3478 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3479 else if (!FRAME_STREAM_P (f))
3481 char *msg = (STRINGP (Vgc_message)
3482 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3485 /* Show "...done" only if the echo area would otherwise be empty. */
3486 if (NILP (clear_echo_area (selected_frame (),
3487 Qgarbage_collecting, 0)))
3489 Lisp_Object args[2], whole_msg;
3490 args[0] = build_string (msg ? msg :
3491 GETTEXT ((CONST char *)
3492 gc_default_message));
3493 args[1] = build_string ("... done");
3494 whole_msg = Fconcat (2, args);
3495 echo_area_message (selected_frame (), (Bufbyte *) 0,
3497 Qgarbage_collecting);
3502 /* now stop inhibiting GC */
3503 unbind_to (speccount, Qnil);
3505 if (!breathing_space)
3507 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3514 /* Debugging aids. */
3517 gc_plist_hack (CONST char *name, int value, Lisp_Object tail)
3519 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3520 or portable numeric datatypes, or bit-vectors, or characters, or
3521 arrays, or exceptions, or ...) */
3522 return cons3 (intern (name), make_int (value), tail);
3525 #define HACK_O_MATIC(type, name, pl) do { \
3527 struct type##_block *x = current_##type##_block; \
3528 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3529 (pl) = gc_plist_hack ((name), s, (pl)); \
3532 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3533 Reclaim storage for Lisp objects no longer needed.
3534 Return info on amount of space in use:
3535 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3536 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3538 where `PLIST' is a list of alternating keyword/value pairs providing
3539 more detailed information.
3540 Garbage collection happens automatically if you cons more than
3541 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3545 Lisp_Object pl = Qnil;
3547 int gc_count_vector_total_size = 0;
3549 garbage_collect_1 ();
3551 for (i = 0; i < last_lrecord_type_index_assigned; i++)
3553 if (lcrecord_stats[i].bytes_in_use != 0
3554 || lcrecord_stats[i].bytes_freed != 0
3555 || lcrecord_stats[i].instances_on_free_list != 0)
3558 CONST char *name = lrecord_implementations_table[i]->name;
3559 int len = strlen (name);
3560 /* save this for the FSFmacs-compatible part of the summary */
3561 if (i == *lrecord_vector.lrecord_type_index)
3562 gc_count_vector_total_size =
3563 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3565 sprintf (buf, "%s-storage", name);
3566 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3567 /* Okay, simple pluralization check for `symbol-value-varalias' */
3568 if (name[len-1] == 's')
3569 sprintf (buf, "%ses-freed", name);
3571 sprintf (buf, "%ss-freed", name);
3572 if (lcrecord_stats[i].instances_freed != 0)
3573 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3574 if (name[len-1] == 's')
3575 sprintf (buf, "%ses-on-free-list", name);
3577 sprintf (buf, "%ss-on-free-list", name);
3578 if (lcrecord_stats[i].instances_on_free_list != 0)
3579 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3581 if (name[len-1] == 's')
3582 sprintf (buf, "%ses-used", name);
3584 sprintf (buf, "%ss-used", name);
3585 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3589 HACK_O_MATIC (extent, "extent-storage", pl);
3590 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3591 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3592 HACK_O_MATIC (event, "event-storage", pl);
3593 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3594 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3595 HACK_O_MATIC (marker, "marker-storage", pl);
3596 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3597 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3598 #ifdef LISP_FLOAT_TYPE
3599 HACK_O_MATIC (float, "float-storage", pl);
3600 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3601 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3602 #endif /* LISP_FLOAT_TYPE */
3603 HACK_O_MATIC (string, "string-header-storage", pl);
3604 pl = gc_plist_hack ("long-strings-total-length",
3605 gc_count_string_total_size
3606 - gc_count_short_string_total_size, pl);
3607 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3608 pl = gc_plist_hack ("short-strings-total-length",
3609 gc_count_short_string_total_size, pl);
3610 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3611 pl = gc_plist_hack ("long-strings-used",
3612 gc_count_num_string_in_use
3613 - gc_count_num_short_string_in_use, pl);
3614 pl = gc_plist_hack ("short-strings-used",
3615 gc_count_num_short_string_in_use, pl);
3617 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3618 pl = gc_plist_hack ("compiled-functions-free",
3619 gc_count_num_compiled_function_freelist, pl);
3620 pl = gc_plist_hack ("compiled-functions-used",
3621 gc_count_num_compiled_function_in_use, pl);
3623 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3624 pl = gc_plist_hack ("bit-vectors-total-length",
3625 gc_count_bit_vector_total_size, pl);
3626 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3628 HACK_O_MATIC (symbol, "symbol-storage", pl);
3629 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3630 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3632 HACK_O_MATIC (cons, "cons-storage", pl);
3633 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3634 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3636 /* The things we do for backwards-compatibility */
3638 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3639 make_int (gc_count_num_cons_freelist)),
3640 Fcons (make_int (gc_count_num_symbol_in_use),
3641 make_int (gc_count_num_symbol_freelist)),
3642 Fcons (make_int (gc_count_num_marker_in_use),
3643 make_int (gc_count_num_marker_freelist)),
3644 make_int (gc_count_string_total_size),
3645 make_int (gc_count_vector_total_size),
3650 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3651 Return the number of bytes consed since the last garbage collection.
3652 \"Consed\" is a misnomer in that this actually counts allocation
3653 of all different kinds of objects, not just conses.
3655 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3659 return make_int (consing_since_gc);
3662 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
3663 Return the address of the last byte Emacs has allocated, divided by 1024.
3664 This may be helpful in debugging Emacs's memory usage.
3665 The value is divided by 1024 to make sure it will fit in a lisp integer.
3669 return make_int ((EMACS_INT) sbrk (0) / 1024);
3675 object_dead_p (Lisp_Object obj)
3677 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3678 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3679 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3680 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3681 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3682 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3683 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3686 #ifdef MEMORY_USAGE_STATS
3688 /* Attempt to determine the actual amount of space that is used for
3689 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3691 It seems that the following holds:
3693 1. When using the old allocator (malloc.c):
3695 -- blocks are always allocated in chunks of powers of two. For
3696 each block, there is an overhead of 8 bytes if rcheck is not
3697 defined, 20 bytes if it is defined. In other words, a
3698 one-byte allocation needs 8 bytes of overhead for a total of
3699 9 bytes, and needs to have 16 bytes of memory chunked out for
3702 2. When using the new allocator (gmalloc.c):
3704 -- blocks are always allocated in chunks of powers of two up
3705 to 4096 bytes. Larger blocks are allocated in chunks of
3706 an integral multiple of 4096 bytes. The minimum block
3707 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3708 is defined. There is no per-block overhead, but there
3709 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3712 3. When using the system malloc, anything goes, but they are
3713 generally slower and more space-efficient than the GNU
3714 allocators. One possibly reasonable assumption to make
3715 for want of better data is that sizeof (void *), or maybe
3716 2 * sizeof (void *), is required as overhead and that
3717 blocks are allocated in the minimum required size except
3718 that some minimum block size is imposed (e.g. 16 bytes). */
3721 malloced_storage_size (void *ptr, size_t claimed_size,
3722 struct overhead_stats *stats)
3724 size_t orig_claimed_size = claimed_size;
3728 if (claimed_size < 2 * sizeof (void *))
3729 claimed_size = 2 * sizeof (void *);
3730 # ifdef SUNOS_LOCALTIME_BUG
3731 if (claimed_size < 16)
3734 if (claimed_size < 4096)
3738 /* compute the log base two, more or less, then use it to compute
3739 the block size needed. */
3741 /* It's big, it's heavy, it's wood! */
3742 while ((claimed_size /= 2) != 0)
3745 /* It's better than bad, it's good! */
3751 /* We have to come up with some average about the amount of
3753 if ((size_t) (rand () & 4095) < claimed_size)
3754 claimed_size += 3 * sizeof (void *);
3758 claimed_size += 4095;
3759 claimed_size &= ~4095;
3760 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3763 #elif defined (SYSTEM_MALLOC)
3765 if (claimed_size < 16)
3767 claimed_size += 2 * sizeof (void *);
3769 #else /* old GNU allocator */
3771 # ifdef rcheck /* #### may not be defined here */
3779 /* compute the log base two, more or less, then use it to compute
3780 the block size needed. */
3782 /* It's big, it's heavy, it's wood! */
3783 while ((claimed_size /= 2) != 0)
3786 /* It's better than bad, it's good! */
3794 #endif /* old GNU allocator */
3798 stats->was_requested += orig_claimed_size;
3799 stats->malloc_overhead += claimed_size - orig_claimed_size;
3801 return claimed_size;
3805 fixed_type_block_overhead (size_t size)
3807 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3808 size_t overhead = 0;
3809 size_t storage_size = malloced_storage_size (0, per_block, 0);
3810 while (size >= per_block)
3813 overhead += sizeof (void *) + per_block - storage_size;
3815 if (rand () % per_block < size)
3816 overhead += sizeof (void *) + per_block - storage_size;
3820 #endif /* MEMORY_USAGE_STATS */
3823 /* Initialization */
3825 init_alloc_once_early (void)
3829 last_lrecord_type_index_assigned = -1;
3830 for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
3832 lrecord_implementations_table[iii] = 0;
3837 * defined subr lrecords were initialized with lheader->type == 0.
3838 * See subr_lheader_initializer in lisp.h. Force type index 0 to be
3839 * assigned to lrecord_subr so that those predefined indexes match
3842 lrecord_type_index (&lrecord_subr);
3843 assert (*(lrecord_subr.lrecord_type_index) == 0);
3845 * The same is true for symbol_value_forward objects, except the
3848 lrecord_type_index (&lrecord_symbol_value_forward);
3849 assert (*(lrecord_symbol_value_forward.lrecord_type_index) == 1);
3851 gc_generation_number[0] = 0;
3852 /* purify_flag 1 is correct even if CANNOT_DUMP.
3853 * loadup.el will set to nil at end. */
3855 breathing_space = 0;
3856 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3857 XSETINT (Vgc_message, 0);
3859 ignore_malloc_warnings = 1;
3860 #ifdef DOUG_LEA_MALLOC
3861 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3862 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3863 #if 0 /* Moved to emacs.c */
3864 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3867 init_string_alloc ();
3868 init_string_chars_alloc ();
3870 init_symbol_alloc ();
3871 init_compiled_function_alloc ();
3872 #ifdef LISP_FLOAT_TYPE
3873 init_float_alloc ();
3874 #endif /* LISP_FLOAT_TYPE */
3875 init_marker_alloc ();
3876 init_extent_alloc ();
3877 init_event_alloc ();
3879 ignore_malloc_warnings = 0;
3881 consing_since_gc = 0;
3883 gc_cons_threshold = 500000; /* XEmacs change */
3885 gc_cons_threshold = 15000; /* debugging */
3887 #ifdef VIRT_ADDR_VARIES
3888 malloc_sbrk_unused = 1<<22; /* A large number */
3889 malloc_sbrk_used = 100000; /* as reasonable as any number */
3890 #endif /* VIRT_ADDR_VARIES */
3891 lrecord_uid_counter = 259;
3892 debug_string_purity = 0;
3895 gc_currently_forbidden = 0;
3896 gc_hooks_inhibited = 0;
3898 #ifdef ERROR_CHECK_TYPECHECK
3899 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3902 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3904 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3906 #endif /* ERROR_CHECK_TYPECHECK */
3909 int pure_bytes_used = 0;
3918 syms_of_alloc (void)
3920 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
3921 defsymbol (&Qpost_gc_hook, "post-gc-hook");
3922 defsymbol (&Qgarbage_collecting, "garbage-collecting");
3927 DEFSUBR (Fbit_vector);
3928 DEFSUBR (Fmake_byte_code);
3929 DEFSUBR (Fmake_list);
3930 DEFSUBR (Fmake_vector);
3931 DEFSUBR (Fmake_bit_vector);
3932 DEFSUBR (Fmake_string);
3934 DEFSUBR (Fmake_symbol);
3935 DEFSUBR (Fmake_marker);
3936 DEFSUBR (Fpurecopy);
3937 DEFSUBR (Fgarbage_collect);
3938 DEFSUBR (Fmemory_limit);
3939 DEFSUBR (Fconsing_since_gc);
3943 vars_of_alloc (void)
3945 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
3946 *Number of bytes of consing between garbage collections.
3947 \"Consing\" is a misnomer in that this actually counts allocation
3948 of all different kinds of objects, not just conses.
3949 Garbage collection can happen automatically once this many bytes have been
3950 allocated since the last garbage collection. All data types count.
3952 Garbage collection happens automatically when `eval' or `funcall' are
3953 called. (Note that `funcall' is called implicitly as part of evaluation.)
3954 By binding this temporarily to a large number, you can effectively
3955 prevent garbage collection during a part of the program.
3957 See also `consing-since-gc'.
3960 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
3961 Number of bytes of sharable Lisp data allocated so far.
3965 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
3966 Number of bytes of unshared memory allocated in this session.
3969 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
3970 Number of bytes of unshared memory remaining available in this session.
3975 DEFVAR_INT ("debug-allocation", &debug_allocation /*
3976 If non-zero, print out information to stderr about all objects allocated.
3977 See also `debug-allocation-backtrace-length'.
3979 debug_allocation = 0;
3981 DEFVAR_INT ("debug-allocation-backtrace-length",
3982 &debug_allocation_backtrace_length /*
3983 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
3985 debug_allocation_backtrace_length = 2;
3988 DEFVAR_BOOL ("purify-flag", &purify_flag /*
3989 Non-nil means loading Lisp code in order to dump an executable.
3990 This means that certain objects should be allocated in readonly space.
3993 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
3994 Function or functions to be run just before each garbage collection.
3995 Interrupts, garbage collection, and errors are inhibited while this hook
3996 runs, so be extremely careful in what you add here. In particular, avoid
3997 consing, and do not interact with the user.
3999 Vpre_gc_hook = Qnil;
4001 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4002 Function or functions to be run just after each garbage collection.
4003 Interrupts, garbage collection, and errors are inhibited while this hook
4004 runs, so be extremely careful in what you add here. In particular, avoid
4005 consing, and do not interact with the user.
4007 Vpost_gc_hook = Qnil;
4009 DEFVAR_LISP ("gc-message", &Vgc_message /*
4010 String to print to indicate that a garbage collection is in progress.
4011 This is printed in the echo area. If the selected frame is on a
4012 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4013 image instance) in the domain of the selected frame, the mouse pointer
4014 will change instead of this message being printed.
4016 Vgc_message = make_string_nocopy ((CONST Bufbyte *) gc_default_message,
4017 countof (gc_default_message) - 1);
4019 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4020 Pointer glyph used to indicate that a garbage collection is in progress.
4021 If the selected window is on a window system and this glyph specifies a
4022 value (i.e. a pointer image instance) in the domain of the selected
4023 window, the pointer will be changed as specified during garbage collection.
4024 Otherwise, a message will be printed in the echo area, as controlled
4030 complex_vars_of_alloc (void)
4032 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);