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.
44 #include "backtrace.h"
55 #include "redisplay.h"
56 #include "specifier.h"
62 #ifdef DOUG_LEA_MALLOC
66 EXFUN (Fgarbage_collect, 0);
68 /* #define GDB_SUCKS */
70 #if 0 /* this is _way_ too slow to be part of the standard debug options */
71 #if defined(DEBUG_XEMACS) && defined(MULE)
72 #define VERIFY_STRING_CHARS_INTEGRITY
76 /* Define this to see where all that space is going... */
77 /* But the length of the printout is obnoxious, so limit it to testers */
78 #ifdef MEMORY_USAGE_STATS
82 /* Define this to use malloc/free with no freelist for all datatypes,
83 the hope being that some debugging tools may help detect
84 freed memory references */
85 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
87 #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 defun should do purecopy on the function definition */
180 extern void sheap_adjust_h();
183 /* Force linker to put it into data space! */
184 EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = { (EMACS_INT) 0};
186 #define PUREBEG ((char *) pure)
188 #if 0 /* This is breathing_space in XEmacs */
189 /* Points to memory space allocated as "spare",
190 to be freed if we run out of memory. */
191 static char *spare_memory;
193 /* Amount of spare memory to keep in reserve. */
194 #define SPARE_MEMORY (1 << 14)
197 /* Index in pure at which next pure object will be allocated. */
198 static size_t pure_bytes_used;
200 #define PURIFIED(ptr) \
201 ((char *) (ptr) >= PUREBEG && \
202 (char *) (ptr) < PUREBEG + get_PURESIZE())
204 /* Non-zero if pure_bytes_used > get_PURESIZE();
205 accounts for excess purespace needs. */
206 static size_t pure_lossage;
208 #ifdef ERROR_CHECK_TYPECHECK
210 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
215 purified (Lisp_Object obj)
217 return POINTER_TYPE_P (XGCTYPE (obj)) && PURIFIED (XPNTR (obj));
221 purespace_usage (void)
223 return pure_bytes_used;
227 check_purespace (size_t size)
231 pure_lossage += size;
234 else if (pure_bytes_used + size > get_PURESIZE())
236 /* This can cause recursive bad behavior, we'll yell at the end */
237 /* when we're done. */
238 /* message ("\nERROR: Pure Lisp storage exhausted!\n"); */
250 #define bump_purestat(p,b) DO_NOTHING
254 static int purecopying_function_constants;
256 static size_t pure_sizeof (Lisp_Object);
258 /* Keep statistics on how much of what is in purespace */
259 static struct purestat
265 purestat_cons = {0, 0, "cons cells"},
266 purestat_float = {0, 0, "float objects"},
267 purestat_string_pname = {0, 0, "symbol-name strings"},
268 purestat_function = {0, 0, "compiled-function objects"},
269 purestat_opaque_instructions = {0, 0, "compiled-function instructions"},
270 purestat_vector_constants = {0, 0, "compiled-function constants vectors"},
271 purestat_string_interactive = {0, 0, "interactive strings"},
273 purestat_string_domain = {0, 0, "domain strings"},
275 purestat_string_documentation = {0, 0, "documentation strings"},
276 purestat_string_other_function = {0, 0, "other function strings"},
277 purestat_vector_other = {0, 0, "other vectors"},
278 purestat_string_other = {0, 0, "other strings"},
279 purestat_string_all = {0, 0, "all strings"},
280 purestat_vector_all = {0, 0, "all vectors"};
283 bump_purestat (struct purestat *purestat, size_t nbytes)
285 if (pure_lossage) return;
286 purestat->nobjects += 1;
287 purestat->nbytes += nbytes;
291 print_purestat (struct purestat *purestat)
294 sprintf(buf, "%s:", purestat->name);
295 message (" %-36s %5d %7d %2d%%",
299 (int) (purestat->nbytes / (pure_bytes_used / 100.0) + 0.5));
301 #endif /* PURESTAT */
304 /* Maximum amount of C stack to save when a GC happens. */
306 #ifndef MAX_SAVE_STACK
307 #define MAX_SAVE_STACK 0 /* 16000 */
310 /* Non-zero means ignore malloc warnings. Set during initialization. */
311 int ignore_malloc_warnings;
314 static void *breathing_space;
317 release_breathing_space (void)
321 void *tmp = breathing_space;
327 /* malloc calls this if it finds we are near exhausting storage */
329 malloc_warning (CONST char *str)
331 if (ignore_malloc_warnings)
337 "Killing some buffers may delay running out of memory.\n"
338 "However, certainly by the time you receive the 95%% warning,\n"
339 "you should clean up, kill this Emacs, and start a new one.",
343 /* Called if malloc returns zero */
347 /* Force a GC next time eval is called.
348 It's better to loop garbage-collecting (we might reclaim enough
349 to win) than to loop beeping and barfing "Memory exhausted"
351 consing_since_gc = gc_cons_threshold + 1;
352 release_breathing_space ();
354 /* Flush some histories which might conceivably contain garbalogical
356 if (!NILP (Fboundp (Qvalues)))
357 Fset (Qvalues, Qnil);
358 Vcommand_history = Qnil;
360 error ("Memory exhausted");
363 /* like malloc and realloc but check for no memory left, and block input. */
370 xmalloc (size_t size)
372 void *val = (void *) malloc (size);
374 if (!val && (size != 0)) memory_full ();
379 xcalloc (size_t nelem, size_t elsize)
381 void *val = (void *) calloc (nelem, elsize);
383 if (!val && (nelem != 0)) memory_full ();
388 xmalloc_and_zero (size_t size)
390 return xcalloc (size, sizeof (char));
398 xrealloc (void *block, size_t size)
400 /* We must call malloc explicitly when BLOCK is 0, since some
401 reallocs don't do this. */
402 void *val = (void *) (block ? realloc (block, size) : malloc (size));
404 if (!val && (size != 0)) memory_full ();
409 #ifdef ERROR_CHECK_MALLOC
410 xfree_1 (void *block)
415 #ifdef ERROR_CHECK_MALLOC
416 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
417 error until much later on for many system mallocs, such as
418 the one that comes with Solaris 2.3. FMH!! */
419 assert (block != (void *) 0xDEADBEEF);
421 #endif /* ERROR_CHECK_MALLOC */
425 #ifdef ERROR_CHECK_GC
428 typedef unsigned int four_byte_t;
429 #elif SIZEOF_LONG == 4
430 typedef unsigned long four_byte_t;
431 #elif SIZEOF_SHORT == 4
432 typedef unsigned short four_byte_t;
434 What kind of strange-ass system are we running on?
438 deadbeef_memory (void *ptr, size_t size)
440 four_byte_t *ptr4 = (four_byte_t *) ptr;
441 size_t beefs = size >> 2;
443 /* In practice, size will always be a multiple of four. */
445 (*ptr4++) = 0xDEADBEEF;
448 #else /* !ERROR_CHECK_GC */
451 #define deadbeef_memory(ptr, size)
453 #endif /* !ERROR_CHECK_GC */
460 xstrdup (CONST char *str)
462 int len = strlen (str) + 1; /* for stupid terminating 0 */
464 void *val = xmalloc (len);
465 if (val == 0) return 0;
466 memcpy (val, str, len);
472 strdup (CONST char *s)
476 #endif /* NEED_STRDUP */
480 allocate_lisp_storage (size_t size)
482 void *p = xmalloc (size);
483 #ifndef USE_MINIMAL_TAGBITS
484 char *lim = ((char *) p) + size;
487 XSETOBJ (val, Lisp_Type_Record, lim);
488 if ((char *) XPNTR (val) != lim)
493 #endif /* ! USE_MINIMAL_TAGBITS */
498 /* lrecords are chained together through their "next.v" field.
499 * After doing the mark phase, the GC will walk this linked
500 * list and free any record which hasn't been marked.
502 static struct lcrecord_header *all_lcrecords;
505 alloc_lcrecord (size_t size, CONST struct lrecord_implementation *implementation)
507 struct lcrecord_header *lcheader;
509 #ifdef ERROR_CHECK_GC
510 if (implementation->static_size == 0)
511 assert (implementation->size_in_bytes_method);
513 assert (implementation->static_size == size);
516 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
517 set_lheader_implementation (&(lcheader->lheader), implementation);
518 lcheader->next = all_lcrecords;
519 #if 1 /* mly prefers to see small ID numbers */
520 lcheader->uid = lrecord_uid_counter++;
521 #else /* jwz prefers to see real addrs */
522 lcheader->uid = (int) &lcheader;
525 all_lcrecords = lcheader;
526 INCREMENT_CONS_COUNTER (size, implementation->name);
530 #if 0 /* Presently unused */
531 /* Very, very poor man's EGC?
532 * This may be slow and thrash pages all over the place.
533 * Only call it if you really feel you must (and if the
534 * lrecord was fairly recently allocated).
535 * Otherwise, just let the GC do its job -- that's what it's there for
538 free_lcrecord (struct lcrecord_header *lcrecord)
540 if (all_lcrecords == lcrecord)
542 all_lcrecords = lcrecord->next;
546 struct lrecord_header *header = all_lcrecords;
549 struct lrecord_header *next = header->next;
550 if (next == lcrecord)
552 header->next = lrecord->next;
561 if (lrecord->implementation->finalizer)
562 lrecord->implementation->finalizer (lrecord, 0);
570 disksave_object_finalization_1 (void)
572 struct lcrecord_header *header;
574 for (header = all_lcrecords; header; header = header->next)
576 if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
578 ((LHEADER_IMPLEMENTATION(&header->lheader)->finalizer)
584 /* This must not be called -- it just serves as for EQ test
585 * If lheader->implementation->finalizer is this_marks_a_marked_record,
586 * then lrecord has been marked by the GC sweeper
587 * header->implementation is put back to its correct value by
590 this_marks_a_marked_record (void *dummy0, int dummy1)
595 /* Semi-kludge -- lrecord_symbol_value_forward objects get stuck
596 in CONST space and you get SEGV's if you attempt to mark them.
597 This sits in lheader->implementation->marker. */
600 this_one_is_unmarkable (Lisp_Object obj, void (*markobj) (Lisp_Object))
606 /* XGCTYPE for records */
608 gc_record_type_p (Lisp_Object frob, CONST struct lrecord_implementation *type)
610 CONST struct lrecord_implementation *imp;
612 if (XGCTYPE (frob) != Lisp_Type_Record)
615 imp = XRECORD_LHEADER_IMPLEMENTATION (frob);
616 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
619 return imp == type || imp == type + 1;
624 /************************************************************************/
625 /* Debugger support */
626 /************************************************************************/
627 /* Give gdb/dbx enough information to decode Lisp Objects.
628 We make sure certain symbols are defined, so gdb doesn't complain
629 about expressions in src/gdbinit. Values are randomly chosen.
630 See src/gdbinit or src/dbxrc to see how this is used. */
634 #ifdef USE_MINIMAL_TAGBITS
635 dbg_valmask = (EMACS_INT) (((1UL << VALBITS) - 1) << GCBITS),
636 dbg_typemask = (EMACS_INT) ((1UL << GCTYPEBITS) - 1),
637 dbg_USE_MINIMAL_TAGBITS = 1,
638 dbg_Lisp_Type_Int = 100,
639 #else /* ! USE_MIMIMAL_TAGBITS */
640 dbg_valmask = (EMACS_INT) ((1UL << VALBITS) - 1),
641 dbg_typemask = (EMACS_INT) (((1UL << GCTYPEBITS) - 1) << (VALBITS + GCMARKBITS)),
642 dbg_USE_MINIMAL_TAGBITS = 0,
643 dbg_Lisp_Type_Int = Lisp_Type_Int,
644 #endif /* ! USE_MIMIMAL_TAGBITS */
646 #ifdef USE_UNION_TYPE
647 dbg_USE_UNION_TYPE = 1,
649 dbg_USE_UNION_TYPE = 0,
652 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
653 dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1,
655 dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0,
658 dbg_Lisp_Type_Char = Lisp_Type_Char,
659 dbg_Lisp_Type_Record = Lisp_Type_Record,
661 dbg_Lisp_Type_Cons = 101,
663 dbg_Lisp_Type_Cons = Lisp_Type_Cons,
666 #ifdef LRECORD_STRING
667 dbg_Lisp_Type_String = 102,
669 dbg_Lisp_Type_String = Lisp_Type_String,
670 lrecord_string = 202,
672 #ifdef LRECORD_VECTOR
673 dbg_Lisp_Type_Vector = 103,
675 dbg_Lisp_Type_Vector = Lisp_Type_Vector,
676 lrecord_vector = 203,
678 #ifdef LRECORD_SYMBOL
679 dbg_Lisp_Type_Symbol = 104,
681 dbg_Lisp_Type_Symbol = Lisp_Type_Symbol,
682 lrecord_symbol = 204,
685 lrecord_char_table_entry = 205,
686 lrecord_charset = 206,
687 lrecord_coding_system = 207,
689 #ifndef HAVE_TOOLBARS
690 lrecord_toolbar_button = 208,
692 #ifndef HAVE_TOOLTALK
693 lrecord_tooltalk_message = 210,
694 lrecord_tooltalk_pattern = 211,
696 #ifndef HAVE_DATABASE
697 lrecord_database = 212,
699 dbg_valbits = VALBITS,
700 dbg_gctypebits = GCTYPEBITS
701 /* If we don't have an actual object of this enum, pgcc (and perhaps
702 other compilers) might optimize away the entire type declaration :-( */
705 /* A few macros turned into functions for ease of debugging.
706 Debuggers don't know about macros! */
707 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
709 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
711 return EQ (obj1, obj2);
715 /************************************************************************/
716 /* Fixed-size type macros */
717 /************************************************************************/
719 /* For fixed-size types that are commonly used, we malloc() large blocks
720 of memory at a time and subdivide them into chunks of the correct
721 size for an object of that type. This is more efficient than
722 malloc()ing each object separately because we save on malloc() time
723 and overhead due to the fewer number of malloc()ed blocks, and
724 also because we don't need any extra pointers within each object
725 to keep them threaded together for GC purposes. For less common
726 (and frequently large-size) types, we use lcrecords, which are
727 malloc()ed individually and chained together through a pointer
728 in the lcrecord header. lcrecords do not need to be fixed-size
729 (i.e. two objects of the same type need not have the same size;
730 however, the size of a particular object cannot vary dynamically).
731 It is also much easier to create a new lcrecord type because no
732 additional code needs to be added to alloc.c. Finally, lcrecords
733 may be more efficient when there are only a small number of them.
735 The types that are stored in these large blocks (or "frob blocks")
736 are cons, float, compiled-function, symbol, marker, extent, event,
739 Note that strings are special in that they are actually stored in
740 two parts: a structure containing information about the string, and
741 the actual data associated with the string. The former structure
742 (a struct Lisp_String) is a fixed-size structure and is managed the
743 same way as all the other such types. This structure contains a
744 pointer to the actual string data, which is stored in structures of
745 type struct string_chars_block. Each string_chars_block consists
746 of a pointer to a struct Lisp_String, followed by the data for that
747 string, followed by another pointer to a struct Lisp_String,
748 followed by the data for that string, etc. At GC time, the data in
749 these blocks is compacted by searching sequentially through all the
750 blocks and compressing out any holes created by unmarked strings.
751 Strings that are more than a certain size (bigger than the size of
752 a string_chars_block, although something like half as big might
753 make more sense) are malloc()ed separately and not stored in
754 string_chars_blocks. Furthermore, no one string stretches across
755 two string_chars_blocks.
757 Vectors are each malloc()ed separately, similar to lcrecords.
759 In the following discussion, we use conses, but it applies equally
760 well to the other fixed-size types.
762 We store cons cells inside of cons_blocks, allocating a new
763 cons_block with malloc() whenever necessary. Cons cells reclaimed
764 by GC are put on a free list to be reallocated before allocating
765 any new cons cells from the latest cons_block. Each cons_block is
766 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
767 the versions in malloc.c and gmalloc.c) really allocates in units
768 of powers of two and uses 4 bytes for its own overhead.
770 What GC actually does is to search through all the cons_blocks,
771 from the most recently allocated to the oldest, and put all
772 cons cells that are not marked (whether or not they're already
773 free) on a cons_free_list. The cons_free_list is a stack, and
774 so the cons cells in the oldest-allocated cons_block end up
775 at the head of the stack and are the first to be reallocated.
776 If any cons_block is entirely free, it is freed with free()
777 and its cons cells removed from the cons_free_list. Because
778 the cons_free_list ends up basically in memory order, we have
779 a high locality of reference (assuming a reasonable turnover
780 of allocating and freeing) and have a reasonable probability
781 of entirely freeing up cons_blocks that have been more recently
782 allocated. This stage is called the "sweep stage" of GC, and
783 is executed after the "mark stage", which involves starting
784 from all places that are known to point to in-use Lisp objects
785 (e.g. the obarray, where are all symbols are stored; the
786 current catches and condition-cases; the backtrace list of
787 currently executing functions; the gcpro list; etc.) and
788 recursively marking all objects that are accessible.
790 At the beginning of the sweep stage, the conses in the cons
791 blocks are in one of three states: in use and marked, in use
792 but not marked, and not in use (already freed). Any conses
793 that are marked have been marked in the mark stage just
794 executed, because as part of the sweep stage we unmark any
795 marked objects. The way we tell whether or not a cons cell
796 is in use is through the FREE_STRUCT_P macro. This basically
797 looks at the first 4 bytes (or however many bytes a pointer
798 fits in) to see if all the bits in those bytes are 1. The
799 resulting value (0xFFFFFFFF) is not a valid pointer and is
800 not a valid Lisp_Object. All current fixed-size types have
801 a pointer or Lisp_Object as their first element with the
802 exception of strings; they have a size value, which can
803 never be less than zero, and so 0xFFFFFFFF is invalid for
804 strings as well. Now assuming that a cons cell is in use,
805 the way we tell whether or not it is marked is to look at
806 the mark bit of its car (each Lisp_Object has one bit
807 reserved as a mark bit, in case it's needed). Note that
808 different types of objects use different fields to indicate
809 whether the object is marked, but the principle is the same.
811 Conses on the free_cons_list are threaded through a pointer
812 stored in the bytes directly after the bytes that are set
813 to 0xFFFFFFFF (we cannot overwrite these because the cons
814 is still in a cons_block and needs to remain marked as
815 not in use for the next time that GC happens). This
816 implies that all fixed-size types must be at least big
817 enough to store two pointers, which is indeed the case
818 for all current fixed-size types.
820 Some types of objects need additional "finalization" done
821 when an object is converted from in use to not in use;
822 this is the purpose of the ADDITIONAL_FREE_type macro.
823 For example, markers need to be removed from the chain
824 of markers that is kept in each buffer. This is because
825 markers in a buffer automatically disappear if the marker
826 is no longer referenced anywhere (the same does not
827 apply to extents, however).
829 WARNING: Things are in an extremely bizarre state when
830 the ADDITIONAL_FREE_type macros are called, so beware!
832 When ERROR_CHECK_GC is defined, we do things differently
833 so as to maximize our chances of catching places where
834 there is insufficient GCPROing. The thing we want to
835 avoid is having an object that we're using but didn't
836 GCPRO get freed by GC and then reallocated while we're
837 in the process of using it -- this will result in something
838 seemingly unrelated getting trashed, and is extremely
839 difficult to track down. If the object gets freed but
840 not reallocated, we can usually catch this because we
841 set all bytes of a freed object to 0xDEADBEEF. (The
842 first four bytes, however, are 0xFFFFFFFF, and the next
843 four are a pointer used to chain freed objects together;
844 we play some tricks with this pointer to make it more
845 bogus, so crashes are more likely to occur right away.)
847 We want freed objects to stay free as long as possible,
848 so instead of doing what we do above, we maintain the
849 free objects in a first-in first-out queue. We also
850 don't recompute the free list each GC, unlike above;
851 this ensures that the queue ordering is preserved.
852 [This means that we are likely to have worse locality
853 of reference, and that we can never free a frob block
854 once it's allocated. (Even if we know that all cells
855 in it are free, there's no easy way to remove all those
856 cells from the free list because the objects on the
857 free list are unlikely to be in memory order.)]
858 Furthermore, we never take objects off the free list
859 unless there's a large number (usually 1000, but
860 varies depending on type) of them already on the list.
861 This way, we ensure that an object that gets freed will
862 remain free for the next 1000 (or whatever) times that
863 an object of that type is allocated.
866 #ifndef MALLOC_OVERHEAD
868 #define MALLOC_OVERHEAD 0
869 #elif defined (rcheck)
870 #define MALLOC_OVERHEAD 20
872 #define MALLOC_OVERHEAD 8
874 #endif /* MALLOC_OVERHEAD */
876 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
877 /* If we released our reserve (due to running out of memory),
878 and we have a fair amount free once again,
879 try to set aside another reserve in case we run out once more.
881 This is called when a relocatable block is freed in ralloc.c. */
882 void refill_memory_reserve (void);
884 refill_memory_reserve ()
886 if (breathing_space == 0)
887 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
891 #ifdef ALLOC_NO_POOLS
892 # define TYPE_ALLOC_SIZE(type, structtype) 1
894 # define TYPE_ALLOC_SIZE(type, structtype) \
895 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
896 / sizeof (structtype))
897 #endif /* ALLOC_NO_POOLS */
899 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
901 struct type##_block \
903 struct type##_block *prev; \
904 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
907 static struct type##_block *current_##type##_block; \
908 static int current_##type##_block_index; \
910 static structtype *type##_free_list; \
911 static structtype *type##_free_list_tail; \
914 init_##type##_alloc (void) \
916 current_##type##_block = 0; \
917 current_##type##_block_index = \
918 countof (current_##type##_block->block); \
919 type##_free_list = 0; \
920 type##_free_list_tail = 0; \
923 static int gc_count_num_##type##_in_use; \
924 static int gc_count_num_##type##_freelist
926 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
927 if (current_##type##_block_index \
928 == countof (current_##type##_block->block)) \
930 struct type##_block *AFTFB_new = (struct type##_block *) \
931 allocate_lisp_storage (sizeof (struct type##_block)); \
932 AFTFB_new->prev = current_##type##_block; \
933 current_##type##_block = AFTFB_new; \
934 current_##type##_block_index = 0; \
937 &(current_##type##_block->block[current_##type##_block_index++]); \
940 /* Allocate an instance of a type that is stored in blocks.
941 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
944 #ifdef ERROR_CHECK_GC
946 /* Note: if you get crashes in this function, suspect incorrect calls
947 to free_cons() and friends. This happened once because the cons
948 cell was not GC-protected and was getting collected before
949 free_cons() was called. */
951 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
954 if (gc_count_num_##type##_freelist > \
955 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
957 result = type##_free_list; \
958 /* Before actually using the chain pointer, we complement all its \
959 bits; see FREE_FIXED_TYPE(). */ \
961 (structtype *) ~(unsigned long) \
962 (* (structtype **) ((char *) result + sizeof (void *))); \
963 gc_count_num_##type##_freelist--; \
966 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
967 MARK_STRUCT_AS_NOT_FREE (result); \
970 #else /* !ERROR_CHECK_GC */
972 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
975 if (type##_free_list) \
977 result = type##_free_list; \
979 * (structtype **) ((char *) result + sizeof (void *)); \
982 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
983 MARK_STRUCT_AS_NOT_FREE (result); \
986 #endif /* !ERROR_CHECK_GC */
988 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
991 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
992 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
995 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
998 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
999 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
1002 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
1003 to a Lisp object and invalid as an actual Lisp_Object value. We have
1004 to make sure that this value cannot be an integer in Lisp_Object form.
1005 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
1006 On a 32-bit system, the type bits will be non-zero, making the value
1007 be a pointer, and the pointer will be misaligned.
1009 Even if Emacs is run on some weirdo system that allows and allocates
1010 byte-aligned pointers, this pointer is at the very top of the address
1011 space and so it's almost inconceivable that it could ever be valid. */
1014 # define INVALID_POINTER_VALUE 0xFFFFFFFF
1016 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
1018 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
1020 You have some weird system and need to supply a reasonable value here.
1023 #define FREE_STRUCT_P(ptr) \
1024 (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
1025 #define MARK_STRUCT_AS_FREE(ptr) \
1026 (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
1027 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
1028 (* (void **) ptr = 0)
1030 #ifdef ERROR_CHECK_GC
1032 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
1033 do { if (type##_free_list_tail) \
1035 /* When we store the chain pointer, we complement all \
1036 its bits; this should significantly increase its \
1037 bogosity in case someone tries to use the value, and \
1038 should make us dump faster if someone stores something \
1039 over the pointer because when it gets un-complemented in \
1040 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
1041 extremely bogus. */ \
1043 ((char *) type##_free_list_tail + sizeof (void *)) = \
1044 (structtype *) ~(unsigned long) ptr; \
1047 type##_free_list = ptr; \
1048 type##_free_list_tail = ptr; \
1051 #else /* !ERROR_CHECK_GC */
1053 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
1054 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
1056 type##_free_list = (ptr); \
1059 #endif /* !ERROR_CHECK_GC */
1061 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
1063 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
1064 structtype *FFT_ptr = (ptr); \
1065 ADDITIONAL_FREE_##type (FFT_ptr); \
1066 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
1067 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
1068 MARK_STRUCT_AS_FREE (FFT_ptr); \
1071 /* Like FREE_FIXED_TYPE() but used when we are explicitly
1072 freeing a structure through free_cons(), free_marker(), etc.
1073 rather than through the normal process of sweeping.
1074 We attempt to undo the changes made to the allocation counters
1075 as a result of this structure being allocated. This is not
1076 completely necessary but helps keep things saner: e.g. this way,
1077 repeatedly allocating and freeing a cons will not result in
1078 the consing-since-gc counter advancing, which would cause a GC
1079 and somewhat defeat the purpose of explicitly freeing. */
1081 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
1082 do { FREE_FIXED_TYPE (type, structtype, ptr); \
1083 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
1084 gc_count_num_##type##_freelist++; \
1089 /************************************************************************/
1090 /* Cons allocation */
1091 /************************************************************************/
1093 DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons);
1094 /* conses are used and freed so often that we set this really high */
1095 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
1096 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
1100 mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object))
1102 if (GC_NILP (XCDR (obj)))
1105 markobj (XCAR (obj));
1110 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
1112 while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1))
1116 if (! CONSP (ob1) || ! CONSP (ob2))
1117 return internal_equal (ob1, ob2, depth + 1);
1122 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
1123 mark_cons, print_cons, 0,
1126 * No `hash' method needed.
1127 * internal_hash knows how to
1132 #endif /* LRECORD_CONS */
1134 DEFUN ("cons", Fcons, 2, 2, 0, /*
1135 Create a new cons, give it CAR and CDR as components, and return it.
1139 /* This cannot GC. */
1141 struct Lisp_Cons *c;
1143 ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1145 set_lheader_implementation (&(c->lheader), lrecord_cons);
1153 /* This is identical to Fcons() but it used for conses that we're
1154 going to free later, and is useful when trying to track down
1157 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
1160 struct Lisp_Cons *c;
1162 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1164 set_lheader_implementation (&(c->lheader), lrecord_cons);
1172 DEFUN ("list", Flist, 0, MANY, 0, /*
1173 Return a newly created list with specified arguments as elements.
1174 Any number of arguments, even zero arguments, are allowed.
1176 (int nargs, Lisp_Object *args))
1178 Lisp_Object val = Qnil;
1179 Lisp_Object *argp = args + nargs;
1182 val = Fcons (*--argp, val);
1187 list1 (Lisp_Object obj0)
1189 /* This cannot GC. */
1190 return Fcons (obj0, Qnil);
1194 list2 (Lisp_Object obj0, Lisp_Object obj1)
1196 /* This cannot GC. */
1197 return Fcons (obj0, Fcons (obj1, Qnil));
1201 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1203 /* This cannot GC. */
1204 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1208 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1210 /* This cannot GC. */
1211 return Fcons (obj0, Fcons (obj1, obj2));
1215 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1217 return Fcons (Fcons (key, value), alist);
1221 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1223 /* This cannot GC. */
1224 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1228 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1231 /* This cannot GC. */
1232 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1236 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1237 Lisp_Object obj4, Lisp_Object obj5)
1239 /* This cannot GC. */
1240 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1243 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1244 Return a new list of length LENGTH, with each element being INIT.
1248 CHECK_NATNUM (length);
1251 Lisp_Object val = Qnil;
1252 int size = XINT (length);
1255 val = Fcons (init, val);
1261 /************************************************************************/
1262 /* Float allocation */
1263 /************************************************************************/
1265 #ifdef LISP_FLOAT_TYPE
1267 DECLARE_FIXED_TYPE_ALLOC (float, struct Lisp_Float);
1268 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1271 make_float (double float_value)
1274 struct Lisp_Float *f;
1276 ALLOCATE_FIXED_TYPE (float, struct Lisp_Float, f);
1277 set_lheader_implementation (&(f->lheader), lrecord_float);
1278 float_data (f) = float_value;
1283 #endif /* LISP_FLOAT_TYPE */
1286 /************************************************************************/
1287 /* Vector allocation */
1288 /************************************************************************/
1290 #ifdef LRECORD_VECTOR
1292 mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
1294 Lisp_Vector *ptr = XVECTOR (obj);
1295 int len = vector_length (ptr);
1298 for (i = 0; i < len - 1; i++)
1299 markobj (ptr->contents[i]);
1300 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1304 size_vector (CONST void *lheader)
1306 return offsetof (Lisp_Vector, contents[((Lisp_Vector *) lheader)->size]);
1310 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1313 int len = XVECTOR_LENGTH (obj1);
1314 if (len != XVECTOR_LENGTH (obj2))
1316 for (indice = 0; indice < len; indice++)
1318 if (!internal_equal (XVECTOR_DATA (obj1) [indice],
1319 XVECTOR_DATA (obj2) [indice],
1326 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1327 mark_vector, print_vector, 0,
1330 * No `hash' method needed for
1331 * vectors. internal_hash
1332 * knows how to handle vectors.
1335 size_vector, Lisp_Vector);
1337 /* #### should allocate `small' vectors from a frob-block */
1338 static Lisp_Vector *
1339 make_vector_internal (size_t sizei)
1341 /* no vector_next */
1342 size_t sizem = offsetof (Lisp_Vector, contents[sizei]);
1343 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, lrecord_vector);
1349 #else /* ! LRECORD_VECTOR */
1351 static Lisp_Object all_vectors;
1353 /* #### should allocate `small' vectors from a frob-block */
1354 static Lisp_Vector *
1355 make_vector_internal (size_t sizei)
1357 /* + 1 to account for vector_next */
1358 size_t sizem = offsetof (Lisp_Vector, contents[sizei+1]);
1359 Lisp_Vector *p = (Lisp_Vector *) allocate_lisp_storage (sizem);
1361 INCREMENT_CONS_COUNTER (sizem, "vector");
1364 vector_next (p) = all_vectors;
1365 XSETVECTOR (all_vectors, p);
1369 #endif /* ! LRECORD_VECTOR */
1372 make_vector (EMACS_INT length, Lisp_Object init)
1379 length = XINT (wrong_type_argument (Qnatnump, make_int (length)));
1381 p = make_vector_internal (length);
1382 XSETVECTOR (vector, p);
1385 /* Initialize big arrays full of 0's quickly, for what that's worth */
1387 char *travesty = (char *) &init;
1388 for (i = 1; i < sizeof (Lisp_Object); i++)
1390 if (travesty[i] != travesty[0])
1393 memset (vector_data (p), travesty[0], length * sizeof (Lisp_Object));
1398 for (elt = 0; elt < length; elt++)
1399 vector_data(p)[elt] = init;
1404 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1405 Return a new vector of length LENGTH, with each element being INIT.
1406 See also the function `vector'.
1410 CHECK_NATNUM (length);
1411 return make_vector (XINT (length), init);
1414 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1415 Return a newly created vector with specified arguments as elements.
1416 Any number of arguments, even zero arguments, are allowed.
1418 (int nargs, Lisp_Object *args))
1422 Lisp_Vector *p = make_vector_internal (nargs);
1424 for (elt = 0; elt < nargs; elt++)
1425 vector_data(p)[elt] = args[elt];
1427 XSETVECTOR (vector, p);
1432 vector1 (Lisp_Object obj0)
1434 return Fvector (1, &obj0);
1438 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1440 Lisp_Object args[2];
1443 return Fvector (2, args);
1447 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1449 Lisp_Object args[3];
1453 return Fvector (3, args);
1456 #if 0 /* currently unused */
1459 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1462 Lisp_Object args[4];
1467 return Fvector (4, args);
1471 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1472 Lisp_Object obj3, Lisp_Object obj4)
1474 Lisp_Object args[5];
1480 return Fvector (5, args);
1484 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1485 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1487 Lisp_Object args[6];
1494 return Fvector (6, args);
1498 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1499 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1502 Lisp_Object args[7];
1510 return Fvector (7, args);
1514 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1515 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1516 Lisp_Object obj6, Lisp_Object obj7)
1518 Lisp_Object args[8];
1527 return Fvector (8, args);
1531 /************************************************************************/
1532 /* Bit Vector allocation */
1533 /************************************************************************/
1535 static Lisp_Object all_bit_vectors;
1537 /* #### should allocate `small' bit vectors from a frob-block */
1538 static struct Lisp_Bit_Vector *
1539 make_bit_vector_internal (size_t sizei)
1542 offsetof (Lisp_Bit_Vector, bits[BIT_VECTOR_LONG_STORAGE (sizei)]);
1543 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1544 set_lheader_implementation (&(p->lheader), lrecord_bit_vector);
1546 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1548 bit_vector_length (p) = sizei;
1549 bit_vector_next (p) = all_bit_vectors;
1550 /* make sure the extra bits in the last long are 0; the calling
1551 functions might not set them. */
1552 p->bits[BIT_VECTOR_LONG_STORAGE (sizei) - 1] = 0;
1553 XSETBIT_VECTOR (all_bit_vectors, p);
1558 make_bit_vector (EMACS_INT length, Lisp_Object init)
1560 Lisp_Object bit_vector;
1561 struct Lisp_Bit_Vector *p;
1562 EMACS_INT num_longs;
1566 num_longs = BIT_VECTOR_LONG_STORAGE (length);
1567 p = make_bit_vector_internal (length);
1568 XSETBIT_VECTOR (bit_vector, p);
1571 memset (p->bits, 0, num_longs * sizeof (long));
1574 EMACS_INT bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1575 memset (p->bits, ~0, num_longs * sizeof (long));
1576 /* But we have to make sure that the unused bits in the
1577 last integer are 0, so that equal/hash is easy. */
1579 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1586 make_bit_vector_from_byte_vector (unsigned char *bytevec, EMACS_INT length)
1588 Lisp_Object bit_vector;
1589 struct Lisp_Bit_Vector *p;
1593 length = XINT (wrong_type_argument (Qnatnump, make_int (length)));
1595 p = make_bit_vector_internal (length);
1596 XSETBIT_VECTOR (bit_vector, p);
1598 for (i = 0; i < length; i++)
1599 set_bit_vector_bit (p, i, bytevec[i]);
1604 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1605 Return a new bit vector of length LENGTH. with each bit being INIT.
1606 Each element is set to INIT. See also the function `bit-vector'.
1610 CONCHECK_NATNUM (length);
1612 return make_bit_vector (XINT (length), init);
1615 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1616 Return a newly created bit vector with specified arguments as elements.
1617 Any number of arguments, even zero arguments, are allowed.
1619 (int nargs, Lisp_Object *args))
1621 Lisp_Object bit_vector;
1623 struct Lisp_Bit_Vector *p;
1625 for (elt = 0; elt < nargs; elt++)
1626 CHECK_BIT (args[elt]);
1628 p = make_bit_vector_internal (nargs);
1630 for (elt = 0; elt < nargs; elt++)
1631 set_bit_vector_bit (p, elt, !ZEROP (args[elt]));
1633 XSETBIT_VECTOR (bit_vector, p);
1638 /************************************************************************/
1639 /* Compiled-function allocation */
1640 /************************************************************************/
1642 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1643 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1646 make_compiled_function (int make_pure)
1648 Lisp_Compiled_Function *f;
1650 size_t size = sizeof (Lisp_Compiled_Function);
1652 if (make_pure && check_purespace (size))
1654 f = (Lisp_Compiled_Function *) (PUREBEG + pure_bytes_used);
1655 set_lheader_implementation (&(f->lheader), lrecord_compiled_function);
1656 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
1657 f->lheader.pure = 1;
1659 pure_bytes_used += size;
1660 bump_purestat (&purestat_function, size);
1664 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1665 set_lheader_implementation (&(f->lheader), lrecord_compiled_function);
1668 f->specpdl_depth = 0;
1669 f->flags.documentationp = 0;
1670 f->flags.interactivep = 0;
1671 f->flags.domainp = 0; /* I18N3 */
1672 f->instructions = Qzero;
1673 f->constants = Qzero;
1675 f->doc_and_interactive = Qnil;
1676 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1677 f->annotated = Qnil;
1679 XSETCOMPILED_FUNCTION (fun, f);
1683 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1684 Return a new compiled-function object.
1685 Usage: (arglist instructions constants stack-depth
1686 &optional doc-string interactive)
1687 Note that, unlike all other emacs-lisp functions, calling this with five
1688 arguments is NOT the same as calling it with six arguments, the last of
1689 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1690 that this function was defined with `(interactive)'. If the arg is not
1691 specified, then that means the function is not interactive.
1692 This is terrible behavior which is retained for compatibility with old
1693 `.elc' files which expect these semantics.
1695 (int nargs, Lisp_Object *args))
1697 /* In a non-insane world this function would have this arglist...
1698 (arglist instructions constants stack_depth &optional doc_string interactive)
1700 Lisp_Object fun = make_compiled_function (purify_flag);
1701 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1703 Lisp_Object arglist = args[0];
1704 Lisp_Object instructions = args[1];
1705 Lisp_Object constants = args[2];
1706 Lisp_Object stack_depth = args[3];
1707 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1708 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1710 /* Don't purecopy the doc references in instructions because it's
1711 wasteful; they will get fixed up later.
1713 #### If something goes wrong and they don't get fixed up,
1714 we're screwed, because pure stuff isn't marked and thus the
1715 cons references won't be marked and will get reused.
1717 Note: there will be a window after the byte code is created and
1718 before the doc references are fixed up in which there will be
1719 impure objects inside a pure object, which apparently won't
1720 get marked, leading to trouble. But during that entire window,
1721 the objects are sitting on Vload_force_doc_string_list, which
1722 is staticpro'd, so we're OK. */
1723 Lisp_Object (*cons) (Lisp_Object, Lisp_Object)
1724 = purify_flag ? pure_cons : Fcons;
1726 if (nargs < 4 || nargs > 6)
1727 return Fsignal (Qwrong_number_of_arguments,
1728 list2 (intern ("make-byte-code"), make_int (nargs)));
1730 /* Check for valid formal parameter list now, to allow us to use
1731 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1733 Lisp_Object symbol, tail;
1734 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1736 CHECK_SYMBOL (symbol);
1737 if (EQ (symbol, Qt) ||
1738 EQ (symbol, Qnil) ||
1739 SYMBOL_IS_KEYWORD (symbol))
1740 signal_simple_error_2
1741 ("Invalid constant symbol in formal parameter list",
1745 f->arglist = arglist;
1747 /* `instructions' is a string or a cons (string . int) for a
1748 lazy-loaded function. */
1749 if (CONSP (instructions))
1751 CHECK_STRING (XCAR (instructions));
1752 CHECK_INT (XCDR (instructions));
1756 CHECK_STRING (instructions);
1758 f->instructions = instructions;
1760 if (!NILP (constants))
1761 CHECK_VECTOR (constants);
1762 f->constants = constants;
1764 CHECK_NATNUM (stack_depth);
1765 f->stack_depth = XINT (stack_depth);
1767 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1768 if (!NILP (Vcurrent_compiled_function_annotation))
1769 f->annotated = Fpurecopy (Vcurrent_compiled_function_annotation);
1770 else if (!NILP (Vload_file_name_internal_the_purecopy))
1771 f->annotated = Vload_file_name_internal_the_purecopy;
1772 else if (!NILP (Vload_file_name_internal))
1774 struct gcpro gcpro1;
1775 GCPRO1 (fun); /* don't let fun get reaped */
1776 Vload_file_name_internal_the_purecopy =
1777 Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
1778 f->annotated = Vload_file_name_internal_the_purecopy;
1781 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1783 /* doc_string may be nil, string, int, or a cons (string . int).
1784 interactive may be list or string (or unbound). */
1785 f->doc_and_interactive = Qunbound;
1787 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1788 f->doc_and_interactive = Vfile_domain;
1790 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1794 interactive = Fpurecopy (interactive);
1795 if (STRINGP (interactive))
1796 bump_purestat (&purestat_string_interactive,
1797 pure_sizeof (interactive));
1799 f->doc_and_interactive
1800 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1801 cons (interactive, f->doc_and_interactive));
1803 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1807 doc_string = Fpurecopy (doc_string);
1808 if (STRINGP (doc_string))
1809 /* These should have been snagged by make-docfile... */
1810 bump_purestat (&purestat_string_documentation,
1811 pure_sizeof (doc_string));
1813 f->doc_and_interactive
1814 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1815 cons (doc_string, f->doc_and_interactive));
1817 if (UNBOUNDP (f->doc_and_interactive))
1818 f->doc_and_interactive = Qnil;
1823 if (!purified (f->arglist))
1824 f->arglist = Fpurecopy (f->arglist);
1826 /* Statistics are kept differently for the constants */
1827 if (!purified (f->constants))
1830 int old = purecopying_function_constants;
1831 purecopying_function_constants = 1;
1832 f->constants = Fpurecopy (f->constants);
1833 bump_purestat (&purestat_vector_constants,
1834 pure_sizeof (f->constants));
1835 purecopying_function_constants = old;
1837 f->constants = Fpurecopy (f->constants);
1838 #endif /* PURESTAT */
1841 optimize_compiled_function (fun);
1843 bump_purestat (&purestat_opaque_instructions,
1844 pure_sizeof (f->instructions));
1851 /************************************************************************/
1852 /* Symbol allocation */
1853 /************************************************************************/
1855 DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol);
1856 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1858 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1859 Return a newly allocated uninterned symbol whose name is NAME.
1860 Its value and function definition are void, and its property list is nil.
1865 struct Lisp_Symbol *p;
1867 CHECK_STRING (name);
1869 ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p);
1870 #ifdef LRECORD_SYMBOL
1871 set_lheader_implementation (&(p->lheader), lrecord_symbol);
1873 p->name = XSTRING (name);
1875 p->value = Qunbound;
1876 p->function = Qunbound;
1878 symbol_next (p) = 0;
1879 XSETSYMBOL (val, p);
1884 /************************************************************************/
1885 /* Extent allocation */
1886 /************************************************************************/
1888 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1889 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1892 allocate_extent (void)
1896 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1897 set_lheader_implementation (&(e->lheader), lrecord_extent);
1898 extent_object (e) = Qnil;
1899 set_extent_start (e, -1);
1900 set_extent_end (e, -1);
1905 extent_face (e) = Qnil;
1906 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1907 e->flags.detachable = 1;
1913 /************************************************************************/
1914 /* Event allocation */
1915 /************************************************************************/
1917 DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event);
1918 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1921 allocate_event (void)
1924 struct Lisp_Event *e;
1926 ALLOCATE_FIXED_TYPE (event, struct Lisp_Event, e);
1927 set_lheader_implementation (&(e->lheader), lrecord_event);
1934 /************************************************************************/
1935 /* Marker allocation */
1936 /************************************************************************/
1938 DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker);
1939 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1941 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1942 Return a new marker which does not point at any place.
1947 struct Lisp_Marker *p;
1949 ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1950 set_lheader_implementation (&(p->lheader), lrecord_marker);
1953 marker_next (p) = 0;
1954 marker_prev (p) = 0;
1955 p->insertion_type = 0;
1956 XSETMARKER (val, p);
1961 noseeum_make_marker (void)
1964 struct Lisp_Marker *p;
1966 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1967 set_lheader_implementation (&(p->lheader), lrecord_marker);
1970 marker_next (p) = 0;
1971 marker_prev (p) = 0;
1972 p->insertion_type = 0;
1973 XSETMARKER (val, p);
1978 /************************************************************************/
1979 /* String allocation */
1980 /************************************************************************/
1982 /* The data for "short" strings generally resides inside of structs of type
1983 string_chars_block. The Lisp_String structure is allocated just like any
1984 other Lisp object (except for vectors), and these are freelisted when
1985 they get garbage collected. The data for short strings get compacted,
1986 but the data for large strings do not.
1988 Previously Lisp_String structures were relocated, but this caused a lot
1989 of bus-errors because the C code didn't include enough GCPRO's for
1990 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1991 that the reference would get relocated).
1993 This new method makes things somewhat bigger, but it is MUCH safer. */
1995 DECLARE_FIXED_TYPE_ALLOC (string, struct Lisp_String);
1996 /* strings are used and freed quite often */
1997 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1998 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
2000 #ifdef LRECORD_STRING
2002 mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object))
2004 struct Lisp_String *ptr = XSTRING (obj);
2006 if (GC_CONSP (ptr->plist) && GC_EXTENT_INFOP (XCAR (ptr->plist)))
2007 flush_cached_extent_info (XCAR (ptr->plist));
2012 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2015 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
2016 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
2019 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
2020 mark_string, print_string,
2022 * No `finalize', or `hash' methods.
2023 * internal_hash already knows how
2024 * to hash strings and finalization
2026 * ADDITIONAL_FREE_string macro,
2027 * which is the standard way to do
2028 * finalization when using
2029 * SWEEP_FIXED_TYPE_BLOCK().
2032 struct Lisp_String);
2033 #endif /* LRECORD_STRING */
2035 /* String blocks contain this many useful bytes. */
2036 #define STRING_CHARS_BLOCK_SIZE \
2037 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
2038 ((2 * sizeof (struct string_chars_block *)) \
2039 + sizeof (EMACS_INT))))
2040 /* Block header for small strings. */
2041 struct string_chars_block
2044 struct string_chars_block *next;
2045 struct string_chars_block *prev;
2046 /* Contents of string_chars_block->string_chars are interleaved
2047 string_chars structures (see below) and the actual string data */
2048 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
2051 struct string_chars_block *first_string_chars_block;
2052 struct string_chars_block *current_string_chars_block;
2054 /* If SIZE is the length of a string, this returns how many bytes
2055 * the string occupies in string_chars_block->string_chars
2056 * (including alignment padding).
2058 #define STRING_FULLSIZE(s) \
2059 ALIGN_SIZE (((s) + 1 + sizeof (struct Lisp_String *)),\
2060 ALIGNOF (struct Lisp_String *))
2062 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
2063 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
2065 #define CHARS_TO_STRING_CHAR(x) \
2066 ((struct string_chars *) \
2067 (((char *) (x)) - (slot_offset (struct string_chars, chars[0]))))
2072 struct Lisp_String *string;
2073 unsigned char chars[1];
2076 struct unused_string_chars
2078 struct Lisp_String *string;
2083 init_string_chars_alloc (void)
2085 first_string_chars_block = xnew (struct string_chars_block);
2086 first_string_chars_block->prev = 0;
2087 first_string_chars_block->next = 0;
2088 first_string_chars_block->pos = 0;
2089 current_string_chars_block = first_string_chars_block;
2092 static struct string_chars *
2093 allocate_string_chars_struct (struct Lisp_String *string_it_goes_with,
2096 struct string_chars *s_chars;
2098 /* Allocate the string's actual data */
2099 if (BIG_STRING_FULLSIZE_P (fullsize))
2101 s_chars = (struct string_chars *) xmalloc (fullsize);
2103 else if (fullsize <=
2104 (countof (current_string_chars_block->string_chars)
2105 - current_string_chars_block->pos))
2107 /* This string can fit in the current string chars block */
2108 s_chars = (struct string_chars *)
2109 (current_string_chars_block->string_chars
2110 + current_string_chars_block->pos);
2111 current_string_chars_block->pos += fullsize;
2115 /* Make a new current string chars block */
2116 struct string_chars_block *new = xnew (struct string_chars_block);
2118 current_string_chars_block->next = new;
2119 new->prev = current_string_chars_block;
2121 current_string_chars_block = new;
2122 new->pos = fullsize;
2123 s_chars = (struct string_chars *)
2124 current_string_chars_block->string_chars;
2127 s_chars->string = string_it_goes_with;
2129 INCREMENT_CONS_COUNTER (fullsize, "string chars");
2135 make_uninit_string (Bytecount length)
2137 struct Lisp_String *s;
2138 struct string_chars *s_chars;
2139 EMACS_INT fullsize = STRING_FULLSIZE (length);
2142 if ((length < 0) || (fullsize <= 0))
2145 /* Allocate the string header */
2146 ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
2147 #ifdef LRECORD_STRING
2148 set_lheader_implementation (&(s->lheader), lrecord_string);
2151 s_chars = allocate_string_chars_struct (s, fullsize);
2153 set_string_data (s, &(s_chars->chars[0]));
2154 set_string_length (s, length);
2157 set_string_byte (s, length, 0);
2159 XSETSTRING (val, s);
2163 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2164 static void verify_string_chars_integrity (void);
2167 /* Resize the string S so that DELTA bytes can be inserted starting
2168 at POS. If DELTA < 0, it means deletion starting at POS. If
2169 POS < 0, resize the string but don't copy any characters. Use
2170 this if you're planning on completely overwriting the string.
2174 resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta)
2176 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2177 verify_string_chars_integrity ();
2180 #ifdef ERROR_CHECK_BUFPOS
2183 assert (pos <= string_length (s));
2185 assert (pos + (-delta) <= string_length (s));
2190 assert ((-delta) <= string_length (s));
2192 #endif /* ERROR_CHECK_BUFPOS */
2194 if (pos >= 0 && delta < 0)
2195 /* If DELTA < 0, the functions below will delete the characters
2196 before POS. We want to delete characters *after* POS, however,
2197 so convert this to the appropriate form. */
2201 /* simplest case: no size change. */
2205 Bytecount oldfullsize = STRING_FULLSIZE (string_length (s));
2206 Bytecount newfullsize = STRING_FULLSIZE (string_length (s) + delta);
2208 if (oldfullsize == newfullsize)
2210 /* next simplest case; size change but the necessary
2211 allocation size won't change (up or down; code somewhere
2212 depends on there not being any unused allocation space,
2213 modulo any alignment constraints). */
2216 Bufbyte *addroff = pos + string_data (s);
2218 memmove (addroff + delta, addroff,
2219 /* +1 due to zero-termination. */
2220 string_length (s) + 1 - pos);
2223 else if (BIG_STRING_FULLSIZE_P (oldfullsize) &&
2224 BIG_STRING_FULLSIZE_P (newfullsize))
2226 /* next simplest case; the string is big enough to be malloc()ed
2227 itself, so we just realloc.
2229 It's important not to let the string get below the threshold
2230 for making big strings and still remain malloc()ed; if that
2231 were the case, repeated calls to this function on the same
2232 string could result in memory leakage. */
2233 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
2237 Bufbyte *addroff = pos + string_data (s);
2239 memmove (addroff + delta, addroff,
2240 /* +1 due to zero-termination. */
2241 string_length (s) + 1 - pos);
2246 /* worst case. We make a new string_chars struct and copy
2247 the string's data into it, inserting/deleting the delta
2248 in the process. The old string data will either get
2249 freed by us (if it was malloc()ed) or will be reclaimed
2250 in the normal course of garbage collection. */
2251 struct string_chars *s_chars =
2252 allocate_string_chars_struct (s, newfullsize);
2253 Bufbyte *new_addr = &(s_chars->chars[0]);
2254 Bufbyte *old_addr = string_data (s);
2257 memcpy (new_addr, old_addr, pos);
2258 memcpy (new_addr + pos + delta, old_addr + pos,
2259 string_length (s) + 1 - pos);
2261 set_string_data (s, new_addr);
2262 if (BIG_STRING_FULLSIZE_P (oldfullsize))
2266 /* We need to mark this chunk of the string_chars_block
2267 as unused so that compact_string_chars() doesn't
2269 struct string_chars *old_s_chars =
2270 (struct string_chars *) ((char *) old_addr -
2271 sizeof (struct Lisp_String *));
2272 /* Sanity check to make sure we aren't hosed by strange
2273 alignment/padding. */
2274 assert (old_s_chars->string == s);
2275 MARK_STRUCT_AS_FREE (old_s_chars);
2276 ((struct unused_string_chars *) old_s_chars)->fullsize =
2281 set_string_length (s, string_length (s) + delta);
2282 /* If pos < 0, the string won't be zero-terminated.
2283 Terminate now just to make sure. */
2284 string_data (s)[string_length (s)] = '\0';
2290 XSETSTRING (string, s);
2291 /* We also have to adjust all of the extent indices after the
2292 place we did the change. We say "pos - 1" because
2293 adjust_extents() is exclusive of the starting position
2295 adjust_extents (string, pos - 1, string_length (s),
2300 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2301 verify_string_chars_integrity ();
2308 set_string_char (struct Lisp_String *s, Charcount i, Emchar c)
2310 Bytecount oldlen, newlen;
2311 Bufbyte newstr[MAX_EMCHAR_LEN];
2312 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2314 oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2315 newlen = set_charptr_emchar (newstr, c);
2317 if (oldlen != newlen)
2318 resize_string (s, bytoff, newlen - oldlen);
2319 /* Remember, string_data (s) might have changed so we can't cache it. */
2320 memcpy (string_data (s) + bytoff, newstr, newlen);
2325 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2326 Return a new string of length LENGTH, with each character being INIT.
2327 LENGTH must be an integer and INIT must be a character.
2331 CHECK_NATNUM (length);
2332 CHECK_CHAR_COERCE_INT (init);
2334 Bufbyte init_str[MAX_EMCHAR_LEN];
2335 int len = set_charptr_emchar (init_str, XCHAR (init));
2336 Lisp_Object val = make_uninit_string (len * XINT (length));
2339 /* Optimize the single-byte case */
2340 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2344 Bufbyte *ptr = XSTRING_DATA (val);
2346 for (i = XINT (length); i; i--)
2348 Bufbyte *init_ptr = init_str;
2351 case 4: *ptr++ = *init_ptr++;
2352 case 3: *ptr++ = *init_ptr++;
2353 case 2: *ptr++ = *init_ptr++;
2354 case 1: *ptr++ = *init_ptr++;
2362 DEFUN ("string", Fstring, 0, MANY, 0, /*
2363 Concatenate all the argument characters and make the result a string.
2365 (int nargs, Lisp_Object *args))
2367 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2368 Bufbyte *p = storage;
2370 for (; nargs; nargs--, args++)
2372 Lisp_Object lisp_char = *args;
2373 CHECK_CHAR_COERCE_INT (lisp_char);
2374 p += set_charptr_emchar (p, XCHAR (lisp_char));
2376 return make_string (storage, p - storage);
2379 /* Take some raw memory, which MUST already be in internal format,
2380 and package it up into a Lisp string. */
2382 make_string (CONST Bufbyte *contents, Bytecount length)
2386 /* Make sure we find out about bad make_string's when they happen */
2387 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2388 bytecount_to_charcount (contents, length); /* Just for the assertions */
2391 val = make_uninit_string (length);
2392 memcpy (XSTRING_DATA (val), contents, length);
2396 /* Take some raw memory, encoded in some external data format,
2397 and convert it into a Lisp string. */
2399 make_ext_string (CONST Extbyte *contents, EMACS_INT length,
2400 enum external_data_format fmt)
2405 GET_CHARPTR_INT_DATA_ALLOCA (contents, length, fmt, intstr, intlen);
2406 return make_string (intstr, intlen);
2410 build_string (CONST char *str)
2412 /* Some strlen's crash and burn if passed null. */
2413 return make_string ((CONST Bufbyte *) str, (str ? strlen(str) : 0));
2417 build_ext_string (CONST char *str, enum external_data_format fmt)
2419 /* Some strlen's crash and burn if passed null. */
2420 return make_ext_string ((CONST Extbyte *) str, (str ? strlen(str) : 0), fmt);
2424 build_translated_string (CONST char *str)
2426 return build_string (GETTEXT (str));
2430 /************************************************************************/
2431 /* lcrecord lists */
2432 /************************************************************************/
2434 /* Lcrecord lists are used to manage the allocation of particular
2435 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2436 malloc() and garbage-collection junk) as much as possible.
2437 It is similar to the Blocktype class.
2441 1) Create an lcrecord-list object using make_lcrecord_list().
2442 This is often done at initialization. Remember to staticpro
2443 this object! The arguments to make_lcrecord_list() are the
2444 same as would be passed to alloc_lcrecord().
2445 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2446 and pass the lcrecord-list earlier created.
2447 3) When done with the lcrecord, call free_managed_lcrecord().
2448 The standard freeing caveats apply: ** make sure there are no
2449 pointers to the object anywhere! **
2450 4) Calling free_managed_lcrecord() is just like kissing the
2451 lcrecord goodbye as if it were garbage-collected. This means:
2452 -- the contents of the freed lcrecord are undefined, and the
2453 contents of something produced by allocate_managed_lcrecord()
2454 are undefined, just like for alloc_lcrecord().
2455 -- the mark method for the lcrecord's type will *NEVER* be called
2457 -- the finalize method for the lcrecord's type will be called
2458 at the time that free_managed_lcrecord() is called.
2463 mark_lcrecord_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
2465 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2466 Lisp_Object chain = list->free;
2468 while (!NILP (chain))
2470 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2471 struct free_lcrecord_header *free_header =
2472 (struct free_lcrecord_header *) lheader;
2474 #ifdef ERROR_CHECK_GC
2475 CONST struct lrecord_implementation *implementation
2476 = LHEADER_IMPLEMENTATION(lheader);
2478 /* There should be no other pointers to the free list. */
2479 assert (!MARKED_RECORD_HEADER_P (lheader));
2480 /* Only lcrecords should be here. */
2481 assert (!implementation->basic_p);
2482 /* Only free lcrecords should be here. */
2483 assert (free_header->lcheader.free);
2484 /* The type of the lcrecord must be right. */
2485 assert (implementation == list->implementation);
2486 /* So must the size. */
2487 assert (implementation->static_size == 0
2488 || implementation->static_size == list->size);
2489 #endif /* ERROR_CHECK_GC */
2491 MARK_RECORD_HEADER (lheader);
2492 chain = free_header->chain;
2498 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2499 mark_lcrecord_list, internal_object_printer,
2500 0, 0, 0, struct lcrecord_list);
2502 make_lcrecord_list (size_t size,
2503 CONST struct lrecord_implementation *implementation)
2505 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2506 lrecord_lcrecord_list);
2509 p->implementation = implementation;
2512 XSETLCRECORD_LIST (val, p);
2517 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2519 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2520 if (!NILP (list->free))
2522 Lisp_Object val = list->free;
2523 struct free_lcrecord_header *free_header =
2524 (struct free_lcrecord_header *) XPNTR (val);
2526 #ifdef ERROR_CHECK_GC
2527 struct lrecord_header *lheader =
2528 (struct lrecord_header *) free_header;
2529 CONST struct lrecord_implementation *implementation
2530 = LHEADER_IMPLEMENTATION (lheader);
2532 /* There should be no other pointers to the free list. */
2533 assert (!MARKED_RECORD_HEADER_P (lheader));
2534 /* Only lcrecords should be here. */
2535 assert (!implementation->basic_p);
2536 /* Only free lcrecords should be here. */
2537 assert (free_header->lcheader.free);
2538 /* The type of the lcrecord must be right. */
2539 assert (implementation == list->implementation);
2540 /* So must the size. */
2541 assert (implementation->static_size == 0
2542 || implementation->static_size == list->size);
2543 #endif /* ERROR_CHECK_GC */
2544 list->free = free_header->chain;
2545 free_header->lcheader.free = 0;
2552 XSETOBJ (val, Lisp_Type_Record,
2553 alloc_lcrecord (list->size, list->implementation));
2559 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2561 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2562 struct free_lcrecord_header *free_header =
2563 (struct free_lcrecord_header *) XPNTR (lcrecord);
2564 struct lrecord_header *lheader =
2565 (struct lrecord_header *) free_header;
2566 CONST struct lrecord_implementation *implementation
2567 = LHEADER_IMPLEMENTATION (lheader);
2569 #ifdef ERROR_CHECK_GC
2570 /* Make sure the size is correct. This will catch, for example,
2571 putting a window configuration on the wrong free list. */
2572 if (implementation->size_in_bytes_method)
2573 assert (implementation->size_in_bytes_method (lheader) == list->size);
2575 assert (implementation->static_size == list->size);
2576 #endif /* ERROR_CHECK_GC */
2578 if (implementation->finalizer)
2579 implementation->finalizer (lheader, 0);
2580 free_header->chain = list->free;
2581 free_header->lcheader.free = 1;
2582 list->free = lcrecord;
2586 /************************************************************************/
2587 /* Purity of essence, peace on earth */
2588 /************************************************************************/
2590 static int symbols_initialized;
2593 make_pure_string (CONST Bufbyte *data, Bytecount length,
2594 Lisp_Object plist, int no_need_to_copy_data)
2597 struct Lisp_String *s;
2598 size_t size = sizeof (struct Lisp_String) +
2599 (no_need_to_copy_data ? 0 : (length + 1)); /* + 1 for terminating 0 */
2600 size = ALIGN_SIZE (size, ALIGNOF (Lisp_Object));
2602 if (symbols_initialized && !pure_lossage)
2604 /* Try to share some names. Saves a few kbytes. */
2605 Lisp_Object tem = oblookup (Vobarray, data, length);
2608 s = XSYMBOL (tem)->name;
2609 if (!PURIFIED (s)) abort ();
2610 XSETSTRING (new, s);
2615 if (!check_purespace (size))
2616 return make_string (data, length);
2618 s = (struct Lisp_String *) (PUREBEG + pure_bytes_used);
2619 #ifdef LRECORD_STRING
2620 set_lheader_implementation (&(s->lheader), lrecord_string);
2621 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2622 s->lheader.pure = 1;
2625 set_string_length (s, length);
2626 if (no_need_to_copy_data)
2628 set_string_data (s, (Bufbyte *) data);
2632 set_string_data (s, (Bufbyte *) s + sizeof (struct Lisp_String));
2633 memcpy (string_data (s), data, length);
2634 set_string_byte (s, length, 0);
2637 pure_bytes_used += size;
2640 bump_purestat (&purestat_string_all, size);
2641 if (purecopying_function_constants)
2642 bump_purestat (&purestat_string_other_function, size);
2643 #endif /* PURESTAT */
2645 /* Do this after the official "completion" of the purecopying. */
2646 s->plist = Fpurecopy (plist);
2648 XSETSTRING (new, s);
2654 make_pure_pname (CONST Bufbyte *data, Bytecount length,
2655 int no_need_to_copy_data)
2657 Lisp_Object name = make_pure_string (data, length, Qnil,
2658 no_need_to_copy_data);
2659 bump_purestat (&purestat_string_pname, pure_sizeof (name));
2661 /* We've made (at least) Qnil now, and Vobarray will soon be set up. */
2662 symbols_initialized = 1;
2669 pure_cons (Lisp_Object car, Lisp_Object cdr)
2672 struct Lisp_Cons *c;
2674 if (!check_purespace (sizeof (struct Lisp_Cons)))
2675 return Fcons (Fpurecopy (car), Fpurecopy (cdr));
2677 c = (struct Lisp_Cons *) (PUREBEG + pure_bytes_used);
2679 set_lheader_implementation (&(c->lheader), lrecord_cons);
2680 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2681 c->lheader.pure = 1;
2684 pure_bytes_used += sizeof (struct Lisp_Cons);
2685 bump_purestat (&purestat_cons, sizeof (struct Lisp_Cons));
2687 c->car = Fpurecopy (car);
2688 c->cdr = Fpurecopy (cdr);
2694 pure_list (int nargs, Lisp_Object *args)
2696 Lisp_Object val = Qnil;
2698 for (--nargs; nargs >= 0; nargs--)
2699 val = pure_cons (args[nargs], val);
2704 #ifdef LISP_FLOAT_TYPE
2707 make_pure_float (double num)
2709 struct Lisp_Float *f;
2712 /* Make sure that PUREBEG + pure_bytes_used is aligned on at least a sizeof
2713 (double) boundary. Some architectures (like the sparc) require
2714 this, and I suspect that floats are rare enough that it's no
2715 tragedy for those that don't. */
2717 #if defined (__GNUC__) && (__GNUC__ >= 2)
2718 /* In gcc, we can directly ask what the alignment constraints of a
2719 structure are, but in general, that's not possible... Arrgh!!
2721 int alignment = __alignof (struct Lisp_Float);
2723 /* Best guess is to make the `double' slot be aligned to the size
2724 of double (which is probably 8 bytes). This assumes that it's
2725 ok to align the beginning of the structure to the same boundary
2726 that the `double' slot in it is supposed to be aligned to; this
2727 should be ok because presumably there is padding in the layout
2728 of the struct to account for this.
2730 int alignment = sizeof (float_data (f));
2732 char *p = ((char *) PUREBEG + pure_bytes_used);
2734 p = (char *) (((EMACS_UINT) p + alignment - 1) & - alignment);
2735 pure_bytes_used = p - (char *) PUREBEG;
2738 if (!check_purespace (sizeof (struct Lisp_Float)))
2739 return make_float (num);
2741 f = (struct Lisp_Float *) (PUREBEG + pure_bytes_used);
2742 set_lheader_implementation (&(f->lheader), lrecord_float);
2743 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2744 f->lheader.pure = 1;
2746 pure_bytes_used += sizeof (struct Lisp_Float);
2747 bump_purestat (&purestat_float, sizeof (struct Lisp_Float));
2749 float_data (f) = num;
2754 #endif /* LISP_FLOAT_TYPE */
2757 make_pure_vector (size_t len, Lisp_Object init)
2761 size_t size = offsetof (Lisp_Vector, contents[len]);
2763 init = Fpurecopy (init);
2765 if (!check_purespace (size))
2766 return make_vector (len, init);
2768 v = (Lisp_Vector *) (PUREBEG + pure_bytes_used);
2769 #ifdef LRECORD_VECTOR
2770 set_lheader_implementation (&(v->header.lheader), lrecord_vector);
2771 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2772 v->header.lheader.pure = 1;
2775 pure_bytes_used += size;
2776 bump_purestat (&purestat_vector_all, size);
2780 for (size = 0; size < len; size++)
2781 v->contents[size] = init;
2783 XSETVECTOR (new, v);
2788 /* Presently unused */
2790 alloc_pure_lrecord (int size, struct lrecord_implementation *implementation)
2792 struct lrecord_header *header = (void *) (PUREBEG + pure_bytes_used);
2794 if (pure_bytes_used + size > get_PURESIZE())
2795 pure_storage_exhausted ();
2797 set_lheader_implementation (header, implementation);
2805 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2806 Make a copy of OBJECT in pure storage.
2807 Recursively copies contents of vectors and cons cells.
2808 Does not copy symbols.
2816 else if (!POINTER_TYPE_P (XTYPE (obj))
2817 || PURIFIED (XPNTR (obj))
2818 /* happens when bootstrapping Qnil */
2819 || EQ (obj, Qnull_pointer))
2823 /* Order of subsequent tests determined via profiling. */
2824 else if (SYMBOLP (obj))
2826 /* Symbols can't be made pure (and thus read-only), because
2827 assigning to their function, value or plist slots would
2828 produced a SEGV in the dumped XEmacs. So we previously would
2829 just return the symbol unchanged.
2831 But purified aggregate objects like lists and vectors can
2832 contain uninterned symbols. If there are no other non-pure
2833 references to the symbol, then the symbol is not protected
2834 from garbage collection because the collector does not mark
2835 the contents of purified objects. So to protect the symbols,
2836 an impure reference has to be kept for each uninterned symbol
2837 that is referenced by a pure object. All such symbols are
2838 stored in the hash table pointed to by
2839 Vpure_uninterned_symbol_table, which is itself
2841 if (NILP (XSYMBOL (obj)->obarray))
2842 Fputhash (obj, Qnil, Vpure_uninterned_symbol_table);
2845 else if (CONSP (obj))
2847 return pure_cons (XCAR (obj), XCDR (obj));
2849 else if (STRINGP (obj))
2851 return make_pure_string (XSTRING_DATA (obj),
2852 XSTRING_LENGTH (obj),
2853 XSTRING (obj)->plist,
2856 else if (VECTORP (obj))
2859 Lisp_Vector *o = XVECTOR (obj);
2860 Lisp_Object pure_obj = make_pure_vector (vector_length (o), Qnil);
2861 for (i = 0; i < vector_length (o); i++)
2862 XVECTOR_DATA (pure_obj)[i] = Fpurecopy (o->contents[i]);
2865 #ifdef LISP_FLOAT_TYPE
2866 else if (FLOATP (obj))
2868 return make_pure_float (XFLOAT_DATA (obj));
2871 else if (COMPILED_FUNCTIONP (obj))
2873 Lisp_Object pure_obj = make_compiled_function (1);
2874 Lisp_Compiled_Function *o = XCOMPILED_FUNCTION (obj);
2875 Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (pure_obj);
2876 n->flags = o->flags;
2877 n->instructions = o->instructions;
2878 n->constants = Fpurecopy (o->constants);
2879 n->arglist = Fpurecopy (o->arglist);
2880 n->doc_and_interactive = Fpurecopy (o->doc_and_interactive);
2881 n->stack_depth = o->stack_depth;
2882 optimize_compiled_function (pure_obj);
2885 else if (OPAQUEP (obj))
2887 Lisp_Object pure_obj;
2888 Lisp_Opaque *old_opaque = XOPAQUE (obj);
2889 Lisp_Opaque *new_opaque = (Lisp_Opaque *) (PUREBEG + pure_bytes_used);
2890 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2891 CONST struct lrecord_implementation *implementation
2892 = LHEADER_IMPLEMENTATION (lheader);
2893 size_t size = implementation->size_in_bytes_method (lheader);
2894 size_t pure_size = ALIGN_SIZE (size, ALIGNOF (Lisp_Object));
2895 if (!check_purespace (pure_size))
2897 pure_bytes_used += pure_size;
2899 memcpy (new_opaque, old_opaque, size);
2900 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2903 new_opaque->header.next = 0;
2905 XSETOPAQUE (pure_obj, new_opaque);
2910 signal_simple_error ("Can't purecopy %S", obj);
2912 return obj; /* Unreached */
2918 puresize_adjust_h (size_t puresize)
2920 FILE *stream = fopen ("puresize-adjust.h", "w");
2923 report_file_error ("Opening puresize adjustment file",
2924 Fcons (build_string ("puresize-adjust.h"), Qnil));
2927 "/*\tDo not edit this file!\n"
2928 "\tAutomatically generated by XEmacs */\n"
2929 "# define PURESIZE_ADJUSTMENT (%ld)\n",
2930 (long) (puresize - RAW_PURESIZE));
2935 report_pure_usage (int report_impurities,
2936 int die_if_pure_storage_exceeded)
2942 message ("\n****\tPure Lisp storage exhausted!\n"
2943 "\tPurespace usage: %ld of %ld\n"
2945 (long) get_PURESIZE() + pure_lossage,
2946 (long) get_PURESIZE());
2947 if (die_if_pure_storage_exceeded)
2949 puresize_adjust_h (get_PURESIZE() + pure_lossage);
2958 size_t lost = (get_PURESIZE() - pure_bytes_used) / 1024;
2960 /* extern Lisp_Object Vemacs_beta_version; */
2961 /* This used to be NILP(Vemacs_beta_version) ? 512 : 4; */
2962 #ifndef PURESIZE_SLOP
2963 #define PURESIZE_SLOP 0
2965 size_t slop = PURESIZE_SLOP;
2967 sprintf (buf, "Purespace usage: %ld of %ld (%d%%",
2968 (long) pure_bytes_used,
2969 (long) get_PURESIZE(),
2970 (int) (pure_bytes_used / (get_PURESIZE() / 100.0) + 0.5));
2971 if (lost > ((slop ? slop : 1) / 1024)) {
2972 sprintf (buf + strlen (buf), " -- %ldk wasted", (long)lost);
2973 if (die_if_pure_storage_exceeded) {
2974 puresize_adjust_h (pure_bytes_used + slop);
2983 message ("%s", buf);
2988 purestat_vector_other.nbytes =
2989 purestat_vector_all.nbytes -
2990 purestat_vector_constants.nbytes;
2991 purestat_vector_other.nobjects =
2992 purestat_vector_all.nobjects -
2993 purestat_vector_constants.nobjects;
2995 purestat_string_other.nbytes =
2996 purestat_string_all.nbytes -
2997 (purestat_string_pname.nbytes +
2998 purestat_string_interactive.nbytes +
2999 purestat_string_documentation.nbytes +
3001 purestat_string_domain.nbytes +
3003 purestat_string_other_function.nbytes);
3005 purestat_string_other.nobjects =
3006 purestat_string_all.nobjects -
3007 (purestat_string_pname.nobjects +
3008 purestat_string_interactive.nobjects +
3009 purestat_string_documentation.nobjects +
3011 purestat_string_domain.nobjects +
3013 purestat_string_other_function.nobjects);
3015 message (" %-34s Objects Bytes", "");
3017 print_purestat (&purestat_cons);
3018 print_purestat (&purestat_float);
3019 print_purestat (&purestat_string_pname);
3020 print_purestat (&purestat_function);
3021 print_purestat (&purestat_opaque_instructions);
3022 print_purestat (&purestat_vector_constants);
3023 print_purestat (&purestat_string_interactive);
3025 print_purestat (&purestat_string_domain);
3027 print_purestat (&purestat_string_documentation);
3028 print_purestat (&purestat_string_other_function);
3029 print_purestat (&purestat_vector_other);
3030 print_purestat (&purestat_string_other);
3031 print_purestat (&purestat_string_all);
3032 print_purestat (&purestat_vector_all);
3034 #endif /* PURESTAT */
3037 if (report_impurities)
3040 struct gcpro gcpro1;
3041 plist = XCAR (XCDR (XCDR (XCDR (XCDR (XCDR (Fgarbage_collect()))))));
3043 message ("\nImpurities:");
3044 for (; CONSP (plist); plist = XCDR (XCDR (plist)))
3046 Lisp_Object symbol = XCAR (plist);
3047 int size = XINT (XCAR (XCDR (plist)));
3053 string_data (XSYMBOL (symbol)->name),
3054 string_length (XSYMBOL (symbol)->name) + 1);
3055 while (*s++) if (*s == '-') *s = ' ';
3056 *(s-1) = ':'; *s = 0;
3057 message (" %-34s %6d", buf, size);
3061 garbage_collect_1 (); /* collect Fgarbage_collect()'s garbage */
3066 unlink("SATISFIED");
3067 fatal ("Pure size adjusted, Don't Panic! I will restart the `make'");
3068 } else if (pure_lossage && die_if_pure_storage_exceeded) {
3069 fatal ("Pure storage exhausted");
3074 /************************************************************************/
3075 /* Garbage Collection */
3076 /************************************************************************/
3078 /* This will be used more extensively In The Future */
3079 static int last_lrecord_type_index_assigned;
3081 CONST struct lrecord_implementation *lrecord_implementations_table[128];
3082 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
3084 struct gcpro *gcprolist;
3086 /* 415 used Mly 29-Jun-93 */
3087 /* 1327 used slb 28-Feb-98 */
3089 #define NSTATICS 4000
3091 #define NSTATICS 2000
3093 /* Not "static" because of linker lossage on some systems */
3094 Lisp_Object *staticvec[NSTATICS]
3095 /* Force it into data space! */
3097 static int staticidx;
3099 /* Put an entry in staticvec, pointing at the variable whose address is given
3102 staticpro (Lisp_Object *varaddress)
3104 if (staticidx >= countof (staticvec))
3105 /* #### This is now a dubious abort() since this routine may be called */
3106 /* by Lisp attempting to load a DLL. */
3108 staticvec[staticidx++] = varaddress;
3112 /* Mark reference to a Lisp_Object. If the object referred to has not been
3113 seen yet, recursively mark all the references contained in it. */
3116 mark_object (Lisp_Object obj)
3120 #ifdef ERROR_CHECK_GC
3121 assert (! (GC_EQ (obj, Qnull_pointer)));
3123 /* Checks we used to perform */
3124 /* if (EQ (obj, Qnull_pointer)) return; */
3125 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3126 /* if (PURIFIED (XPNTR (obj))) return; */
3128 switch (XGCTYPE (obj))
3130 #ifndef LRECORD_CONS
3131 case Lisp_Type_Cons:
3133 struct Lisp_Cons *ptr = XCONS (obj);
3136 if (CONS_MARKED_P (ptr))
3139 /* If the cdr is nil, tail-recurse on the car. */
3140 if (GC_NILP (ptr->cdr))
3146 mark_object (ptr->car);
3153 case Lisp_Type_Record:
3155 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3156 #if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION)
3157 assert (lheader->type <= last_lrecord_type_index_assigned);
3159 if (PURIFIED (lheader))
3162 if (! MARKED_RECORD_HEADER_P (lheader) &&
3163 ! UNMARKABLE_RECORD_HEADER_P (lheader))
3165 CONST struct lrecord_implementation *implementation =
3166 LHEADER_IMPLEMENTATION (lheader);
3167 MARK_RECORD_HEADER (lheader);
3168 #ifdef ERROR_CHECK_GC
3169 if (!implementation->basic_p)
3170 assert (! ((struct lcrecord_header *) lheader)->free);
3172 if (implementation->marker)
3174 obj = implementation->marker (obj, mark_object);
3175 if (!GC_NILP (obj)) goto tail_recurse;
3181 #ifndef LRECORD_STRING
3182 case Lisp_Type_String:
3184 struct Lisp_String *ptr = XSTRING (obj);
3188 if (!XMARKBIT (ptr->plist))
3190 if (CONSP (ptr->plist) &&
3191 EXTENT_INFOP (XCAR (ptr->plist)))
3192 flush_cached_extent_info (XCAR (ptr->plist));
3199 #endif /* ! LRECORD_STRING */
3201 #ifndef LRECORD_VECTOR
3202 case Lisp_Type_Vector:
3204 struct Lisp_Vector *ptr = XVECTOR (obj);
3210 len = vector_length (ptr);
3213 break; /* Already marked */
3214 ptr->size = -1 - len; /* Else mark it */
3215 for (i = 0; i < len - 1; i++) /* and then mark its elements */
3216 mark_object (ptr->contents[i]);
3219 obj = ptr->contents[len - 1];
3224 #endif /* !LRECORD_VECTOR */
3226 #ifndef LRECORD_SYMBOL
3227 case Lisp_Type_Symbol:
3229 struct Lisp_Symbol *sym = XSYMBOL (obj);
3234 while (!XMARKBIT (sym->plist))
3237 mark_object (sym->value);
3238 mark_object (sym->function);
3241 * symbol->name is a struct Lisp_String *, not a
3242 * Lisp_Object. Fix it up and pass to mark_object.
3244 Lisp_Object symname;
3245 XSETSTRING (symname, sym->name);
3246 mark_object (symname);
3248 if (!symbol_next (sym))
3253 mark_object (sym->plist);
3254 /* Mark the rest of the symbols in the hash-chain */
3255 sym = symbol_next (sym);
3259 #endif /* !LRECORD_SYMBOL */
3261 /* Check for invalid Lisp_Object types */
3262 #if defined (ERROR_CHECK_GC) && ! defined (USE_MINIMAL_TAGBITS)
3264 case Lisp_Type_Char:
3269 #endif /* ERROR_CHECK_GC && ! USE_MINIMAL_TAGBITS */
3273 /* mark all of the conses in a list and mark the final cdr; but
3274 DO NOT mark the cars.
3276 Use only for internal lists! There should never be other pointers
3277 to the cons cells, because if so, the cars will remain unmarked
3278 even when they maybe should be marked. */
3280 mark_conses_in_list (Lisp_Object obj)
3284 for (rest = obj; CONSP (rest); rest = XCDR (rest))
3286 if (CONS_MARKED_P (XCONS (rest)))
3288 MARK_CONS (XCONS (rest));
3296 /* Simpler than mark-object, because pure structure can't
3297 have any circularities */
3300 pure_string_sizeof (Lisp_Object obj)
3302 struct Lisp_String *ptr = XSTRING (obj);
3304 if (string_data (ptr) != (Bufbyte *) ptr + sizeof (*ptr))
3306 /* string-data not allocated contiguously.
3307 Probably (better be!!) a pointer constant "C" data. */
3308 return sizeof (*ptr);
3312 size_t size = sizeof (*ptr) + string_length (ptr) + 1;
3313 size = ALIGN_SIZE (size, sizeof (Lisp_Object));
3319 pure_sizeof (Lisp_Object obj)
3321 if (!POINTER_TYPE_P (XTYPE (obj))
3322 || !PURIFIED (XPNTR (obj)))
3324 /* symbol sizes are accounted for separately */
3325 else if (SYMBOLP (obj))
3327 else if (STRINGP (obj))
3328 return pure_string_sizeof (obj);
3329 else if (LRECORDP (obj))
3331 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3332 CONST struct lrecord_implementation *implementation
3333 = LHEADER_IMPLEMENTATION (lheader);
3335 return implementation->size_in_bytes_method
3336 ? implementation->size_in_bytes_method (lheader)
3337 : implementation->static_size;
3339 #ifndef LRECORD_VECTOR
3340 else if (VECTORP (obj))
3341 return offsetof (Lisp_Vector, contents[XVECTOR_LENGTH (obj)]);
3342 #endif /* !LRECORD_VECTOR */
3344 #ifndef LRECORD_CONS
3345 else if (CONSP (obj))
3346 return sizeof (struct Lisp_Cons);
3347 #endif /* !LRECORD_CONS */
3349 /* Others can't be purified */
3351 return 0; /* unreached */
3353 #endif /* PURESTAT */
3358 /* Find all structures not marked, and free them. */
3360 #ifndef LRECORD_VECTOR
3361 static int gc_count_num_vector_used, gc_count_vector_total_size;
3362 static int gc_count_vector_storage;
3364 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
3365 static int gc_count_bit_vector_storage;
3366 static int gc_count_num_short_string_in_use;
3367 static int gc_count_string_total_size;
3368 static int gc_count_short_string_total_size;
3370 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3374 lrecord_type_index (CONST struct lrecord_implementation *implementation)
3376 int type_index = *(implementation->lrecord_type_index);
3377 /* Have to do this circuitous validation test because of problems
3378 dumping out initialized variables (ie can't set xxx_type_index to -1
3379 because that would make xxx_type_index read-only in a dumped emacs. */
3380 if (type_index < 0 || type_index > max_lrecord_type
3381 || lrecord_implementations_table[type_index] != implementation)
3383 if (last_lrecord_type_index_assigned == max_lrecord_type)
3385 type_index = ++last_lrecord_type_index_assigned;
3386 lrecord_implementations_table[type_index] = implementation;
3387 *(implementation->lrecord_type_index) = type_index;
3392 /* stats on lcrecords in use - kinda kludgy */
3396 int instances_in_use;
3398 int instances_freed;
3400 int instances_on_free_list;
3401 } lcrecord_stats [countof (lrecord_implementations_table)];
3405 reset_lcrecord_stats (void)
3408 for (i = 0; i < countof (lcrecord_stats); i++)
3410 lcrecord_stats[i].instances_in_use = 0;
3411 lcrecord_stats[i].bytes_in_use = 0;
3412 lcrecord_stats[i].instances_freed = 0;
3413 lcrecord_stats[i].bytes_freed = 0;
3414 lcrecord_stats[i].instances_on_free_list = 0;
3419 tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p)
3421 CONST struct lrecord_implementation *implementation =
3422 LHEADER_IMPLEMENTATION (h);
3423 int type_index = lrecord_type_index (implementation);
3425 if (((struct lcrecord_header *) h)->free)
3428 lcrecord_stats[type_index].instances_on_free_list++;
3432 size_t sz = (implementation->size_in_bytes_method
3433 ? implementation->size_in_bytes_method (h)
3434 : implementation->static_size);
3438 lcrecord_stats[type_index].instances_freed++;
3439 lcrecord_stats[type_index].bytes_freed += sz;
3443 lcrecord_stats[type_index].instances_in_use++;
3444 lcrecord_stats[type_index].bytes_in_use += sz;
3450 /* Free all unmarked records */
3452 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
3454 struct lcrecord_header *header;
3456 /* int total_size = 0; */
3457 reset_lcrecord_stats ();
3459 /* First go through and call all the finalize methods.
3460 Then go through and free the objects. There used to
3461 be only one loop here, with the call to the finalizer
3462 occurring directly before the xfree() below. That
3463 is marginally faster but much less safe -- if the
3464 finalize method for an object needs to reference any
3465 other objects contained within it (and many do),
3466 we could easily be screwed by having already freed that
3469 for (header = *prev; header; header = header->next)
3471 struct lrecord_header *h = &(header->lheader);
3472 if (!MARKED_RECORD_HEADER_P (h) && ! (header->free))
3474 if (LHEADER_IMPLEMENTATION (h)->finalizer)
3475 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
3479 for (header = *prev; header; )
3481 struct lrecord_header *h = &(header->lheader);
3482 if (MARKED_RECORD_HEADER_P (h))
3484 UNMARK_RECORD_HEADER (h);
3486 /* total_size += n->implementation->size_in_bytes (h);*/
3487 prev = &(header->next);
3489 tick_lcrecord_stats (h, 0);
3493 struct lcrecord_header *next = header->next;
3495 tick_lcrecord_stats (h, 1);
3496 /* used to call finalizer right here. */
3502 /* *total = total_size; */
3505 #ifndef LRECORD_VECTOR
3508 sweep_vectors_1 (Lisp_Object *prev,
3509 int *used, int *total, int *storage)
3514 int total_storage = 0;
3516 for (vector = *prev; VECTORP (vector); )
3518 Lisp_Vector *v = XVECTOR (vector);
3520 if (len < 0) /* marked */
3526 MALLOC_OVERHEAD + offsetof (Lisp_Vector, contents[len + 1]);
3528 prev = &(vector_next (v));
3533 Lisp_Object next = vector_next (v);
3540 *total = total_size;
3541 *storage = total_storage;
3544 #endif /* ! LRECORD_VECTOR */
3547 sweep_bit_vectors_1 (Lisp_Object *prev,
3548 int *used, int *total, int *storage)
3550 Lisp_Object bit_vector;
3553 int total_storage = 0;
3555 /* BIT_VECTORP fails because the objects are marked, which changes
3556 their implementation */
3557 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
3559 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
3561 if (MARKED_RECORD_P (bit_vector))
3563 UNMARK_RECORD_HEADER (&(v->lheader));
3567 + offsetof (Lisp_Bit_Vector, bits[BIT_VECTOR_LONG_STORAGE (len)]);
3569 prev = &(bit_vector_next (v));
3574 Lisp_Object next = bit_vector_next (v);
3581 *total = total_size;
3582 *storage = total_storage;
3585 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3586 to make macros prettier. */
3588 #ifdef ERROR_CHECK_GC
3590 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3592 struct typename##_block *SFTB_current; \
3593 struct typename##_block **SFTB_prev; \
3595 int num_free = 0, num_used = 0; \
3597 for (SFTB_prev = ¤t_##typename##_block, \
3598 SFTB_current = current_##typename##_block, \
3599 SFTB_limit = current_##typename##_block_index; \
3605 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
3607 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
3609 if (FREE_STRUCT_P (SFTB_victim)) \
3613 else if (!MARKED_##typename##_P (SFTB_victim)) \
3616 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
3621 UNMARK_##typename (SFTB_victim); \
3624 SFTB_prev = &(SFTB_current->prev); \
3625 SFTB_current = SFTB_current->prev; \
3626 SFTB_limit = countof (current_##typename##_block->block); \
3629 gc_count_num_##typename##_in_use = num_used; \
3630 gc_count_num_##typename##_freelist = num_free; \
3633 #else /* !ERROR_CHECK_GC */
3635 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3637 struct typename##_block *SFTB_current; \
3638 struct typename##_block **SFTB_prev; \
3640 int num_free = 0, num_used = 0; \
3642 typename##_free_list = 0; \
3644 for (SFTB_prev = ¤t_##typename##_block, \
3645 SFTB_current = current_##typename##_block, \
3646 SFTB_limit = current_##typename##_block_index; \
3651 int SFTB_empty = 1; \
3652 obj_type *SFTB_old_free_list = typename##_free_list; \
3654 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
3656 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
3658 if (FREE_STRUCT_P (SFTB_victim)) \
3661 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
3663 else if (!MARKED_##typename##_P (SFTB_victim)) \
3666 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
3672 UNMARK_##typename (SFTB_victim); \
3677 SFTB_prev = &(SFTB_current->prev); \
3678 SFTB_current = SFTB_current->prev; \
3680 else if (SFTB_current == current_##typename##_block \
3681 && !SFTB_current->prev) \
3683 /* No real point in freeing sole allocation block */ \
3688 struct typename##_block *SFTB_victim_block = SFTB_current; \
3689 if (SFTB_victim_block == current_##typename##_block) \
3690 current_##typename##_block_index \
3691 = countof (current_##typename##_block->block); \
3692 SFTB_current = SFTB_current->prev; \
3694 *SFTB_prev = SFTB_current; \
3695 xfree (SFTB_victim_block); \
3696 /* Restore free list to what it was before victim was swept */ \
3697 typename##_free_list = SFTB_old_free_list; \
3698 num_free -= SFTB_limit; \
3701 SFTB_limit = countof (current_##typename##_block->block); \
3704 gc_count_num_##typename##_in_use = num_used; \
3705 gc_count_num_##typename##_freelist = num_free; \
3708 #endif /* !ERROR_CHECK_GC */
3716 #ifndef LRECORD_CONS
3717 # define MARKED_cons_P(ptr) XMARKBIT ((ptr)->car)
3718 # define UNMARK_cons(ptr) do { XUNMARK ((ptr)->car); } while (0)
3719 #else /* LRECORD_CONS */
3720 # define MARKED_cons_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3721 # define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3722 #endif /* LRECORD_CONS */
3723 #define ADDITIONAL_FREE_cons(ptr)
3725 SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons);
3728 /* Explicitly free a cons cell. */
3730 free_cons (struct Lisp_Cons *ptr)
3732 #ifdef ERROR_CHECK_GC
3733 /* If the CAR is not an int, then it will be a pointer, which will
3734 always be four-byte aligned. If this cons cell has already been
3735 placed on the free list, however, its car will probably contain
3736 a chain pointer to the next cons on the list, which has cleverly
3737 had all its 0's and 1's inverted. This allows for a quick
3738 check to make sure we're not freeing something already freed. */
3739 if (POINTER_TYPE_P (XTYPE (ptr->car)))
3740 ASSERT_VALID_POINTER (XPNTR (ptr->car));
3741 #endif /* ERROR_CHECK_GC */
3743 #ifndef ALLOC_NO_POOLS
3744 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, struct Lisp_Cons, ptr);
3745 #endif /* ALLOC_NO_POOLS */
3748 /* explicitly free a list. You **must make sure** that you have
3749 created all the cons cells that make up this list and that there
3750 are no pointers to any of these cons cells anywhere else. If there
3751 are, you will lose. */
3754 free_list (Lisp_Object list)
3756 Lisp_Object rest, next;
3758 for (rest = list; !NILP (rest); rest = next)
3761 free_cons (XCONS (rest));
3765 /* explicitly free an alist. You **must make sure** that you have
3766 created all the cons cells that make up this alist and that there
3767 are no pointers to any of these cons cells anywhere else. If there
3768 are, you will lose. */
3771 free_alist (Lisp_Object alist)
3773 Lisp_Object rest, next;
3775 for (rest = alist; !NILP (rest); rest = next)
3778 free_cons (XCONS (XCAR (rest)));
3779 free_cons (XCONS (rest));
3784 sweep_compiled_functions (void)
3786 #define MARKED_compiled_function_P(ptr) \
3787 MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3788 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3789 #define ADDITIONAL_FREE_compiled_function(ptr)
3791 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
3795 #ifdef LISP_FLOAT_TYPE
3799 #define MARKED_float_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3800 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3801 #define ADDITIONAL_FREE_float(ptr)
3803 SWEEP_FIXED_TYPE_BLOCK (float, struct Lisp_Float);
3805 #endif /* LISP_FLOAT_TYPE */
3808 sweep_symbols (void)
3810 #ifndef LRECORD_SYMBOL
3811 # define MARKED_symbol_P(ptr) XMARKBIT ((ptr)->plist)
3812 # define UNMARK_symbol(ptr) do { XUNMARK ((ptr)->plist); } while (0)
3814 # define MARKED_symbol_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3815 # define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3816 #endif /* !LRECORD_SYMBOL */
3817 #define ADDITIONAL_FREE_symbol(ptr)
3819 SWEEP_FIXED_TYPE_BLOCK (symbol, struct Lisp_Symbol);
3823 sweep_extents (void)
3825 #define MARKED_extent_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3826 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3827 #define ADDITIONAL_FREE_extent(ptr)
3829 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
3835 #define MARKED_event_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3836 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3837 #define ADDITIONAL_FREE_event(ptr)
3839 SWEEP_FIXED_TYPE_BLOCK (event, struct Lisp_Event);
3843 sweep_markers (void)
3845 #define MARKED_marker_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3846 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3847 #define ADDITIONAL_FREE_marker(ptr) \
3848 do { Lisp_Object tem; \
3849 XSETMARKER (tem, ptr); \
3850 unchain_marker (tem); \
3853 SWEEP_FIXED_TYPE_BLOCK (marker, struct Lisp_Marker);
3856 /* Explicitly free a marker. */
3858 free_marker (struct Lisp_Marker *ptr)
3860 #ifdef ERROR_CHECK_GC
3861 /* Perhaps this will catch freeing an already-freed marker. */
3863 XSETMARKER (temmy, ptr);
3864 assert (GC_MARKERP (temmy));
3865 #endif /* ERROR_CHECK_GC */
3867 #ifndef ALLOC_NO_POOLS
3868 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr);
3869 #endif /* ALLOC_NO_POOLS */
3873 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
3876 verify_string_chars_integrity (void)
3878 struct string_chars_block *sb;
3880 /* Scan each existing string block sequentially, string by string. */
3881 for (sb = first_string_chars_block; sb; sb = sb->next)
3884 /* POS is the index of the next string in the block. */
3885 while (pos < sb->pos)
3887 struct string_chars *s_chars =
3888 (struct string_chars *) &(sb->string_chars[pos]);
3889 struct Lisp_String *string;
3893 /* If the string_chars struct is marked as free (i.e. the STRING
3894 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3895 storage. (See below.) */
3897 if (FREE_STRUCT_P (s_chars))
3899 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3904 string = s_chars->string;
3905 /* Must be 32-bit aligned. */
3906 assert ((((int) string) & 3) == 0);
3908 size = string_length (string);
3909 fullsize = STRING_FULLSIZE (size);
3911 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3912 assert (string_data (string) == s_chars->chars);
3915 assert (pos == sb->pos);
3919 #endif /* MULE && ERROR_CHECK_GC */
3921 /* Compactify string chars, relocating the reference to each --
3922 free any empty string_chars_block we see. */
3924 compact_string_chars (void)
3926 struct string_chars_block *to_sb = first_string_chars_block;
3928 struct string_chars_block *from_sb;
3930 /* Scan each existing string block sequentially, string by string. */
3931 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3934 /* FROM_POS is the index of the next string in the block. */
3935 while (from_pos < from_sb->pos)
3937 struct string_chars *from_s_chars =
3938 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3939 struct string_chars *to_s_chars;
3940 struct Lisp_String *string;
3944 /* If the string_chars struct is marked as free (i.e. the STRING
3945 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3946 storage. This happens under Mule when a string's size changes
3947 in such a way that its fullsize changes. (Strings can change
3948 size because a different-length character can be substituted
3949 for another character.) In this case, after the bogus string
3950 pointer is the "fullsize" of this entry, i.e. how many bytes
3953 if (FREE_STRUCT_P (from_s_chars))
3955 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3956 from_pos += fullsize;
3960 string = from_s_chars->string;
3961 assert (!(FREE_STRUCT_P (string)));
3963 size = string_length (string);
3964 fullsize = STRING_FULLSIZE (size);
3966 if (BIG_STRING_FULLSIZE_P (fullsize))
3969 /* Just skip it if it isn't marked. */
3970 #ifdef LRECORD_STRING
3971 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3973 if (!XMARKBIT (string->plist))
3976 from_pos += fullsize;
3980 /* If it won't fit in what's left of TO_SB, close TO_SB out
3981 and go on to the next string_chars_block. We know that TO_SB
3982 cannot advance past FROM_SB here since FROM_SB is large enough
3983 to currently contain this string. */
3984 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3986 to_sb->pos = to_pos;
3987 to_sb = to_sb->next;
3991 /* Compute new address of this string
3992 and update TO_POS for the space being used. */
3993 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3995 /* Copy the string_chars to the new place. */
3996 if (from_s_chars != to_s_chars)
3997 memmove (to_s_chars, from_s_chars, fullsize);
3999 /* Relocate FROM_S_CHARS's reference */
4000 set_string_data (string, &(to_s_chars->chars[0]));
4002 from_pos += fullsize;
4007 /* Set current to the last string chars block still used and
4008 free any that follow. */
4010 struct string_chars_block *victim;
4012 for (victim = to_sb->next; victim; )
4014 struct string_chars_block *next = victim->next;
4019 current_string_chars_block = to_sb;
4020 current_string_chars_block->pos = to_pos;
4021 current_string_chars_block->next = 0;
4025 #if 1 /* Hack to debug missing purecopy's */
4026 static int debug_string_purity;
4029 debug_string_purity_print (struct Lisp_String *p)
4032 Charcount s = string_char_length (p);
4033 putc ('\"', stderr);
4034 for (i = 0; i < s; i++)
4036 Emchar ch = string_char (p, i);
4037 if (ch < 32 || ch >= 126)
4038 stderr_out ("\\%03o", ch);
4039 else if (ch == '\\' || ch == '\"')
4040 stderr_out ("\\%c", ch);
4042 stderr_out ("%c", ch);
4044 stderr_out ("\"\n");
4050 sweep_strings (void)
4052 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
4053 int debug = debug_string_purity;
4055 #ifdef LRECORD_STRING
4057 # define MARKED_string_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
4058 # define UNMARK_string(ptr) \
4059 do { struct Lisp_String *p = (ptr); \
4060 int size = string_length (p); \
4061 UNMARK_RECORD_HEADER (&(p->lheader)); \
4062 num_bytes += size; \
4063 if (!BIG_STRING_SIZE_P (size)) \
4064 { num_small_bytes += size; \
4067 if (debug) debug_string_purity_print (p); \
4069 # define ADDITIONAL_FREE_string(p) \
4070 do { int size = string_length (p); \
4071 if (BIG_STRING_SIZE_P (size)) \
4072 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
4077 # define MARKED_string_P(ptr) XMARKBIT ((ptr)->plist)
4078 # define UNMARK_string(ptr) \
4079 do { struct Lisp_String *p = (ptr); \
4080 int size = string_length (p); \
4081 XUNMARK (p->plist); \
4082 num_bytes += size; \
4083 if (!BIG_STRING_SIZE_P (size)) \
4084 { num_small_bytes += size; \
4087 if (debug) debug_string_purity_print (p); \
4089 # define ADDITIONAL_FREE_string(p) \
4090 do { int size = string_length (p); \
4091 if (BIG_STRING_SIZE_P (size)) \
4092 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
4095 #endif /* ! LRECORD_STRING */
4097 SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String);
4099 gc_count_num_short_string_in_use = num_small_used;
4100 gc_count_string_total_size = num_bytes;
4101 gc_count_short_string_total_size = num_small_bytes;
4105 /* I hate duplicating all this crap! */
4107 marked_p (Lisp_Object obj)
4109 #ifdef ERROR_CHECK_GC
4110 assert (! (GC_EQ (obj, Qnull_pointer)));
4112 /* Checks we used to perform. */
4113 /* if (EQ (obj, Qnull_pointer)) return 1; */
4114 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
4115 /* if (PURIFIED (XPNTR (obj))) return 1; */
4117 switch (XGCTYPE (obj))
4119 #ifndef LRECORD_CONS
4120 case Lisp_Type_Cons:
4122 struct Lisp_Cons *ptr = XCONS (obj);
4123 return PURIFIED (ptr) || XMARKBIT (ptr->car);
4126 case Lisp_Type_Record:
4128 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
4129 #if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION)
4130 assert (lheader->type <= last_lrecord_type_index_assigned);
4132 return PURIFIED (lheader) || MARKED_RECORD_HEADER_P (lheader);
4134 #ifndef LRECORD_STRING
4135 case Lisp_Type_String:
4137 struct Lisp_String *ptr = XSTRING (obj);
4138 return PURIFIED (ptr) || XMARKBIT (ptr->plist);
4140 #endif /* ! LRECORD_STRING */
4141 #ifndef LRECORD_VECTOR
4142 case Lisp_Type_Vector:
4144 struct Lisp_Vector *ptr = XVECTOR (obj);
4145 return PURIFIED (ptr) || vector_length (ptr) < 0;
4147 #endif /* !LRECORD_VECTOR */
4148 #ifndef LRECORD_SYMBOL
4149 case Lisp_Type_Symbol:
4151 struct Lisp_Symbol *ptr = XSYMBOL (obj);
4152 return PURIFIED (ptr) || XMARKBIT (ptr->plist);
4156 /* Ints and Chars don't need GC */
4157 #if defined (USE_MINIMAL_TAGBITS) || ! defined (ERROR_CHECK_GC)
4164 case Lisp_Type_Char:
4173 /* Free all unmarked records. Do this at the very beginning,
4174 before anything else, so that the finalize methods can safely
4175 examine items in the objects. sweep_lcrecords_1() makes
4176 sure to call all the finalize methods *before* freeing anything,
4177 to complete the safety. */
4180 sweep_lcrecords_1 (&all_lcrecords, &ignored);
4183 compact_string_chars ();
4185 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
4186 macros) must be *extremely* careful to make sure they're not
4187 referencing freed objects. The only two existing finalize
4188 methods (for strings and markers) pass muster -- the string
4189 finalizer doesn't look at anything but its own specially-
4190 created block, and the marker finalizer only looks at live
4191 buffers (which will never be freed) and at the markers before
4192 and after it in the chain (which, by induction, will never be
4193 freed because if so, they would have already removed themselves
4196 /* Put all unmarked strings on free list, free'ing the string chars
4197 of large unmarked strings */
4200 /* Put all unmarked conses on free list */
4203 #ifndef LRECORD_VECTOR
4204 /* Free all unmarked vectors */
4205 sweep_vectors_1 (&all_vectors,
4206 &gc_count_num_vector_used, &gc_count_vector_total_size,
4207 &gc_count_vector_storage);
4210 /* Free all unmarked bit vectors */
4211 sweep_bit_vectors_1 (&all_bit_vectors,
4212 &gc_count_num_bit_vector_used,
4213 &gc_count_bit_vector_total_size,
4214 &gc_count_bit_vector_storage);
4216 /* Free all unmarked compiled-function objects */
4217 sweep_compiled_functions ();
4219 #ifdef LISP_FLOAT_TYPE
4220 /* Put all unmarked floats on free list */
4224 /* Put all unmarked symbols on free list */
4227 /* Put all unmarked extents on free list */
4230 /* Put all unmarked markers on free list.
4231 Dechain each one first from the buffer into which it points. */
4238 /* Clearing for disksave. */
4241 disksave_object_finalization (void)
4243 /* It's important that certain information from the environment not get
4244 dumped with the executable (pathnames, environment variables, etc.).
4245 To make it easier to tell when this has happened with strings(1) we
4246 clear some known-to-be-garbage blocks of memory, so that leftover
4247 results of old evaluation don't look like potential problems.
4248 But first we set some notable variables to nil and do one more GC,
4249 to turn those strings into garbage.
4252 /* Yeah, this list is pretty ad-hoc... */
4253 Vprocess_environment = Qnil;
4254 Vexec_directory = Qnil;
4255 Vdata_directory = Qnil;
4256 Vsite_directory = Qnil;
4257 Vdoc_directory = Qnil;
4258 Vconfigure_info_directory = Qnil;
4261 /* Vdump_load_path = Qnil; */
4262 uncache_home_directory();
4264 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
4265 defined(LOADHIST_BUILTIN))
4266 Vload_history = Qnil;
4268 Vshell_file_name = Qnil;
4270 garbage_collect_1 ();
4272 /* Run the disksave finalization methods of all live objects. */
4273 disksave_object_finalization_1 ();
4275 #if 0 /* I don't see any point in this. The purespace starts out all 0's */
4276 /* Zero out the unused portion of purespace */
4278 memset ( (char *) (PUREBEG + pure_bytes_used), 0,
4279 (((char *) (PUREBEG + get_PURESIZE())) -
4280 ((char *) (PUREBEG + pure_bytes_used))));
4283 /* Zero out the uninitialized (really, unused) part of the containers
4284 for the live strings. */
4286 struct string_chars_block *scb;
4287 for (scb = first_string_chars_block; scb; scb = scb->next)
4289 int count = sizeof (scb->string_chars) - scb->pos;
4291 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
4293 /* from the block's fill ptr to the end */
4294 memset ((scb->string_chars + scb->pos), 0, count);
4299 /* There, that ought to be enough... */
4305 restore_gc_inhibit (Lisp_Object val)
4307 gc_currently_forbidden = XINT (val);
4311 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
4312 static int gc_hooks_inhibited;
4316 garbage_collect_1 (void)
4318 #if MAX_SAVE_STACK > 0
4319 char stack_top_variable;
4320 extern char *stack_bottom;
4326 Lisp_Object pre_gc_cursor;
4327 struct gcpro gcpro1;
4330 || gc_currently_forbidden
4332 || preparing_for_armageddon)
4335 /* We used to call selected_frame() here.
4337 The following functions cannot be called inside GC
4338 so we move to after the above tests. */
4341 Lisp_Object device = Fselected_device (Qnil);
4342 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
4344 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
4346 signal_simple_error ("No frames exist on device", device);
4350 pre_gc_cursor = Qnil;
4353 GCPRO1 (pre_gc_cursor);
4355 /* Very important to prevent GC during any of the following
4356 stuff that might run Lisp code; otherwise, we'll likely
4357 have infinite GC recursion. */
4358 speccount = specpdl_depth ();
4359 record_unwind_protect (restore_gc_inhibit,
4360 make_int (gc_currently_forbidden));
4361 gc_currently_forbidden = 1;
4363 if (!gc_hooks_inhibited)
4364 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
4366 /* Now show the GC cursor/message. */
4367 if (!noninteractive)
4369 if (FRAME_WIN_P (f))
4371 Lisp_Object frame = make_frame (f);
4372 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
4373 FRAME_SELECTED_WINDOW (f),
4375 pre_gc_cursor = f->pointer;
4376 if (POINTER_IMAGE_INSTANCEP (cursor)
4377 /* don't change if we don't know how to change back. */
4378 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
4381 Fset_frame_pointer (frame, cursor);
4385 /* Don't print messages to the stream device. */
4386 if (!cursor_changed && !FRAME_STREAM_P (f))
4388 char *msg = (STRINGP (Vgc_message)
4389 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
4391 Lisp_Object args[2], whole_msg;
4392 args[0] = build_string (msg ? msg :
4393 GETTEXT ((CONST char *) gc_default_message));
4394 args[1] = build_string ("...");
4395 whole_msg = Fconcat (2, args);
4396 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
4397 Qgarbage_collecting);
4401 /***** Now we actually start the garbage collection. */
4405 gc_generation_number[0]++;
4407 #if MAX_SAVE_STACK > 0
4409 /* Save a copy of the contents of the stack, for debugging. */
4412 /* Static buffer in which we save a copy of the C stack at each GC. */
4413 static char *stack_copy;
4414 static size_t stack_copy_size;
4416 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
4417 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
4418 if (stack_size < MAX_SAVE_STACK)
4420 if (stack_copy_size < stack_size)
4422 stack_copy = (char *) xrealloc (stack_copy, stack_size);
4423 stack_copy_size = stack_size;
4427 stack_diff > 0 ? stack_bottom : &stack_top_variable,
4431 #endif /* MAX_SAVE_STACK > 0 */
4433 /* Do some totally ad-hoc resource clearing. */
4434 /* #### generalize this? */
4435 clear_event_resource ();
4436 cleanup_specifiers ();
4438 /* Mark all the special slots that serve as the roots of accessibility. */
4441 struct catchtag *catch;
4442 struct backtrace *backlist;
4443 struct specbinding *bind;
4445 for (i = 0; i < staticidx; i++)
4447 mark_object (*(staticvec[i]));
4450 for (tail = gcprolist; tail; tail = tail->next)
4452 for (i = 0; i < tail->nvars; i++)
4453 mark_object (tail->var[i]);
4456 for (bind = specpdl; bind != specpdl_ptr; bind++)
4458 mark_object (bind->symbol);
4459 mark_object (bind->old_value);
4462 for (catch = catchlist; catch; catch = catch->next)
4464 mark_object (catch->tag);
4465 mark_object (catch->val);
4468 for (backlist = backtrace_list; backlist; backlist = backlist->next)
4470 int nargs = backlist->nargs;
4472 mark_object (*backlist->function);
4473 if (nargs == UNEVALLED || nargs == MANY)
4474 mark_object (backlist->args[0]);
4476 for (i = 0; i < nargs; i++)
4477 mark_object (backlist->args[i]);
4480 mark_redisplay (mark_object);
4481 mark_profiling_info (mark_object);
4484 /* OK, now do the after-mark stuff. This is for things that
4485 are only marked when something else is marked (e.g. weak hash tables).
4486 There may be complex dependencies between such objects -- e.g.
4487 a weak hash table might be unmarked, but after processing a later
4488 weak hash table, the former one might get marked. So we have to
4489 iterate until nothing more gets marked. */
4491 while (finish_marking_weak_hash_tables (marked_p, mark_object) > 0 ||
4492 finish_marking_weak_lists (marked_p, mark_object) > 0)
4495 /* And prune (this needs to be called after everything else has been
4496 marked and before we do any sweeping). */
4497 /* #### this is somewhat ad-hoc and should probably be an object
4499 prune_weak_hash_tables (marked_p);
4500 prune_weak_lists (marked_p);
4501 prune_specifiers (marked_p);
4502 prune_syntax_tables (marked_p);
4506 consing_since_gc = 0;
4507 #ifndef DEBUG_XEMACS
4508 /* Allow you to set it really fucking low if you really want ... */
4509 if (gc_cons_threshold < 10000)
4510 gc_cons_threshold = 10000;
4515 /******* End of garbage collection ********/
4517 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
4519 /* Now remove the GC cursor/message */
4520 if (!noninteractive)
4523 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
4524 else if (!FRAME_STREAM_P (f))
4526 char *msg = (STRINGP (Vgc_message)
4527 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
4530 /* Show "...done" only if the echo area would otherwise be empty. */
4531 if (NILP (clear_echo_area (selected_frame (),
4532 Qgarbage_collecting, 0)))
4534 Lisp_Object args[2], whole_msg;
4535 args[0] = build_string (msg ? msg :
4536 GETTEXT ((CONST char *)
4537 gc_default_message));
4538 args[1] = build_string ("... done");
4539 whole_msg = Fconcat (2, args);
4540 echo_area_message (selected_frame (), (Bufbyte *) 0,
4542 Qgarbage_collecting);
4547 /* now stop inhibiting GC */
4548 unbind_to (speccount, Qnil);
4550 if (!breathing_space)
4552 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
4559 /* Debugging aids. */
4562 gc_plist_hack (CONST char *name, int value, Lisp_Object tail)
4564 /* C doesn't have local functions (or closures, or GC, or readable syntax,
4565 or portable numeric datatypes, or bit-vectors, or characters, or
4566 arrays, or exceptions, or ...) */
4567 return cons3 (intern (name), make_int (value), tail);
4570 #define HACK_O_MATIC(type, name, pl) do { \
4572 struct type##_block *x = current_##type##_block; \
4573 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
4574 (pl) = gc_plist_hack ((name), s, (pl)); \
4577 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
4578 Reclaim storage for Lisp objects no longer needed.
4579 Return info on amount of space in use:
4580 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4581 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4583 where `PLIST' is a list of alternating keyword/value pairs providing
4584 more detailed information.
4585 Garbage collection happens automatically if you cons more than
4586 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4590 Lisp_Object pl = Qnil;
4592 #ifdef LRECORD_VECTOR
4593 int gc_count_vector_total_size = 0;
4596 if (purify_flag && pure_lossage)
4599 garbage_collect_1 ();
4601 for (i = 0; i < last_lrecord_type_index_assigned; i++)
4603 if (lcrecord_stats[i].bytes_in_use != 0
4604 || lcrecord_stats[i].bytes_freed != 0
4605 || lcrecord_stats[i].instances_on_free_list != 0)
4608 CONST char *name = lrecord_implementations_table[i]->name;
4609 int len = strlen (name);
4610 #ifdef LRECORD_VECTOR
4611 /* save this for the FSFmacs-compatible part of the summary */
4612 if (i == *lrecord_vector[0].lrecord_type_index)
4613 gc_count_vector_total_size =
4614 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
4616 sprintf (buf, "%s-storage", name);
4617 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
4618 /* Okay, simple pluralization check for `symbol-value-varalias' */
4619 if (name[len-1] == 's')
4620 sprintf (buf, "%ses-freed", name);
4622 sprintf (buf, "%ss-freed", name);
4623 if (lcrecord_stats[i].instances_freed != 0)
4624 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
4625 if (name[len-1] == 's')
4626 sprintf (buf, "%ses-on-free-list", name);
4628 sprintf (buf, "%ss-on-free-list", name);
4629 if (lcrecord_stats[i].instances_on_free_list != 0)
4630 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
4632 if (name[len-1] == 's')
4633 sprintf (buf, "%ses-used", name);
4635 sprintf (buf, "%ss-used", name);
4636 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
4640 HACK_O_MATIC (extent, "extent-storage", pl);
4641 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
4642 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
4643 HACK_O_MATIC (event, "event-storage", pl);
4644 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
4645 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
4646 HACK_O_MATIC (marker, "marker-storage", pl);
4647 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
4648 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
4649 #ifdef LISP_FLOAT_TYPE
4650 HACK_O_MATIC (float, "float-storage", pl);
4651 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
4652 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
4653 #endif /* LISP_FLOAT_TYPE */
4654 HACK_O_MATIC (string, "string-header-storage", pl);
4655 pl = gc_plist_hack ("long-strings-total-length",
4656 gc_count_string_total_size
4657 - gc_count_short_string_total_size, pl);
4658 HACK_O_MATIC (string_chars, "short-string-storage", pl);
4659 pl = gc_plist_hack ("short-strings-total-length",
4660 gc_count_short_string_total_size, pl);
4661 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
4662 pl = gc_plist_hack ("long-strings-used",
4663 gc_count_num_string_in_use
4664 - gc_count_num_short_string_in_use, pl);
4665 pl = gc_plist_hack ("short-strings-used",
4666 gc_count_num_short_string_in_use, pl);
4668 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
4669 pl = gc_plist_hack ("compiled-functions-free",
4670 gc_count_num_compiled_function_freelist, pl);
4671 pl = gc_plist_hack ("compiled-functions-used",
4672 gc_count_num_compiled_function_in_use, pl);
4674 #ifndef LRECORD_VECTOR
4675 pl = gc_plist_hack ("vector-storage", gc_count_vector_storage, pl);
4676 pl = gc_plist_hack ("vectors-total-length",
4677 gc_count_vector_total_size, pl);
4678 pl = gc_plist_hack ("vectors-used", gc_count_num_vector_used, pl);
4681 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
4682 pl = gc_plist_hack ("bit-vectors-total-length",
4683 gc_count_bit_vector_total_size, pl);
4684 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
4686 HACK_O_MATIC (symbol, "symbol-storage", pl);
4687 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
4688 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
4690 HACK_O_MATIC (cons, "cons-storage", pl);
4691 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
4692 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
4694 /* The things we do for backwards-compatibility */
4696 list6 (Fcons (make_int (gc_count_num_cons_in_use),
4697 make_int (gc_count_num_cons_freelist)),
4698 Fcons (make_int (gc_count_num_symbol_in_use),
4699 make_int (gc_count_num_symbol_freelist)),
4700 Fcons (make_int (gc_count_num_marker_in_use),
4701 make_int (gc_count_num_marker_freelist)),
4702 make_int (gc_count_string_total_size),
4703 make_int (gc_count_vector_total_size),
4708 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
4709 Return the number of bytes consed since the last garbage collection.
4710 \"Consed\" is a misnomer in that this actually counts allocation
4711 of all different kinds of objects, not just conses.
4713 If this value exceeds `gc-cons-threshold', a garbage collection happens.
4717 return make_int (consing_since_gc);
4720 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
4721 Return the address of the last byte Emacs has allocated, divided by 1024.
4722 This may be helpful in debugging Emacs's memory usage.
4723 The value is divided by 1024 to make sure it will fit in a lisp integer.
4727 return make_int ((EMACS_INT) sbrk (0) / 1024);
4733 object_dead_p (Lisp_Object obj)
4735 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
4736 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
4737 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
4738 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
4739 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
4740 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
4741 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
4744 #ifdef MEMORY_USAGE_STATS
4746 /* Attempt to determine the actual amount of space that is used for
4747 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
4749 It seems that the following holds:
4751 1. When using the old allocator (malloc.c):
4753 -- blocks are always allocated in chunks of powers of two. For
4754 each block, there is an overhead of 8 bytes if rcheck is not
4755 defined, 20 bytes if it is defined. In other words, a
4756 one-byte allocation needs 8 bytes of overhead for a total of
4757 9 bytes, and needs to have 16 bytes of memory chunked out for
4760 2. When using the new allocator (gmalloc.c):
4762 -- blocks are always allocated in chunks of powers of two up
4763 to 4096 bytes. Larger blocks are allocated in chunks of
4764 an integral multiple of 4096 bytes. The minimum block
4765 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
4766 is defined. There is no per-block overhead, but there
4767 is an overhead of 3*sizeof (size_t) for each 4096 bytes
4770 3. When using the system malloc, anything goes, but they are
4771 generally slower and more space-efficient than the GNU
4772 allocators. One possibly reasonable assumption to make
4773 for want of better data is that sizeof (void *), or maybe
4774 2 * sizeof (void *), is required as overhead and that
4775 blocks are allocated in the minimum required size except
4776 that some minimum block size is imposed (e.g. 16 bytes). */
4779 malloced_storage_size (void *ptr, size_t claimed_size,
4780 struct overhead_stats *stats)
4782 size_t orig_claimed_size = claimed_size;
4786 if (claimed_size < 2 * sizeof (void *))
4787 claimed_size = 2 * sizeof (void *);
4788 # ifdef SUNOS_LOCALTIME_BUG
4789 if (claimed_size < 16)
4792 if (claimed_size < 4096)
4796 /* compute the log base two, more or less, then use it to compute
4797 the block size needed. */
4799 /* It's big, it's heavy, it's wood! */
4800 while ((claimed_size /= 2) != 0)
4803 /* It's better than bad, it's good! */
4809 /* We have to come up with some average about the amount of
4811 if ((size_t) (rand () & 4095) < claimed_size)
4812 claimed_size += 3 * sizeof (void *);
4816 claimed_size += 4095;
4817 claimed_size &= ~4095;
4818 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
4821 #elif defined (SYSTEM_MALLOC)
4823 if (claimed_size < 16)
4825 claimed_size += 2 * sizeof (void *);
4827 #else /* old GNU allocator */
4829 # ifdef rcheck /* #### may not be defined here */
4837 /* compute the log base two, more or less, then use it to compute
4838 the block size needed. */
4840 /* It's big, it's heavy, it's wood! */
4841 while ((claimed_size /= 2) != 0)
4844 /* It's better than bad, it's good! */
4852 #endif /* old GNU allocator */
4856 stats->was_requested += orig_claimed_size;
4857 stats->malloc_overhead += claimed_size - orig_claimed_size;
4859 return claimed_size;
4863 fixed_type_block_overhead (size_t size)
4865 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
4866 size_t overhead = 0;
4867 size_t storage_size = malloced_storage_size (0, per_block, 0);
4868 while (size >= per_block)
4871 overhead += sizeof (void *) + per_block - storage_size;
4873 if (rand () % per_block < size)
4874 overhead += sizeof (void *) + per_block - storage_size;
4878 #endif /* MEMORY_USAGE_STATS */
4881 /* Initialization */
4883 init_alloc_once_early (void)
4887 last_lrecord_type_index_assigned = -1;
4888 for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
4890 lrecord_implementations_table[iii] = 0;
4893 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
4895 * If USE_INDEXED_LRECORD_IMPLEMENTATION is defined, all the staticly
4896 * defined subr lrecords were initialized with lheader->type == 0.
4897 * See subr_lheader_initializer in lisp.h. Force type index 0 to be
4898 * assigned to lrecord_subr so that those predefined indexes match
4901 lrecord_type_index (lrecord_subr);
4902 assert (*(lrecord_subr[0].lrecord_type_index) == 0);
4904 * The same is true for symbol_value_forward objects, except the
4907 lrecord_type_index (lrecord_symbol_value_forward);
4908 assert (*(lrecord_symbol_value_forward[0].lrecord_type_index) == 1);
4909 #endif /* USE_INDEXED_LRECORD_IMPLEMENTATION */
4911 symbols_initialized = 0;
4913 gc_generation_number[0] = 0;
4914 /* purify_flag 1 is correct even if CANNOT_DUMP.
4915 * loadup.el will set to nil at end. */
4917 pure_bytes_used = 0;
4919 breathing_space = 0;
4920 #ifndef LRECORD_VECTOR
4921 XSETINT (all_vectors, 0); /* Qzero may not be set yet. */
4923 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
4924 XSETINT (Vgc_message, 0);
4926 ignore_malloc_warnings = 1;
4927 #ifdef DOUG_LEA_MALLOC
4928 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
4929 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
4930 #if 0 /* Moved to emacs.c */
4931 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
4934 init_string_alloc ();
4935 init_string_chars_alloc ();
4937 init_symbol_alloc ();
4938 init_compiled_function_alloc ();
4939 #ifdef LISP_FLOAT_TYPE
4940 init_float_alloc ();
4941 #endif /* LISP_FLOAT_TYPE */
4942 init_marker_alloc ();
4943 init_extent_alloc ();
4944 init_event_alloc ();
4946 ignore_malloc_warnings = 0;
4948 consing_since_gc = 0;
4950 gc_cons_threshold = 500000; /* XEmacs change */
4952 gc_cons_threshold = 15000; /* debugging */
4954 #ifdef VIRT_ADDR_VARIES
4955 malloc_sbrk_unused = 1<<22; /* A large number */
4956 malloc_sbrk_used = 100000; /* as reasonable as any number */
4957 #endif /* VIRT_ADDR_VARIES */
4958 lrecord_uid_counter = 259;
4959 debug_string_purity = 0;
4962 gc_currently_forbidden = 0;
4963 gc_hooks_inhibited = 0;
4965 #ifdef ERROR_CHECK_TYPECHECK
4966 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4969 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
4971 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4973 #endif /* ERROR_CHECK_TYPECHECK */
4983 syms_of_alloc (void)
4985 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
4986 defsymbol (&Qpost_gc_hook, "post-gc-hook");
4987 defsymbol (&Qgarbage_collecting, "garbage-collecting");
4992 DEFSUBR (Fbit_vector);
4993 DEFSUBR (Fmake_byte_code);
4994 DEFSUBR (Fmake_list);
4995 DEFSUBR (Fmake_vector);
4996 DEFSUBR (Fmake_bit_vector);
4997 DEFSUBR (Fmake_string);
4999 DEFSUBR (Fmake_symbol);
5000 DEFSUBR (Fmake_marker);
5001 DEFSUBR (Fpurecopy);
5002 DEFSUBR (Fgarbage_collect);
5003 DEFSUBR (Fmemory_limit);
5004 DEFSUBR (Fconsing_since_gc);
5008 vars_of_alloc (void)
5010 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
5011 *Number of bytes of consing between garbage collections.
5012 \"Consing\" is a misnomer in that this actually counts allocation
5013 of all different kinds of objects, not just conses.
5014 Garbage collection can happen automatically once this many bytes have been
5015 allocated since the last garbage collection. All data types count.
5017 Garbage collection happens automatically when `eval' or `funcall' are
5018 called. (Note that `funcall' is called implicitly as part of evaluation.)
5019 By binding this temporarily to a large number, you can effectively
5020 prevent garbage collection during a part of the program.
5022 See also `consing-since-gc'.
5025 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
5026 Number of bytes of sharable Lisp data allocated so far.
5030 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
5031 Number of bytes of unshared memory allocated in this session.
5034 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
5035 Number of bytes of unshared memory remaining available in this session.
5040 DEFVAR_INT ("debug-allocation", &debug_allocation /*
5041 If non-zero, print out information to stderr about all objects allocated.
5042 See also `debug-allocation-backtrace-length'.
5044 debug_allocation = 0;
5046 DEFVAR_INT ("debug-allocation-backtrace-length",
5047 &debug_allocation_backtrace_length /*
5048 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
5050 debug_allocation_backtrace_length = 2;
5053 DEFVAR_BOOL ("purify-flag", &purify_flag /*
5054 Non-nil means loading Lisp code in order to dump an executable.
5055 This means that certain objects should be allocated in shared (pure) space.
5058 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
5059 Function or functions to be run just before each garbage collection.
5060 Interrupts, garbage collection, and errors are inhibited while this hook
5061 runs, so be extremely careful in what you add here. In particular, avoid
5062 consing, and do not interact with the user.
5064 Vpre_gc_hook = Qnil;
5066 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
5067 Function or functions to be run just after each garbage collection.
5068 Interrupts, garbage collection, and errors are inhibited while this hook
5069 runs, so be extremely careful in what you add here. In particular, avoid
5070 consing, and do not interact with the user.
5072 Vpost_gc_hook = Qnil;
5074 DEFVAR_LISP ("gc-message", &Vgc_message /*
5075 String to print to indicate that a garbage collection is in progress.
5076 This is printed in the echo area. If the selected frame is on a
5077 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
5078 image instance) in the domain of the selected frame, the mouse pointer
5079 will change instead of this message being printed.
5081 Vgc_message = make_pure_string ((CONST Bufbyte *) gc_default_message,
5082 countof (gc_default_message) - 1,
5085 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
5086 Pointer glyph used to indicate that a garbage collection is in progress.
5087 If the selected window is on a window system and this glyph specifies a
5088 value (i.e. a pointer image instance) in the domain of the selected
5089 window, the pointer will be changed as specified during garbage collection.
5090 Otherwise, a message will be printed in the echo area, as controlled
5096 complex_vars_of_alloc (void)
5098 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);