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 /* Return the true size of a struct with a variable-length array field. */
69 #define STRETCHY_STRUCT_SIZEOF(stretchy_struct_type, \
70 stretchy_array_field, \
71 stretchy_array_length) \
72 (offsetof (stretchy_struct_type, stretchy_array_field) + \
73 (offsetof (stretchy_struct_type, stretchy_array_field[1]) - \
74 offsetof (stretchy_struct_type, stretchy_array_field[0])) * \
75 (stretchy_array_length))
77 #if 0 /* this is _way_ too slow to be part of the standard debug options */
78 #if defined(DEBUG_XEMACS) && defined(MULE)
79 #define VERIFY_STRING_CHARS_INTEGRITY
83 /* Define this to see where all that space is going... */
84 /* But the length of the printout is obnoxious, so limit it to testers */
85 #ifdef MEMORY_USAGE_STATS
89 /* Define this to use malloc/free with no freelist for all datatypes,
90 the hope being that some debugging tools may help detect
91 freed memory references */
92 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
94 #define ALLOC_NO_POOLS
100 static int debug_allocation;
101 static int debug_allocation_backtrace_length;
104 /* Number of bytes of consing done since the last gc */
105 EMACS_INT consing_since_gc;
106 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
108 #define debug_allocation_backtrace() \
110 if (debug_allocation_backtrace_length > 0) \
111 debug_short_backtrace (debug_allocation_backtrace_length); \
115 #define INCREMENT_CONS_COUNTER(foosize, type) \
117 if (debug_allocation) \
119 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
120 debug_allocation_backtrace (); \
122 INCREMENT_CONS_COUNTER_1 (foosize); \
124 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
126 if (debug_allocation > 1) \
128 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
129 debug_allocation_backtrace (); \
131 INCREMENT_CONS_COUNTER_1 (foosize); \
134 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
135 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
136 INCREMENT_CONS_COUNTER_1 (size)
139 #define DECREMENT_CONS_COUNTER(size) do { \
140 consing_since_gc -= (size); \
141 if (consing_since_gc < 0) \
142 consing_since_gc = 0; \
145 /* Number of bytes of consing since gc before another gc should be done. */
146 EMACS_INT gc_cons_threshold;
148 /* Nonzero during gc */
151 /* Number of times GC has happened at this level or below.
152 * Level 0 is most volatile, contrary to usual convention.
153 * (Of course, there's only one level at present) */
154 EMACS_INT gc_generation_number[1];
156 /* This is just for use by the printer, to allow things to print uniquely */
157 static int lrecord_uid_counter;
159 /* Nonzero when calling certain hooks or doing other things where
161 int gc_currently_forbidden;
164 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
165 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
167 /* "Garbage collecting" */
168 Lisp_Object Vgc_message;
169 Lisp_Object Vgc_pointer_glyph;
170 static CONST char gc_default_message[] = "Garbage collecting";
171 Lisp_Object Qgarbage_collecting;
173 #ifndef VIRT_ADDR_VARIES
175 #endif /* VIRT_ADDR_VARIES */
176 EMACS_INT malloc_sbrk_used;
178 #ifndef VIRT_ADDR_VARIES
180 #endif /* VIRT_ADDR_VARIES */
181 EMACS_INT malloc_sbrk_unused;
183 /* Non-zero means defun should do purecopy on the function definition */
187 extern void sheap_adjust_h();
190 /* Force linker to put it into data space! */
191 EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = { (EMACS_INT) 0};
193 #define PUREBEG ((char *) pure)
195 #if 0 /* This is breathing_space in XEmacs */
196 /* Points to memory space allocated as "spare",
197 to be freed if we run out of memory. */
198 static char *spare_memory;
200 /* Amount of spare memory to keep in reserve. */
201 #define SPARE_MEMORY (1 << 14)
204 /* Index in pure at which next pure object will be allocated. */
205 static size_t pure_bytes_used;
207 #define PURIFIED(ptr) \
208 ((char *) (ptr) >= PUREBEG && \
209 (char *) (ptr) < PUREBEG + get_PURESIZE())
211 /* Non-zero if pure_bytes_used > get_PURESIZE();
212 accounts for excess purespace needs. */
213 static size_t pure_lossage;
215 #ifdef ERROR_CHECK_TYPECHECK
217 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
222 purified (Lisp_Object obj)
224 return POINTER_TYPE_P (XGCTYPE (obj)) && PURIFIED (XPNTR (obj));
228 purespace_usage (void)
230 return pure_bytes_used;
234 check_purespace (size_t size)
238 pure_lossage += size;
241 else if (pure_bytes_used + size > get_PURESIZE())
243 /* This can cause recursive bad behavior, we'll yell at the end */
244 /* when we're done. */
245 /* message ("\nERROR: Pure Lisp storage exhausted!\n"); */
257 #define bump_purestat(p,b) DO_NOTHING
261 static int purecopying_function_constants;
263 static size_t pure_sizeof (Lisp_Object);
265 /* Keep statistics on how much of what is in purespace */
266 static struct purestat
272 purestat_cons = {0, 0, "cons cells"},
273 purestat_float = {0, 0, "float objects"},
274 purestat_string_pname = {0, 0, "symbol-name strings"},
275 purestat_function = {0, 0, "compiled-function objects"},
276 purestat_opaque_instructions = {0, 0, "compiled-function instructions"},
277 purestat_vector_constants = {0, 0, "compiled-function constants vectors"},
278 purestat_string_interactive = {0, 0, "interactive strings"},
280 purestat_string_domain = {0, 0, "domain strings"},
282 purestat_string_documentation = {0, 0, "documentation strings"},
283 purestat_string_other_function = {0, 0, "other function strings"},
284 purestat_vector_other = {0, 0, "other vectors"},
285 purestat_string_other = {0, 0, "other strings"},
286 purestat_string_all = {0, 0, "all strings"},
287 purestat_vector_all = {0, 0, "all vectors"};
290 bump_purestat (struct purestat *purestat, size_t nbytes)
292 if (pure_lossage) return;
293 purestat->nobjects += 1;
294 purestat->nbytes += nbytes;
298 print_purestat (struct purestat *purestat)
301 sprintf(buf, "%s:", purestat->name);
302 message (" %-36s %5d %7d %2d%%",
306 (int) (purestat->nbytes / (pure_bytes_used / 100.0) + 0.5));
308 #endif /* PURESTAT */
311 /* Maximum amount of C stack to save when a GC happens. */
313 #ifndef MAX_SAVE_STACK
314 #define MAX_SAVE_STACK 0 /* 16000 */
317 /* Non-zero means ignore malloc warnings. Set during initialization. */
318 int ignore_malloc_warnings;
321 static void *breathing_space;
324 release_breathing_space (void)
328 void *tmp = breathing_space;
334 /* malloc calls this if it finds we are near exhausting storage */
336 malloc_warning (CONST char *str)
338 if (ignore_malloc_warnings)
344 "Killing some buffers may delay running out of memory.\n"
345 "However, certainly by the time you receive the 95%% warning,\n"
346 "you should clean up, kill this Emacs, and start a new one.",
350 /* Called if malloc returns zero */
354 /* Force a GC next time eval is called.
355 It's better to loop garbage-collecting (we might reclaim enough
356 to win) than to loop beeping and barfing "Memory exhausted"
358 consing_since_gc = gc_cons_threshold + 1;
359 release_breathing_space ();
361 /* Flush some histories which might conceivably contain garbalogical
363 if (!NILP (Fboundp (Qvalues)))
364 Fset (Qvalues, Qnil);
365 Vcommand_history = Qnil;
367 error ("Memory exhausted");
370 /* like malloc and realloc but check for no memory left, and block input. */
377 xmalloc (size_t size)
379 void *val = malloc (size);
381 if (!val && (size != 0)) memory_full ();
390 xcalloc (size_t nelem, size_t elsize)
392 void *val = calloc (nelem, elsize);
394 if (!val && (nelem != 0)) memory_full ();
399 xmalloc_and_zero (size_t size)
401 return xcalloc (size, sizeof (char));
409 xrealloc (void *block, size_t size)
411 /* We must call malloc explicitly when BLOCK is 0, since some
412 reallocs don't do this. */
413 void *val = block ? realloc (block, size) : malloc (size);
415 if (!val && (size != 0)) memory_full ();
420 #ifdef ERROR_CHECK_MALLOC
421 xfree_1 (void *block)
426 #ifdef ERROR_CHECK_MALLOC
427 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
428 error until much later on for many system mallocs, such as
429 the one that comes with Solaris 2.3. FMH!! */
430 assert (block != (void *) 0xDEADBEEF);
432 #endif /* ERROR_CHECK_MALLOC */
436 #ifdef ERROR_CHECK_GC
439 typedef unsigned int four_byte_t;
440 #elif SIZEOF_LONG == 4
441 typedef unsigned long four_byte_t;
442 #elif SIZEOF_SHORT == 4
443 typedef unsigned short four_byte_t;
445 What kind of strange-ass system are we running on?
449 deadbeef_memory (void *ptr, size_t size)
451 four_byte_t *ptr4 = (four_byte_t *) ptr;
452 size_t beefs = size >> 2;
454 /* In practice, size will always be a multiple of four. */
456 (*ptr4++) = 0xDEADBEEF;
459 #else /* !ERROR_CHECK_GC */
462 #define deadbeef_memory(ptr, size)
464 #endif /* !ERROR_CHECK_GC */
471 xstrdup (CONST char *str)
473 int len = strlen (str) + 1; /* for stupid terminating 0 */
475 void *val = xmalloc (len);
476 if (val == 0) return 0;
477 memcpy (val, str, len);
483 strdup (CONST char *s)
487 #endif /* NEED_STRDUP */
491 allocate_lisp_storage (size_t size)
493 void *p = xmalloc (size);
494 #ifndef USE_MINIMAL_TAGBITS
495 char *lim = ((char *) p) + size;
498 XSETOBJ (val, Lisp_Type_Record, lim);
499 if ((char *) XPNTR (val) != lim)
504 #endif /* ! USE_MINIMAL_TAGBITS */
509 /* lrecords are chained together through their "next.v" field.
510 * After doing the mark phase, the GC will walk this linked
511 * list and free any record which hasn't been marked.
513 static struct lcrecord_header *all_lcrecords;
516 alloc_lcrecord (size_t size, CONST struct lrecord_implementation *implementation)
518 struct lcrecord_header *lcheader;
520 #ifdef ERROR_CHECK_GC
521 if (implementation->static_size == 0)
522 assert (implementation->size_in_bytes_method);
524 assert (implementation->static_size == size);
527 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
528 set_lheader_implementation (&(lcheader->lheader), implementation);
529 lcheader->next = all_lcrecords;
530 #if 1 /* mly prefers to see small ID numbers */
531 lcheader->uid = lrecord_uid_counter++;
532 #else /* jwz prefers to see real addrs */
533 lcheader->uid = (int) &lcheader;
536 all_lcrecords = lcheader;
537 INCREMENT_CONS_COUNTER (size, implementation->name);
541 #if 0 /* Presently unused */
542 /* Very, very poor man's EGC?
543 * This may be slow and thrash pages all over the place.
544 * Only call it if you really feel you must (and if the
545 * lrecord was fairly recently allocated).
546 * Otherwise, just let the GC do its job -- that's what it's there for
549 free_lcrecord (struct lcrecord_header *lcrecord)
551 if (all_lcrecords == lcrecord)
553 all_lcrecords = lcrecord->next;
557 struct lrecord_header *header = all_lcrecords;
560 struct lrecord_header *next = header->next;
561 if (next == lcrecord)
563 header->next = lrecord->next;
572 if (lrecord->implementation->finalizer)
573 lrecord->implementation->finalizer (lrecord, 0);
581 disksave_object_finalization_1 (void)
583 struct lcrecord_header *header;
585 for (header = all_lcrecords; header; header = header->next)
587 if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
589 ((LHEADER_IMPLEMENTATION(&header->lheader)->finalizer)
595 /* This must not be called -- it just serves as for EQ test
596 * If lheader->implementation->finalizer is this_marks_a_marked_record,
597 * then lrecord has been marked by the GC sweeper
598 * header->implementation is put back to its correct value by
601 this_marks_a_marked_record (void *dummy0, int dummy1)
606 /* Semi-kludge -- lrecord_symbol_value_forward objects get stuck
607 in CONST space and you get SEGV's if you attempt to mark them.
608 This sits in lheader->implementation->marker. */
611 this_one_is_unmarkable (Lisp_Object obj, void (*markobj) (Lisp_Object))
617 /* XGCTYPE for records */
619 gc_record_type_p (Lisp_Object frob, CONST struct lrecord_implementation *type)
621 CONST struct lrecord_implementation *imp;
623 if (XGCTYPE (frob) != Lisp_Type_Record)
626 imp = XRECORD_LHEADER_IMPLEMENTATION (frob);
627 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
630 return imp == type || imp == type + 1;
635 /************************************************************************/
636 /* Debugger support */
637 /************************************************************************/
638 /* Give gdb/dbx enough information to decode Lisp Objects.
639 We make sure certain symbols are defined, so gdb doesn't complain
640 about expressions in src/gdbinit. Values are randomly chosen.
641 See src/gdbinit or src/dbxrc to see how this is used. */
645 #ifdef USE_MINIMAL_TAGBITS
646 dbg_valmask = (EMACS_INT) (((1UL << VALBITS) - 1) << GCBITS),
647 dbg_typemask = (EMACS_INT) ((1UL << GCTYPEBITS) - 1),
648 dbg_USE_MINIMAL_TAGBITS = 1,
649 dbg_Lisp_Type_Int = 100,
650 #else /* ! USE_MIMIMAL_TAGBITS */
651 dbg_valmask = (EMACS_INT) ((1UL << VALBITS) - 1),
652 dbg_typemask = (EMACS_INT) (((1UL << GCTYPEBITS) - 1) << (VALBITS + GCMARKBITS)),
653 dbg_USE_MINIMAL_TAGBITS = 0,
654 dbg_Lisp_Type_Int = Lisp_Type_Int,
655 #endif /* ! USE_MIMIMAL_TAGBITS */
657 #ifdef USE_UNION_TYPE
658 dbg_USE_UNION_TYPE = 1,
660 dbg_USE_UNION_TYPE = 0,
663 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
664 dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1,
666 dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0,
669 dbg_Lisp_Type_Char = Lisp_Type_Char,
670 dbg_Lisp_Type_Record = Lisp_Type_Record,
672 dbg_Lisp_Type_Cons = 101,
674 dbg_Lisp_Type_Cons = Lisp_Type_Cons,
677 #ifdef LRECORD_STRING
678 dbg_Lisp_Type_String = 102,
680 dbg_Lisp_Type_String = Lisp_Type_String,
681 lrecord_string = 202,
683 #ifdef LRECORD_VECTOR
684 dbg_Lisp_Type_Vector = 103,
686 dbg_Lisp_Type_Vector = Lisp_Type_Vector,
687 lrecord_vector = 203,
689 #ifdef LRECORD_SYMBOL
690 dbg_Lisp_Type_Symbol = 104,
692 dbg_Lisp_Type_Symbol = Lisp_Type_Symbol,
693 lrecord_symbol = 204,
696 lrecord_char_table_entry = 205,
697 lrecord_charset = 206,
698 lrecord_coding_system = 207,
700 #ifndef HAVE_TOOLBARS
701 lrecord_toolbar_button = 208,
703 #ifndef HAVE_TOOLTALK
704 lrecord_tooltalk_message = 210,
705 lrecord_tooltalk_pattern = 211,
707 #ifndef HAVE_DATABASE
708 lrecord_database = 212,
710 dbg_valbits = VALBITS,
711 dbg_gctypebits = GCTYPEBITS
712 /* If we don't have an actual object of this enum, pgcc (and perhaps
713 other compilers) might optimize away the entire type declaration :-( */
716 /* A few macros turned into functions for ease of debugging.
717 Debuggers don't know about macros! */
718 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
720 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
722 return EQ (obj1, obj2);
726 /************************************************************************/
727 /* Fixed-size type macros */
728 /************************************************************************/
730 /* For fixed-size types that are commonly used, we malloc() large blocks
731 of memory at a time and subdivide them into chunks of the correct
732 size for an object of that type. This is more efficient than
733 malloc()ing each object separately because we save on malloc() time
734 and overhead due to the fewer number of malloc()ed blocks, and
735 also because we don't need any extra pointers within each object
736 to keep them threaded together for GC purposes. For less common
737 (and frequently large-size) types, we use lcrecords, which are
738 malloc()ed individually and chained together through a pointer
739 in the lcrecord header. lcrecords do not need to be fixed-size
740 (i.e. two objects of the same type need not have the same size;
741 however, the size of a particular object cannot vary dynamically).
742 It is also much easier to create a new lcrecord type because no
743 additional code needs to be added to alloc.c. Finally, lcrecords
744 may be more efficient when there are only a small number of them.
746 The types that are stored in these large blocks (or "frob blocks")
747 are cons, float, compiled-function, symbol, marker, extent, event,
750 Note that strings are special in that they are actually stored in
751 two parts: a structure containing information about the string, and
752 the actual data associated with the string. The former structure
753 (a struct Lisp_String) is a fixed-size structure and is managed the
754 same way as all the other such types. This structure contains a
755 pointer to the actual string data, which is stored in structures of
756 type struct string_chars_block. Each string_chars_block consists
757 of a pointer to a struct Lisp_String, followed by the data for that
758 string, followed by another pointer to a struct Lisp_String,
759 followed by the data for that string, etc. At GC time, the data in
760 these blocks is compacted by searching sequentially through all the
761 blocks and compressing out any holes created by unmarked strings.
762 Strings that are more than a certain size (bigger than the size of
763 a string_chars_block, although something like half as big might
764 make more sense) are malloc()ed separately and not stored in
765 string_chars_blocks. Furthermore, no one string stretches across
766 two string_chars_blocks.
768 Vectors are each malloc()ed separately, similar to lcrecords.
770 In the following discussion, we use conses, but it applies equally
771 well to the other fixed-size types.
773 We store cons cells inside of cons_blocks, allocating a new
774 cons_block with malloc() whenever necessary. Cons cells reclaimed
775 by GC are put on a free list to be reallocated before allocating
776 any new cons cells from the latest cons_block. Each cons_block is
777 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
778 the versions in malloc.c and gmalloc.c) really allocates in units
779 of powers of two and uses 4 bytes for its own overhead.
781 What GC actually does is to search through all the cons_blocks,
782 from the most recently allocated to the oldest, and put all
783 cons cells that are not marked (whether or not they're already
784 free) on a cons_free_list. The cons_free_list is a stack, and
785 so the cons cells in the oldest-allocated cons_block end up
786 at the head of the stack and are the first to be reallocated.
787 If any cons_block is entirely free, it is freed with free()
788 and its cons cells removed from the cons_free_list. Because
789 the cons_free_list ends up basically in memory order, we have
790 a high locality of reference (assuming a reasonable turnover
791 of allocating and freeing) and have a reasonable probability
792 of entirely freeing up cons_blocks that have been more recently
793 allocated. This stage is called the "sweep stage" of GC, and
794 is executed after the "mark stage", which involves starting
795 from all places that are known to point to in-use Lisp objects
796 (e.g. the obarray, where are all symbols are stored; the
797 current catches and condition-cases; the backtrace list of
798 currently executing functions; the gcpro list; etc.) and
799 recursively marking all objects that are accessible.
801 At the beginning of the sweep stage, the conses in the cons
802 blocks are in one of three states: in use and marked, in use
803 but not marked, and not in use (already freed). Any conses
804 that are marked have been marked in the mark stage just
805 executed, because as part of the sweep stage we unmark any
806 marked objects. The way we tell whether or not a cons cell
807 is in use is through the FREE_STRUCT_P macro. This basically
808 looks at the first 4 bytes (or however many bytes a pointer
809 fits in) to see if all the bits in those bytes are 1. The
810 resulting value (0xFFFFFFFF) is not a valid pointer and is
811 not a valid Lisp_Object. All current fixed-size types have
812 a pointer or Lisp_Object as their first element with the
813 exception of strings; they have a size value, which can
814 never be less than zero, and so 0xFFFFFFFF is invalid for
815 strings as well. Now assuming that a cons cell is in use,
816 the way we tell whether or not it is marked is to look at
817 the mark bit of its car (each Lisp_Object has one bit
818 reserved as a mark bit, in case it's needed). Note that
819 different types of objects use different fields to indicate
820 whether the object is marked, but the principle is the same.
822 Conses on the free_cons_list are threaded through a pointer
823 stored in the bytes directly after the bytes that are set
824 to 0xFFFFFFFF (we cannot overwrite these because the cons
825 is still in a cons_block and needs to remain marked as
826 not in use for the next time that GC happens). This
827 implies that all fixed-size types must be at least big
828 enough to store two pointers, which is indeed the case
829 for all current fixed-size types.
831 Some types of objects need additional "finalization" done
832 when an object is converted from in use to not in use;
833 this is the purpose of the ADDITIONAL_FREE_type macro.
834 For example, markers need to be removed from the chain
835 of markers that is kept in each buffer. This is because
836 markers in a buffer automatically disappear if the marker
837 is no longer referenced anywhere (the same does not
838 apply to extents, however).
840 WARNING: Things are in an extremely bizarre state when
841 the ADDITIONAL_FREE_type macros are called, so beware!
843 When ERROR_CHECK_GC is defined, we do things differently
844 so as to maximize our chances of catching places where
845 there is insufficient GCPROing. The thing we want to
846 avoid is having an object that we're using but didn't
847 GCPRO get freed by GC and then reallocated while we're
848 in the process of using it -- this will result in something
849 seemingly unrelated getting trashed, and is extremely
850 difficult to track down. If the object gets freed but
851 not reallocated, we can usually catch this because we
852 set all bytes of a freed object to 0xDEADBEEF. (The
853 first four bytes, however, are 0xFFFFFFFF, and the next
854 four are a pointer used to chain freed objects together;
855 we play some tricks with this pointer to make it more
856 bogus, so crashes are more likely to occur right away.)
858 We want freed objects to stay free as long as possible,
859 so instead of doing what we do above, we maintain the
860 free objects in a first-in first-out queue. We also
861 don't recompute the free list each GC, unlike above;
862 this ensures that the queue ordering is preserved.
863 [This means that we are likely to have worse locality
864 of reference, and that we can never free a frob block
865 once it's allocated. (Even if we know that all cells
866 in it are free, there's no easy way to remove all those
867 cells from the free list because the objects on the
868 free list are unlikely to be in memory order.)]
869 Furthermore, we never take objects off the free list
870 unless there's a large number (usually 1000, but
871 varies depending on type) of them already on the list.
872 This way, we ensure that an object that gets freed will
873 remain free for the next 1000 (or whatever) times that
874 an object of that type is allocated.
877 #ifndef MALLOC_OVERHEAD
879 #define MALLOC_OVERHEAD 0
880 #elif defined (rcheck)
881 #define MALLOC_OVERHEAD 20
883 #define MALLOC_OVERHEAD 8
885 #endif /* MALLOC_OVERHEAD */
887 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
888 /* If we released our reserve (due to running out of memory),
889 and we have a fair amount free once again,
890 try to set aside another reserve in case we run out once more.
892 This is called when a relocatable block is freed in ralloc.c. */
893 void refill_memory_reserve (void);
895 refill_memory_reserve ()
897 if (breathing_space == 0)
898 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
902 #ifdef ALLOC_NO_POOLS
903 # define TYPE_ALLOC_SIZE(type, structtype) 1
905 # define TYPE_ALLOC_SIZE(type, structtype) \
906 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
907 / sizeof (structtype))
908 #endif /* ALLOC_NO_POOLS */
910 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
912 struct type##_block \
914 struct type##_block *prev; \
915 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
918 static struct type##_block *current_##type##_block; \
919 static int current_##type##_block_index; \
921 static structtype *type##_free_list; \
922 static structtype *type##_free_list_tail; \
925 init_##type##_alloc (void) \
927 current_##type##_block = 0; \
928 current_##type##_block_index = \
929 countof (current_##type##_block->block); \
930 type##_free_list = 0; \
931 type##_free_list_tail = 0; \
934 static int gc_count_num_##type##_in_use; \
935 static int gc_count_num_##type##_freelist
937 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
938 if (current_##type##_block_index \
939 == countof (current_##type##_block->block)) \
941 struct type##_block *AFTFB_new = (struct type##_block *) \
942 allocate_lisp_storage (sizeof (struct type##_block)); \
943 AFTFB_new->prev = current_##type##_block; \
944 current_##type##_block = AFTFB_new; \
945 current_##type##_block_index = 0; \
948 &(current_##type##_block->block[current_##type##_block_index++]); \
951 /* Allocate an instance of a type that is stored in blocks.
952 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
955 #ifdef ERROR_CHECK_GC
957 /* Note: if you get crashes in this function, suspect incorrect calls
958 to free_cons() and friends. This happened once because the cons
959 cell was not GC-protected and was getting collected before
960 free_cons() was called. */
962 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
965 if (gc_count_num_##type##_freelist > \
966 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
968 result = type##_free_list; \
969 /* Before actually using the chain pointer, we complement all its \
970 bits; see FREE_FIXED_TYPE(). */ \
972 (structtype *) ~(unsigned long) \
973 (* (structtype **) ((char *) result + sizeof (void *))); \
974 gc_count_num_##type##_freelist--; \
977 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
978 MARK_STRUCT_AS_NOT_FREE (result); \
981 #else /* !ERROR_CHECK_GC */
983 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
986 if (type##_free_list) \
988 result = type##_free_list; \
990 * (structtype **) ((char *) result + sizeof (void *)); \
993 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
994 MARK_STRUCT_AS_NOT_FREE (result); \
997 #endif /* !ERROR_CHECK_GC */
999 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
1002 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
1003 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
1006 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
1009 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
1010 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
1013 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
1014 to a Lisp object and invalid as an actual Lisp_Object value. We have
1015 to make sure that this value cannot be an integer in Lisp_Object form.
1016 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
1017 On a 32-bit system, the type bits will be non-zero, making the value
1018 be a pointer, and the pointer will be misaligned.
1020 Even if Emacs is run on some weirdo system that allows and allocates
1021 byte-aligned pointers, this pointer is at the very top of the address
1022 space and so it's almost inconceivable that it could ever be valid. */
1025 # define INVALID_POINTER_VALUE 0xFFFFFFFF
1027 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
1029 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
1031 You have some weird system and need to supply a reasonable value here.
1034 #define FREE_STRUCT_P(ptr) \
1035 (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
1036 #define MARK_STRUCT_AS_FREE(ptr) \
1037 (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
1038 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
1039 (* (void **) ptr = 0)
1041 #ifdef ERROR_CHECK_GC
1043 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
1044 do { if (type##_free_list_tail) \
1046 /* When we store the chain pointer, we complement all \
1047 its bits; this should significantly increase its \
1048 bogosity in case someone tries to use the value, and \
1049 should make us dump faster if someone stores something \
1050 over the pointer because when it gets un-complemented in \
1051 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
1052 extremely bogus. */ \
1054 ((char *) type##_free_list_tail + sizeof (void *)) = \
1055 (structtype *) ~(unsigned long) ptr; \
1058 type##_free_list = ptr; \
1059 type##_free_list_tail = ptr; \
1062 #else /* !ERROR_CHECK_GC */
1064 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
1065 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
1067 type##_free_list = (ptr); \
1070 #endif /* !ERROR_CHECK_GC */
1072 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
1074 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
1075 structtype *FFT_ptr = (ptr); \
1076 ADDITIONAL_FREE_##type (FFT_ptr); \
1077 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
1078 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
1079 MARK_STRUCT_AS_FREE (FFT_ptr); \
1082 /* Like FREE_FIXED_TYPE() but used when we are explicitly
1083 freeing a structure through free_cons(), free_marker(), etc.
1084 rather than through the normal process of sweeping.
1085 We attempt to undo the changes made to the allocation counters
1086 as a result of this structure being allocated. This is not
1087 completely necessary but helps keep things saner: e.g. this way,
1088 repeatedly allocating and freeing a cons will not result in
1089 the consing-since-gc counter advancing, which would cause a GC
1090 and somewhat defeat the purpose of explicitly freeing. */
1092 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
1093 do { FREE_FIXED_TYPE (type, structtype, ptr); \
1094 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
1095 gc_count_num_##type##_freelist++; \
1100 /************************************************************************/
1101 /* Cons allocation */
1102 /************************************************************************/
1104 DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons);
1105 /* conses are used and freed so often that we set this really high */
1106 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
1107 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
1111 mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object))
1113 if (GC_NILP (XCDR (obj)))
1116 markobj (XCAR (obj));
1121 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
1123 while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1))
1127 if (! CONSP (ob1) || ! CONSP (ob2))
1128 return internal_equal (ob1, ob2, depth + 1);
1133 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
1134 mark_cons, print_cons, 0,
1137 * No `hash' method needed.
1138 * internal_hash knows how to
1143 #endif /* LRECORD_CONS */
1145 DEFUN ("cons", Fcons, 2, 2, 0, /*
1146 Create a new cons, give it CAR and CDR as components, and return it.
1150 /* This cannot GC. */
1152 struct Lisp_Cons *c;
1154 ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1156 set_lheader_implementation (&(c->lheader), lrecord_cons);
1164 /* This is identical to Fcons() but it used for conses that we're
1165 going to free later, and is useful when trying to track down
1168 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
1171 struct Lisp_Cons *c;
1173 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1175 set_lheader_implementation (&(c->lheader), lrecord_cons);
1183 DEFUN ("list", Flist, 0, MANY, 0, /*
1184 Return a newly created list with specified arguments as elements.
1185 Any number of arguments, even zero arguments, are allowed.
1187 (int nargs, Lisp_Object *args))
1189 Lisp_Object val = Qnil;
1190 Lisp_Object *argp = args + nargs;
1193 val = Fcons (*--argp, val);
1198 list1 (Lisp_Object obj0)
1200 /* This cannot GC. */
1201 return Fcons (obj0, Qnil);
1205 list2 (Lisp_Object obj0, Lisp_Object obj1)
1207 /* This cannot GC. */
1208 return Fcons (obj0, Fcons (obj1, Qnil));
1212 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1214 /* This cannot GC. */
1215 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1219 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1221 /* This cannot GC. */
1222 return Fcons (obj0, Fcons (obj1, obj2));
1226 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1228 return Fcons (Fcons (key, value), alist);
1232 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1234 /* This cannot GC. */
1235 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1239 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1242 /* This cannot GC. */
1243 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1247 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1248 Lisp_Object obj4, Lisp_Object obj5)
1250 /* This cannot GC. */
1251 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1254 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1255 Return a new list of length LENGTH, with each element being INIT.
1259 CHECK_NATNUM (length);
1262 Lisp_Object val = Qnil;
1263 int size = XINT (length);
1266 val = Fcons (init, val);
1272 /************************************************************************/
1273 /* Float allocation */
1274 /************************************************************************/
1276 #ifdef LISP_FLOAT_TYPE
1278 DECLARE_FIXED_TYPE_ALLOC (float, struct Lisp_Float);
1279 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1282 make_float (double float_value)
1285 struct Lisp_Float *f;
1287 ALLOCATE_FIXED_TYPE (float, struct Lisp_Float, f);
1288 set_lheader_implementation (&(f->lheader), lrecord_float);
1289 float_data (f) = float_value;
1294 #endif /* LISP_FLOAT_TYPE */
1297 /************************************************************************/
1298 /* Vector allocation */
1299 /************************************************************************/
1301 #ifdef LRECORD_VECTOR
1303 mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
1305 Lisp_Vector *ptr = XVECTOR (obj);
1306 int len = vector_length (ptr);
1309 for (i = 0; i < len - 1; i++)
1310 markobj (ptr->contents[i]);
1311 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1315 size_vector (CONST void *lheader)
1317 return STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents,
1318 ((Lisp_Vector *) lheader)->size);
1322 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1324 int len = XVECTOR_LENGTH (obj1);
1325 if (len != XVECTOR_LENGTH (obj2))
1329 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1330 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1332 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1338 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1339 mark_vector, print_vector, 0,
1342 * No `hash' method needed for
1343 * vectors. internal_hash
1344 * knows how to handle vectors.
1347 size_vector, Lisp_Vector);
1349 /* #### should allocate `small' vectors from a frob-block */
1350 static Lisp_Vector *
1351 make_vector_internal (size_t sizei)
1353 /* no vector_next */
1354 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1355 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, lrecord_vector);
1361 #else /* ! LRECORD_VECTOR */
1363 static Lisp_Object all_vectors;
1365 /* #### should allocate `small' vectors from a frob-block */
1366 static Lisp_Vector *
1367 make_vector_internal (size_t sizei)
1369 /* + 1 to account for vector_next */
1370 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei+1);
1371 Lisp_Vector *p = (Lisp_Vector *) allocate_lisp_storage (sizem);
1373 INCREMENT_CONS_COUNTER (sizem, "vector");
1376 vector_next (p) = all_vectors;
1377 XSETVECTOR (all_vectors, p);
1381 #endif /* ! LRECORD_VECTOR */
1384 make_vector (size_t length, Lisp_Object init)
1386 Lisp_Vector *vecp = make_vector_internal (length);
1387 Lisp_Object *p = vector_data (vecp);
1394 XSETVECTOR (vector, vecp);
1399 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1400 Return a new vector of length LENGTH, with each element being INIT.
1401 See also the function `vector'.
1405 CONCHECK_NATNUM (length);
1406 return make_vector (XINT (length), init);
1409 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1410 Return a newly created vector with specified arguments as elements.
1411 Any number of arguments, even zero arguments, are allowed.
1413 (int nargs, Lisp_Object *args))
1415 Lisp_Vector *vecp = make_vector_internal (nargs);
1416 Lisp_Object *p = vector_data (vecp);
1423 XSETVECTOR (vector, vecp);
1429 vector1 (Lisp_Object obj0)
1431 return Fvector (1, &obj0);
1435 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1437 Lisp_Object args[2];
1440 return Fvector (2, args);
1444 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1446 Lisp_Object args[3];
1450 return Fvector (3, args);
1453 #if 0 /* currently unused */
1456 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1459 Lisp_Object args[4];
1464 return Fvector (4, args);
1468 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1469 Lisp_Object obj3, Lisp_Object obj4)
1471 Lisp_Object args[5];
1477 return Fvector (5, args);
1481 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1482 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1484 Lisp_Object args[6];
1491 return Fvector (6, args);
1495 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1496 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1499 Lisp_Object args[7];
1507 return Fvector (7, args);
1511 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1512 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1513 Lisp_Object obj6, Lisp_Object obj7)
1515 Lisp_Object args[8];
1524 return Fvector (8, args);
1528 /************************************************************************/
1529 /* Bit Vector allocation */
1530 /************************************************************************/
1532 static Lisp_Object all_bit_vectors;
1534 /* #### should allocate `small' bit vectors from a frob-block */
1535 static struct Lisp_Bit_Vector *
1536 make_bit_vector_internal (size_t sizei)
1538 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1539 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1540 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1541 set_lheader_implementation (&(p->lheader), lrecord_bit_vector);
1543 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1545 bit_vector_length (p) = sizei;
1546 bit_vector_next (p) = all_bit_vectors;
1547 /* make sure the extra bits in the last long are 0; the calling
1548 functions might not set them. */
1549 p->bits[num_longs - 1] = 0;
1550 XSETBIT_VECTOR (all_bit_vectors, p);
1555 make_bit_vector (size_t length, Lisp_Object init)
1557 struct Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1558 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1563 memset (p->bits, 0, num_longs * sizeof (long));
1566 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1567 memset (p->bits, ~0, num_longs * sizeof (long));
1568 /* But we have to make sure that the unused bits in the
1569 last long are 0, so that equal/hash is easy. */
1571 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1575 Lisp_Object bit_vector;
1576 XSETBIT_VECTOR (bit_vector, p);
1582 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1585 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1587 for (i = 0; i < length; i++)
1588 set_bit_vector_bit (p, i, bytevec[i]);
1591 Lisp_Object bit_vector;
1592 XSETBIT_VECTOR (bit_vector, p);
1597 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1598 Return a new bit vector of length LENGTH. with each bit being INIT.
1599 Each element is set to INIT. See also the function `bit-vector'.
1603 CONCHECK_NATNUM (length);
1605 return make_bit_vector (XINT (length), init);
1608 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1609 Return a newly created bit vector with specified arguments as elements.
1610 Any number of arguments, even zero arguments, are allowed.
1612 (int nargs, Lisp_Object *args))
1615 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1617 for (i = 0; i < nargs; i++)
1619 CHECK_BIT (args[i]);
1620 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1624 Lisp_Object bit_vector;
1625 XSETBIT_VECTOR (bit_vector, p);
1631 /************************************************************************/
1632 /* Compiled-function allocation */
1633 /************************************************************************/
1635 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1636 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1639 make_compiled_function (int make_pure)
1641 Lisp_Compiled_Function *f;
1643 size_t size = sizeof (Lisp_Compiled_Function);
1645 if (make_pure && check_purespace (size))
1647 f = (Lisp_Compiled_Function *) (PUREBEG + pure_bytes_used);
1648 set_lheader_implementation (&(f->lheader), lrecord_compiled_function);
1649 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
1650 f->lheader.pure = 1;
1652 pure_bytes_used += size;
1653 bump_purestat (&purestat_function, size);
1657 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1658 set_lheader_implementation (&(f->lheader), lrecord_compiled_function);
1661 f->specpdl_depth = 0;
1662 f->flags.documentationp = 0;
1663 f->flags.interactivep = 0;
1664 f->flags.domainp = 0; /* I18N3 */
1665 f->instructions = Qzero;
1666 f->constants = Qzero;
1668 f->doc_and_interactive = Qnil;
1669 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1670 f->annotated = Qnil;
1672 XSETCOMPILED_FUNCTION (fun, f);
1676 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1677 Return a new compiled-function object.
1678 Usage: (arglist instructions constants stack-depth
1679 &optional doc-string interactive)
1680 Note that, unlike all other emacs-lisp functions, calling this with five
1681 arguments is NOT the same as calling it with six arguments, the last of
1682 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1683 that this function was defined with `(interactive)'. If the arg is not
1684 specified, then that means the function is not interactive.
1685 This is terrible behavior which is retained for compatibility with old
1686 `.elc' files which expect these semantics.
1688 (int nargs, Lisp_Object *args))
1690 /* In a non-insane world this function would have this arglist...
1691 (arglist instructions constants stack_depth &optional doc_string interactive)
1693 Lisp_Object fun = make_compiled_function (purify_flag);
1694 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1696 Lisp_Object arglist = args[0];
1697 Lisp_Object instructions = args[1];
1698 Lisp_Object constants = args[2];
1699 Lisp_Object stack_depth = args[3];
1700 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1701 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1703 /* Don't purecopy the doc references in instructions because it's
1704 wasteful; they will get fixed up later.
1706 #### If something goes wrong and they don't get fixed up,
1707 we're screwed, because pure stuff isn't marked and thus the
1708 cons references won't be marked and will get reused.
1710 Note: there will be a window after the byte code is created and
1711 before the doc references are fixed up in which there will be
1712 impure objects inside a pure object, which apparently won't
1713 get marked, leading to trouble. But during that entire window,
1714 the objects are sitting on Vload_force_doc_string_list, which
1715 is staticpro'd, so we're OK. */
1716 Lisp_Object (*cons) (Lisp_Object, Lisp_Object)
1717 = purify_flag ? pure_cons : Fcons;
1719 if (nargs < 4 || nargs > 6)
1720 return Fsignal (Qwrong_number_of_arguments,
1721 list2 (intern ("make-byte-code"), make_int (nargs)));
1723 /* Check for valid formal parameter list now, to allow us to use
1724 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1726 Lisp_Object symbol, tail;
1727 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1729 CHECK_SYMBOL (symbol);
1730 if (EQ (symbol, Qt) ||
1731 EQ (symbol, Qnil) ||
1732 SYMBOL_IS_KEYWORD (symbol))
1733 signal_simple_error_2
1734 ("Invalid constant symbol in formal parameter list",
1738 f->arglist = arglist;
1740 /* `instructions' is a string or a cons (string . int) for a
1741 lazy-loaded function. */
1742 if (CONSP (instructions))
1744 CHECK_STRING (XCAR (instructions));
1745 CHECK_INT (XCDR (instructions));
1749 CHECK_STRING (instructions);
1751 f->instructions = instructions;
1753 if (!NILP (constants))
1754 CHECK_VECTOR (constants);
1755 f->constants = constants;
1757 CHECK_NATNUM (stack_depth);
1758 f->stack_depth = XINT (stack_depth);
1760 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1761 if (!NILP (Vcurrent_compiled_function_annotation))
1762 f->annotated = Fpurecopy (Vcurrent_compiled_function_annotation);
1763 else if (!NILP (Vload_file_name_internal_the_purecopy))
1764 f->annotated = Vload_file_name_internal_the_purecopy;
1765 else if (!NILP (Vload_file_name_internal))
1767 struct gcpro gcpro1;
1768 GCPRO1 (fun); /* don't let fun get reaped */
1769 Vload_file_name_internal_the_purecopy =
1770 Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
1771 f->annotated = Vload_file_name_internal_the_purecopy;
1774 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1776 /* doc_string may be nil, string, int, or a cons (string . int).
1777 interactive may be list or string (or unbound). */
1778 f->doc_and_interactive = Qunbound;
1780 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1781 f->doc_and_interactive = Vfile_domain;
1783 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1787 interactive = Fpurecopy (interactive);
1788 if (STRINGP (interactive))
1789 bump_purestat (&purestat_string_interactive,
1790 pure_sizeof (interactive));
1792 f->doc_and_interactive
1793 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1794 cons (interactive, f->doc_and_interactive));
1796 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1800 doc_string = Fpurecopy (doc_string);
1801 if (STRINGP (doc_string))
1802 /* These should have been snagged by make-docfile... */
1803 bump_purestat (&purestat_string_documentation,
1804 pure_sizeof (doc_string));
1806 f->doc_and_interactive
1807 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1808 cons (doc_string, f->doc_and_interactive));
1810 if (UNBOUNDP (f->doc_and_interactive))
1811 f->doc_and_interactive = Qnil;
1816 if (!purified (f->arglist))
1817 f->arglist = Fpurecopy (f->arglist);
1819 /* Statistics are kept differently for the constants */
1820 if (!purified (f->constants))
1823 int old = purecopying_function_constants;
1824 purecopying_function_constants = 1;
1825 f->constants = Fpurecopy (f->constants);
1826 bump_purestat (&purestat_vector_constants,
1827 pure_sizeof (f->constants));
1828 purecopying_function_constants = old;
1830 f->constants = Fpurecopy (f->constants);
1831 #endif /* PURESTAT */
1834 optimize_compiled_function (fun);
1836 bump_purestat (&purestat_opaque_instructions,
1837 pure_sizeof (f->instructions));
1844 /************************************************************************/
1845 /* Symbol allocation */
1846 /************************************************************************/
1848 DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol);
1849 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1851 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1852 Return a newly allocated uninterned symbol whose name is NAME.
1853 Its value and function definition are void, and its property list is nil.
1858 struct Lisp_Symbol *p;
1860 CHECK_STRING (name);
1862 ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p);
1863 #ifdef LRECORD_SYMBOL
1864 set_lheader_implementation (&(p->lheader), lrecord_symbol);
1866 p->name = XSTRING (name);
1868 p->value = Qunbound;
1869 p->function = Qunbound;
1871 symbol_next (p) = 0;
1872 XSETSYMBOL (val, p);
1877 /************************************************************************/
1878 /* Extent allocation */
1879 /************************************************************************/
1881 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1882 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1885 allocate_extent (void)
1889 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1890 set_lheader_implementation (&(e->lheader), lrecord_extent);
1891 extent_object (e) = Qnil;
1892 set_extent_start (e, -1);
1893 set_extent_end (e, -1);
1898 extent_face (e) = Qnil;
1899 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1900 e->flags.detachable = 1;
1906 /************************************************************************/
1907 /* Event allocation */
1908 /************************************************************************/
1910 DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event);
1911 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1914 allocate_event (void)
1917 struct Lisp_Event *e;
1919 ALLOCATE_FIXED_TYPE (event, struct Lisp_Event, e);
1920 set_lheader_implementation (&(e->lheader), lrecord_event);
1927 /************************************************************************/
1928 /* Marker allocation */
1929 /************************************************************************/
1931 DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker);
1932 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1934 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1935 Return a new marker which does not point at any place.
1940 struct Lisp_Marker *p;
1942 ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1943 set_lheader_implementation (&(p->lheader), lrecord_marker);
1946 marker_next (p) = 0;
1947 marker_prev (p) = 0;
1948 p->insertion_type = 0;
1949 XSETMARKER (val, p);
1954 noseeum_make_marker (void)
1957 struct Lisp_Marker *p;
1959 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1960 set_lheader_implementation (&(p->lheader), lrecord_marker);
1963 marker_next (p) = 0;
1964 marker_prev (p) = 0;
1965 p->insertion_type = 0;
1966 XSETMARKER (val, p);
1971 /************************************************************************/
1972 /* String allocation */
1973 /************************************************************************/
1975 /* The data for "short" strings generally resides inside of structs of type
1976 string_chars_block. The Lisp_String structure is allocated just like any
1977 other Lisp object (except for vectors), and these are freelisted when
1978 they get garbage collected. The data for short strings get compacted,
1979 but the data for large strings do not.
1981 Previously Lisp_String structures were relocated, but this caused a lot
1982 of bus-errors because the C code didn't include enough GCPRO's for
1983 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1984 that the reference would get relocated).
1986 This new method makes things somewhat bigger, but it is MUCH safer. */
1988 DECLARE_FIXED_TYPE_ALLOC (string, struct Lisp_String);
1989 /* strings are used and freed quite often */
1990 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1991 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1993 #ifdef LRECORD_STRING
1995 mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object))
1997 struct Lisp_String *ptr = XSTRING (obj);
1999 if (GC_CONSP (ptr->plist) && GC_EXTENT_INFOP (XCAR (ptr->plist)))
2000 flush_cached_extent_info (XCAR (ptr->plist));
2005 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2008 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
2009 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
2012 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
2013 mark_string, print_string,
2015 * No `finalize', or `hash' methods.
2016 * internal_hash already knows how
2017 * to hash strings and finalization
2019 * ADDITIONAL_FREE_string macro,
2020 * which is the standard way to do
2021 * finalization when using
2022 * SWEEP_FIXED_TYPE_BLOCK().
2025 struct Lisp_String);
2026 #endif /* LRECORD_STRING */
2028 /* String blocks contain this many useful bytes. */
2029 #define STRING_CHARS_BLOCK_SIZE \
2030 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
2031 ((2 * sizeof (struct string_chars_block *)) \
2032 + sizeof (EMACS_INT))))
2033 /* Block header for small strings. */
2034 struct string_chars_block
2037 struct string_chars_block *next;
2038 struct string_chars_block *prev;
2039 /* Contents of string_chars_block->string_chars are interleaved
2040 string_chars structures (see below) and the actual string data */
2041 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
2044 struct string_chars_block *first_string_chars_block;
2045 struct string_chars_block *current_string_chars_block;
2047 /* If SIZE is the length of a string, this returns how many bytes
2048 * the string occupies in string_chars_block->string_chars
2049 * (including alignment padding).
2051 #define STRING_FULLSIZE(s) \
2052 ALIGN_SIZE (((s) + 1 + sizeof (struct Lisp_String *)),\
2053 ALIGNOF (struct Lisp_String *))
2055 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
2056 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
2058 #define CHARS_TO_STRING_CHAR(x) \
2059 ((struct string_chars *) \
2060 (((char *) (x)) - (slot_offset (struct string_chars, chars[0]))))
2065 struct Lisp_String *string;
2066 unsigned char chars[1];
2069 struct unused_string_chars
2071 struct Lisp_String *string;
2076 init_string_chars_alloc (void)
2078 first_string_chars_block = xnew (struct string_chars_block);
2079 first_string_chars_block->prev = 0;
2080 first_string_chars_block->next = 0;
2081 first_string_chars_block->pos = 0;
2082 current_string_chars_block = first_string_chars_block;
2085 static struct string_chars *
2086 allocate_string_chars_struct (struct Lisp_String *string_it_goes_with,
2089 struct string_chars *s_chars;
2091 /* Allocate the string's actual data */
2092 if (BIG_STRING_FULLSIZE_P (fullsize))
2094 s_chars = (struct string_chars *) xmalloc (fullsize);
2096 else if (fullsize <=
2097 (countof (current_string_chars_block->string_chars)
2098 - current_string_chars_block->pos))
2100 /* This string can fit in the current string chars block */
2101 s_chars = (struct string_chars *)
2102 (current_string_chars_block->string_chars
2103 + current_string_chars_block->pos);
2104 current_string_chars_block->pos += fullsize;
2108 /* Make a new current string chars block */
2109 struct string_chars_block *new_scb = xnew (struct string_chars_block);
2111 current_string_chars_block->next = new_scb;
2112 new_scb->prev = current_string_chars_block;
2114 current_string_chars_block = new_scb;
2115 new_scb->pos = fullsize;
2116 s_chars = (struct string_chars *)
2117 current_string_chars_block->string_chars;
2120 s_chars->string = string_it_goes_with;
2122 INCREMENT_CONS_COUNTER (fullsize, "string chars");
2128 make_uninit_string (Bytecount length)
2130 struct Lisp_String *s;
2131 struct string_chars *s_chars;
2132 EMACS_INT fullsize = STRING_FULLSIZE (length);
2135 if ((length < 0) || (fullsize <= 0))
2138 /* Allocate the string header */
2139 ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
2140 #ifdef LRECORD_STRING
2141 set_lheader_implementation (&(s->lheader), lrecord_string);
2144 s_chars = allocate_string_chars_struct (s, fullsize);
2146 set_string_data (s, &(s_chars->chars[0]));
2147 set_string_length (s, length);
2150 set_string_byte (s, length, 0);
2152 XSETSTRING (val, s);
2156 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2157 static void verify_string_chars_integrity (void);
2160 /* Resize the string S so that DELTA bytes can be inserted starting
2161 at POS. If DELTA < 0, it means deletion starting at POS. If
2162 POS < 0, resize the string but don't copy any characters. Use
2163 this if you're planning on completely overwriting the string.
2167 resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta)
2169 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2170 verify_string_chars_integrity ();
2173 #ifdef ERROR_CHECK_BUFPOS
2176 assert (pos <= string_length (s));
2178 assert (pos + (-delta) <= string_length (s));
2183 assert ((-delta) <= string_length (s));
2185 #endif /* ERROR_CHECK_BUFPOS */
2187 if (pos >= 0 && delta < 0)
2188 /* If DELTA < 0, the functions below will delete the characters
2189 before POS. We want to delete characters *after* POS, however,
2190 so convert this to the appropriate form. */
2194 /* simplest case: no size change. */
2198 Bytecount oldfullsize = STRING_FULLSIZE (string_length (s));
2199 Bytecount newfullsize = STRING_FULLSIZE (string_length (s) + delta);
2201 if (oldfullsize == newfullsize)
2203 /* next simplest case; size change but the necessary
2204 allocation size won't change (up or down; code somewhere
2205 depends on there not being any unused allocation space,
2206 modulo any alignment constraints). */
2209 Bufbyte *addroff = pos + string_data (s);
2211 memmove (addroff + delta, addroff,
2212 /* +1 due to zero-termination. */
2213 string_length (s) + 1 - pos);
2216 else if (BIG_STRING_FULLSIZE_P (oldfullsize) &&
2217 BIG_STRING_FULLSIZE_P (newfullsize))
2219 /* next simplest case; the string is big enough to be malloc()ed
2220 itself, so we just realloc.
2222 It's important not to let the string get below the threshold
2223 for making big strings and still remain malloc()ed; if that
2224 were the case, repeated calls to this function on the same
2225 string could result in memory leakage. */
2226 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
2230 Bufbyte *addroff = pos + string_data (s);
2232 memmove (addroff + delta, addroff,
2233 /* +1 due to zero-termination. */
2234 string_length (s) + 1 - pos);
2239 /* worst case. We make a new string_chars struct and copy
2240 the string's data into it, inserting/deleting the delta
2241 in the process. The old string data will either get
2242 freed by us (if it was malloc()ed) or will be reclaimed
2243 in the normal course of garbage collection. */
2244 struct string_chars *s_chars =
2245 allocate_string_chars_struct (s, newfullsize);
2246 Bufbyte *new_addr = &(s_chars->chars[0]);
2247 Bufbyte *old_addr = string_data (s);
2250 memcpy (new_addr, old_addr, pos);
2251 memcpy (new_addr + pos + delta, old_addr + pos,
2252 string_length (s) + 1 - pos);
2254 set_string_data (s, new_addr);
2255 if (BIG_STRING_FULLSIZE_P (oldfullsize))
2259 /* We need to mark this chunk of the string_chars_block
2260 as unused so that compact_string_chars() doesn't
2262 struct string_chars *old_s_chars =
2263 (struct string_chars *) ((char *) old_addr -
2264 sizeof (struct Lisp_String *));
2265 /* Sanity check to make sure we aren't hosed by strange
2266 alignment/padding. */
2267 assert (old_s_chars->string == s);
2268 MARK_STRUCT_AS_FREE (old_s_chars);
2269 ((struct unused_string_chars *) old_s_chars)->fullsize =
2274 set_string_length (s, string_length (s) + delta);
2275 /* If pos < 0, the string won't be zero-terminated.
2276 Terminate now just to make sure. */
2277 string_data (s)[string_length (s)] = '\0';
2283 XSETSTRING (string, s);
2284 /* We also have to adjust all of the extent indices after the
2285 place we did the change. We say "pos - 1" because
2286 adjust_extents() is exclusive of the starting position
2288 adjust_extents (string, pos - 1, string_length (s),
2293 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2294 verify_string_chars_integrity ();
2301 set_string_char (struct Lisp_String *s, Charcount i, Emchar c)
2303 Bufbyte newstr[MAX_EMCHAR_LEN];
2304 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2305 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2306 Bytecount newlen = set_charptr_emchar (newstr, c);
2308 if (oldlen != newlen)
2309 resize_string (s, bytoff, newlen - oldlen);
2310 /* Remember, string_data (s) might have changed so we can't cache it. */
2311 memcpy (string_data (s) + bytoff, newstr, newlen);
2316 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2317 Return a new string of length LENGTH, with each character being INIT.
2318 LENGTH must be an integer and INIT must be a character.
2322 CHECK_NATNUM (length);
2323 CHECK_CHAR_COERCE_INT (init);
2325 Bufbyte init_str[MAX_EMCHAR_LEN];
2326 int len = set_charptr_emchar (init_str, XCHAR (init));
2327 Lisp_Object val = make_uninit_string (len * XINT (length));
2330 /* Optimize the single-byte case */
2331 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2335 Bufbyte *ptr = XSTRING_DATA (val);
2337 for (i = XINT (length); i; i--)
2339 Bufbyte *init_ptr = init_str;
2342 case 4: *ptr++ = *init_ptr++;
2343 case 3: *ptr++ = *init_ptr++;
2344 case 2: *ptr++ = *init_ptr++;
2345 case 1: *ptr++ = *init_ptr++;
2353 DEFUN ("string", Fstring, 0, MANY, 0, /*
2354 Concatenate all the argument characters and make the result a string.
2356 (int nargs, Lisp_Object *args))
2358 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2359 Bufbyte *p = storage;
2361 for (; nargs; nargs--, args++)
2363 Lisp_Object lisp_char = *args;
2364 CHECK_CHAR_COERCE_INT (lisp_char);
2365 p += set_charptr_emchar (p, XCHAR (lisp_char));
2367 return make_string (storage, p - storage);
2370 /* Take some raw memory, which MUST already be in internal format,
2371 and package it up into a Lisp string. */
2373 make_string (CONST Bufbyte *contents, Bytecount length)
2377 /* Make sure we find out about bad make_string's when they happen */
2378 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2379 bytecount_to_charcount (contents, length); /* Just for the assertions */
2382 val = make_uninit_string (length);
2383 memcpy (XSTRING_DATA (val), contents, length);
2387 /* Take some raw memory, encoded in some external data format,
2388 and convert it into a Lisp string. */
2390 make_ext_string (CONST Extbyte *contents, EMACS_INT length,
2391 enum external_data_format fmt)
2396 GET_CHARPTR_INT_DATA_ALLOCA (contents, length, fmt, intstr, intlen);
2397 return make_string (intstr, intlen);
2401 build_string (CONST char *str)
2403 /* Some strlen's crash and burn if passed null. */
2404 return make_string ((CONST Bufbyte *) str, (str ? strlen(str) : 0));
2408 build_ext_string (CONST char *str, enum external_data_format fmt)
2410 /* Some strlen's crash and burn if passed null. */
2411 return make_ext_string ((CONST Extbyte *) str, (str ? strlen(str) : 0), fmt);
2415 build_translated_string (CONST char *str)
2417 return build_string (GETTEXT (str));
2421 /************************************************************************/
2422 /* lcrecord lists */
2423 /************************************************************************/
2425 /* Lcrecord lists are used to manage the allocation of particular
2426 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2427 malloc() and garbage-collection junk) as much as possible.
2428 It is similar to the Blocktype class.
2432 1) Create an lcrecord-list object using make_lcrecord_list().
2433 This is often done at initialization. Remember to staticpro
2434 this object! The arguments to make_lcrecord_list() are the
2435 same as would be passed to alloc_lcrecord().
2436 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2437 and pass the lcrecord-list earlier created.
2438 3) When done with the lcrecord, call free_managed_lcrecord().
2439 The standard freeing caveats apply: ** make sure there are no
2440 pointers to the object anywhere! **
2441 4) Calling free_managed_lcrecord() is just like kissing the
2442 lcrecord goodbye as if it were garbage-collected. This means:
2443 -- the contents of the freed lcrecord are undefined, and the
2444 contents of something produced by allocate_managed_lcrecord()
2445 are undefined, just like for alloc_lcrecord().
2446 -- the mark method for the lcrecord's type will *NEVER* be called
2448 -- the finalize method for the lcrecord's type will be called
2449 at the time that free_managed_lcrecord() is called.
2454 mark_lcrecord_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
2456 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2457 Lisp_Object chain = list->free;
2459 while (!NILP (chain))
2461 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2462 struct free_lcrecord_header *free_header =
2463 (struct free_lcrecord_header *) lheader;
2465 #ifdef ERROR_CHECK_GC
2466 CONST struct lrecord_implementation *implementation
2467 = LHEADER_IMPLEMENTATION(lheader);
2469 /* There should be no other pointers to the free list. */
2470 assert (!MARKED_RECORD_HEADER_P (lheader));
2471 /* Only lcrecords should be here. */
2472 assert (!implementation->basic_p);
2473 /* Only free lcrecords should be here. */
2474 assert (free_header->lcheader.free);
2475 /* The type of the lcrecord must be right. */
2476 assert (implementation == list->implementation);
2477 /* So must the size. */
2478 assert (implementation->static_size == 0
2479 || implementation->static_size == list->size);
2480 #endif /* ERROR_CHECK_GC */
2482 MARK_RECORD_HEADER (lheader);
2483 chain = free_header->chain;
2489 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2490 mark_lcrecord_list, internal_object_printer,
2491 0, 0, 0, struct lcrecord_list);
2493 make_lcrecord_list (size_t size,
2494 CONST struct lrecord_implementation *implementation)
2496 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2497 lrecord_lcrecord_list);
2500 p->implementation = implementation;
2503 XSETLCRECORD_LIST (val, p);
2508 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2510 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2511 if (!NILP (list->free))
2513 Lisp_Object val = list->free;
2514 struct free_lcrecord_header *free_header =
2515 (struct free_lcrecord_header *) XPNTR (val);
2517 #ifdef ERROR_CHECK_GC
2518 struct lrecord_header *lheader =
2519 (struct lrecord_header *) free_header;
2520 CONST struct lrecord_implementation *implementation
2521 = LHEADER_IMPLEMENTATION (lheader);
2523 /* There should be no other pointers to the free list. */
2524 assert (!MARKED_RECORD_HEADER_P (lheader));
2525 /* Only lcrecords should be here. */
2526 assert (!implementation->basic_p);
2527 /* Only free lcrecords should be here. */
2528 assert (free_header->lcheader.free);
2529 /* The type of the lcrecord must be right. */
2530 assert (implementation == list->implementation);
2531 /* So must the size. */
2532 assert (implementation->static_size == 0
2533 || implementation->static_size == list->size);
2534 #endif /* ERROR_CHECK_GC */
2535 list->free = free_header->chain;
2536 free_header->lcheader.free = 0;
2543 XSETOBJ (val, Lisp_Type_Record,
2544 alloc_lcrecord (list->size, list->implementation));
2550 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2552 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2553 struct free_lcrecord_header *free_header =
2554 (struct free_lcrecord_header *) XPNTR (lcrecord);
2555 struct lrecord_header *lheader =
2556 (struct lrecord_header *) free_header;
2557 CONST struct lrecord_implementation *implementation
2558 = LHEADER_IMPLEMENTATION (lheader);
2560 #ifdef ERROR_CHECK_GC
2561 /* Make sure the size is correct. This will catch, for example,
2562 putting a window configuration on the wrong free list. */
2563 if (implementation->size_in_bytes_method)
2564 assert (implementation->size_in_bytes_method (lheader) == list->size);
2566 assert (implementation->static_size == list->size);
2567 #endif /* ERROR_CHECK_GC */
2569 if (implementation->finalizer)
2570 implementation->finalizer (lheader, 0);
2571 free_header->chain = list->free;
2572 free_header->lcheader.free = 1;
2573 list->free = lcrecord;
2577 /************************************************************************/
2578 /* Purity of essence, peace on earth */
2579 /************************************************************************/
2581 static int symbols_initialized;
2584 make_pure_string (CONST Bufbyte *data, Bytecount length,
2585 Lisp_Object plist, int no_need_to_copy_data)
2588 size_t size = sizeof (Lisp_String) +
2589 (no_need_to_copy_data ? 0 : (length + 1)); /* + 1 for terminating 0 */
2590 size = ALIGN_SIZE (size, ALIGNOF (Lisp_Object));
2592 if (symbols_initialized && !pure_lossage)
2594 /* Try to share some names. Saves a few kbytes. */
2595 Lisp_Object tem = oblookup (Vobarray, data, length);
2598 s = XSYMBOL (tem)->name;
2599 if (!PURIFIED (s)) abort ();
2603 XSETSTRING (string, s);
2609 if (!check_purespace (size))
2610 return make_string (data, length);
2612 s = (Lisp_String *) (PUREBEG + pure_bytes_used);
2613 #ifdef LRECORD_STRING
2614 set_lheader_implementation (&(s->lheader), lrecord_string);
2615 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2616 s->lheader.pure = 1;
2619 set_string_length (s, length);
2620 if (no_need_to_copy_data)
2622 set_string_data (s, (Bufbyte *) data);
2626 set_string_data (s, (Bufbyte *) s + sizeof (Lisp_String));
2627 memcpy (string_data (s), data, length);
2628 set_string_byte (s, length, 0);
2631 pure_bytes_used += size;
2634 bump_purestat (&purestat_string_all, size);
2635 if (purecopying_function_constants)
2636 bump_purestat (&purestat_string_other_function, size);
2637 #endif /* PURESTAT */
2639 /* Do this after the official "completion" of the purecopying. */
2640 s->plist = Fpurecopy (plist);
2644 XSETSTRING (string, s);
2651 make_pure_pname (CONST Bufbyte *data, Bytecount length,
2652 int no_need_to_copy_data)
2654 Lisp_Object name = make_pure_string (data, length, Qnil,
2655 no_need_to_copy_data);
2656 bump_purestat (&purestat_string_pname, pure_sizeof (name));
2658 /* We've made (at least) Qnil now, and Vobarray will soon be set up. */
2659 symbols_initialized = 1;
2666 pure_cons (Lisp_Object car, Lisp_Object cdr)
2670 if (!check_purespace (sizeof (Lisp_Cons)))
2671 return Fcons (Fpurecopy (car), Fpurecopy (cdr));
2673 c = (Lisp_Cons *) (PUREBEG + pure_bytes_used);
2675 set_lheader_implementation (&(c->lheader), lrecord_cons);
2676 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2677 c->lheader.pure = 1;
2680 pure_bytes_used += sizeof (Lisp_Cons);
2681 bump_purestat (&purestat_cons, sizeof (Lisp_Cons));
2683 c->car = Fpurecopy (car);
2684 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)
2760 size_t size = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, len);
2762 init = Fpurecopy (init);
2764 if (!check_purespace (size))
2765 return make_vector (len, init);
2767 v = (Lisp_Vector *) (PUREBEG + pure_bytes_used);
2768 #ifdef LRECORD_VECTOR
2769 set_lheader_implementation (&(v->header.lheader), lrecord_vector);
2770 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2771 v->header.lheader.pure = 1;
2774 pure_bytes_used += size;
2775 bump_purestat (&purestat_vector_all, size);
2779 for (size = 0; size < len; size++)
2780 v->contents[size] = init;
2784 XSETVECTOR (vector, v);
2790 /* Presently unused */
2792 alloc_pure_lrecord (int size, struct lrecord_implementation *implementation)
2794 struct lrecord_header *header = (void *) (PUREBEG + pure_bytes_used);
2796 if (pure_bytes_used + size > get_PURESIZE())
2797 pure_storage_exhausted ();
2799 set_lheader_implementation (header, implementation);
2807 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2808 Make a copy of OBJECT in pure storage.
2809 Recursively copies contents of vectors and cons cells.
2810 Does not copy symbols.
2818 else if (!POINTER_TYPE_P (XTYPE (obj))
2819 || PURIFIED (XPNTR (obj))
2820 /* happens when bootstrapping Qnil */
2821 || EQ (obj, Qnull_pointer))
2825 /* Order of subsequent tests determined via profiling. */
2826 else if (SYMBOLP (obj))
2828 /* Symbols can't be made pure (and thus read-only), because
2829 assigning to their function, value or plist slots would
2830 produced a SEGV in the dumped XEmacs. So we previously would
2831 just return the symbol unchanged.
2833 But purified aggregate objects like lists and vectors can
2834 contain uninterned symbols. If there are no other non-pure
2835 references to the symbol, then the symbol is not protected
2836 from garbage collection because the collector does not mark
2837 the contents of purified objects. So to protect the symbols,
2838 an impure reference has to be kept for each uninterned symbol
2839 that is referenced by a pure object. All such symbols are
2840 stored in the hash table pointed to by
2841 Vpure_uninterned_symbol_table, which is itself
2843 if (NILP (XSYMBOL (obj)->obarray))
2844 Fputhash (obj, Qnil, Vpure_uninterned_symbol_table);
2847 else if (CONSP (obj))
2849 return pure_cons (XCAR (obj), XCDR (obj));
2851 else if (STRINGP (obj))
2853 return make_pure_string (XSTRING_DATA (obj),
2854 XSTRING_LENGTH (obj),
2855 XSTRING (obj)->plist,
2858 else if (VECTORP (obj))
2861 Lisp_Vector *o = XVECTOR (obj);
2862 Lisp_Object pure_obj = make_pure_vector (vector_length (o), Qnil);
2863 for (i = 0; i < vector_length (o); i++)
2864 XVECTOR_DATA (pure_obj)[i] = Fpurecopy (o->contents[i]);
2867 #ifdef LISP_FLOAT_TYPE
2868 else if (FLOATP (obj))
2870 return make_pure_float (XFLOAT_DATA (obj));
2873 else if (COMPILED_FUNCTIONP (obj))
2875 Lisp_Object pure_obj = make_compiled_function (1);
2876 Lisp_Compiled_Function *o = XCOMPILED_FUNCTION (obj);
2877 Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (pure_obj);
2878 n->flags = o->flags;
2879 n->instructions = o->instructions;
2880 n->constants = Fpurecopy (o->constants);
2881 n->arglist = Fpurecopy (o->arglist);
2882 n->doc_and_interactive = Fpurecopy (o->doc_and_interactive);
2883 n->stack_depth = o->stack_depth;
2884 optimize_compiled_function (pure_obj);
2887 else if (OPAQUEP (obj))
2889 Lisp_Object pure_obj;
2890 Lisp_Opaque *old_opaque = XOPAQUE (obj);
2891 Lisp_Opaque *new_opaque = (Lisp_Opaque *) (PUREBEG + pure_bytes_used);
2892 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2893 CONST struct lrecord_implementation *implementation
2894 = LHEADER_IMPLEMENTATION (lheader);
2895 size_t size = implementation->size_in_bytes_method (lheader);
2896 size_t pure_size = ALIGN_SIZE (size, ALIGNOF (Lisp_Object));
2897 if (!check_purespace (pure_size))
2899 pure_bytes_used += pure_size;
2901 memcpy (new_opaque, old_opaque, size);
2902 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2905 new_opaque->header.next = 0;
2907 XSETOPAQUE (pure_obj, new_opaque);
2912 signal_simple_error ("Can't purecopy %S", obj);
2914 return obj; /* Unreached */
2920 puresize_adjust_h (size_t puresize)
2922 FILE *stream = fopen ("puresize-adjust.h", "w");
2925 report_file_error ("Opening puresize adjustment file",
2926 Fcons (build_string ("puresize-adjust.h"), Qnil));
2929 "/*\tDo not edit this file!\n"
2930 "\tAutomatically generated by XEmacs */\n"
2931 "# define PURESIZE_ADJUSTMENT (%ld)\n",
2932 (long) (puresize - RAW_PURESIZE));
2937 report_pure_usage (int report_impurities,
2938 int die_if_pure_storage_exceeded)
2944 message ("\n****\tPure Lisp storage exhausted!\n"
2945 "\tPurespace usage: %ld of %ld\n"
2947 (long) get_PURESIZE() + pure_lossage,
2948 (long) get_PURESIZE());
2949 if (die_if_pure_storage_exceeded)
2951 puresize_adjust_h (get_PURESIZE() + pure_lossage);
2960 size_t lost = (get_PURESIZE() - pure_bytes_used) / 1024;
2962 /* extern Lisp_Object Vemacs_beta_version; */
2963 /* This used to be NILP(Vemacs_beta_version) ? 512 : 4; */
2964 #ifndef PURESIZE_SLOP
2965 #define PURESIZE_SLOP 0
2967 size_t slop = PURESIZE_SLOP;
2969 sprintf (buf, "Purespace usage: %ld of %ld (%d%%",
2970 (long) pure_bytes_used,
2971 (long) get_PURESIZE(),
2972 (int) (pure_bytes_used / (get_PURESIZE() / 100.0) + 0.5));
2973 if (lost > ((slop ? slop : 1) / 1024)) {
2974 sprintf (buf + strlen (buf), " -- %ldk wasted", (long)lost);
2975 if (die_if_pure_storage_exceeded) {
2976 puresize_adjust_h (pure_bytes_used + slop);
2985 message ("%s", buf);
2990 purestat_vector_other.nbytes =
2991 purestat_vector_all.nbytes -
2992 purestat_vector_constants.nbytes;
2993 purestat_vector_other.nobjects =
2994 purestat_vector_all.nobjects -
2995 purestat_vector_constants.nobjects;
2997 purestat_string_other.nbytes =
2998 purestat_string_all.nbytes -
2999 (purestat_string_pname.nbytes +
3000 purestat_string_interactive.nbytes +
3001 purestat_string_documentation.nbytes +
3003 purestat_string_domain.nbytes +
3005 purestat_string_other_function.nbytes);
3007 purestat_string_other.nobjects =
3008 purestat_string_all.nobjects -
3009 (purestat_string_pname.nobjects +
3010 purestat_string_interactive.nobjects +
3011 purestat_string_documentation.nobjects +
3013 purestat_string_domain.nobjects +
3015 purestat_string_other_function.nobjects);
3017 message (" %-34s Objects Bytes", "");
3019 print_purestat (&purestat_cons);
3020 print_purestat (&purestat_float);
3021 print_purestat (&purestat_string_pname);
3022 print_purestat (&purestat_function);
3023 print_purestat (&purestat_opaque_instructions);
3024 print_purestat (&purestat_vector_constants);
3025 print_purestat (&purestat_string_interactive);
3027 print_purestat (&purestat_string_domain);
3029 print_purestat (&purestat_string_documentation);
3030 print_purestat (&purestat_string_other_function);
3031 print_purestat (&purestat_vector_other);
3032 print_purestat (&purestat_string_other);
3033 print_purestat (&purestat_string_all);
3034 print_purestat (&purestat_vector_all);
3036 #endif /* PURESTAT */
3039 if (report_impurities)
3042 struct gcpro gcpro1;
3043 plist = XCAR (XCDR (XCDR (XCDR (XCDR (XCDR (Fgarbage_collect()))))));
3045 message ("\nImpurities:");
3046 for (; CONSP (plist); plist = XCDR (XCDR (plist)))
3048 Lisp_Object symbol = XCAR (plist);
3049 int size = XINT (XCAR (XCDR (plist)));
3055 string_data (XSYMBOL (symbol)->name),
3056 string_length (XSYMBOL (symbol)->name) + 1);
3057 while (*s++) if (*s == '-') *s = ' ';
3058 *(s-1) = ':'; *s = 0;
3059 message (" %-34s %6d", buf, size);
3063 garbage_collect_1 (); /* collect Fgarbage_collect()'s garbage */
3068 unlink("SATISFIED");
3069 fatal ("Pure size adjusted, Don't Panic! I will restart the `make'");
3070 } else if (pure_lossage && die_if_pure_storage_exceeded) {
3071 fatal ("Pure storage exhausted");
3076 /************************************************************************/
3077 /* Garbage Collection */
3078 /************************************************************************/
3080 /* This will be used more extensively In The Future */
3081 static int last_lrecord_type_index_assigned;
3083 CONST struct lrecord_implementation *lrecord_implementations_table[128];
3084 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
3086 struct gcpro *gcprolist;
3088 /* 415 used Mly 29-Jun-93 */
3089 /* 1327 used slb 28-Feb-98 */
3091 #define NSTATICS 4000
3093 #define NSTATICS 2000
3095 /* Not "static" because of linker lossage on some systems */
3096 Lisp_Object *staticvec[NSTATICS]
3097 /* Force it into data space! */
3099 static int staticidx;
3101 /* Put an entry in staticvec, pointing at the variable whose address is given
3104 staticpro (Lisp_Object *varaddress)
3106 if (staticidx >= countof (staticvec))
3107 /* #### This is now a dubious abort() since this routine may be called */
3108 /* by Lisp attempting to load a DLL. */
3110 staticvec[staticidx++] = varaddress;
3114 /* Mark reference to a Lisp_Object. If the object referred to has not been
3115 seen yet, recursively mark all the references contained in it. */
3118 mark_object (Lisp_Object obj)
3122 #ifdef ERROR_CHECK_GC
3123 assert (! (GC_EQ (obj, Qnull_pointer)));
3125 /* Checks we used to perform */
3126 /* if (EQ (obj, Qnull_pointer)) return; */
3127 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3128 /* if (PURIFIED (XPNTR (obj))) return; */
3130 switch (XGCTYPE (obj))
3132 #ifndef LRECORD_CONS
3133 case Lisp_Type_Cons:
3135 struct Lisp_Cons *ptr = XCONS (obj);
3138 if (CONS_MARKED_P (ptr))
3141 /* If the cdr is nil, tail-recurse on the car. */
3142 if (GC_NILP (ptr->cdr))
3148 mark_object (ptr->car);
3155 case Lisp_Type_Record:
3157 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3158 #if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION)
3159 assert (lheader->type <= last_lrecord_type_index_assigned);
3161 if (PURIFIED (lheader))
3164 if (! MARKED_RECORD_HEADER_P (lheader) &&
3165 ! UNMARKABLE_RECORD_HEADER_P (lheader))
3167 CONST struct lrecord_implementation *implementation =
3168 LHEADER_IMPLEMENTATION (lheader);
3169 MARK_RECORD_HEADER (lheader);
3170 #ifdef ERROR_CHECK_GC
3171 if (!implementation->basic_p)
3172 assert (! ((struct lcrecord_header *) lheader)->free);
3174 if (implementation->marker)
3176 obj = implementation->marker (obj, mark_object);
3177 if (!GC_NILP (obj)) goto tail_recurse;
3183 #ifndef LRECORD_STRING
3184 case Lisp_Type_String:
3186 struct Lisp_String *ptr = XSTRING (obj);
3190 if (!XMARKBIT (ptr->plist))
3192 if (CONSP (ptr->plist) &&
3193 EXTENT_INFOP (XCAR (ptr->plist)))
3194 flush_cached_extent_info (XCAR (ptr->plist));
3201 #endif /* ! LRECORD_STRING */
3203 #ifndef LRECORD_VECTOR
3204 case Lisp_Type_Vector:
3206 struct Lisp_Vector *ptr = XVECTOR (obj);
3212 len = vector_length (ptr);
3215 break; /* Already marked */
3216 ptr->size = -1 - len; /* Else mark it */
3217 for (i = 0; i < len - 1; i++) /* and then mark its elements */
3218 mark_object (ptr->contents[i]);
3221 obj = ptr->contents[len - 1];
3226 #endif /* !LRECORD_VECTOR */
3228 #ifndef LRECORD_SYMBOL
3229 case Lisp_Type_Symbol:
3231 struct Lisp_Symbol *sym = XSYMBOL (obj);
3236 while (!XMARKBIT (sym->plist))
3239 mark_object (sym->value);
3240 mark_object (sym->function);
3243 * symbol->name is a struct Lisp_String *, not a
3244 * Lisp_Object. Fix it up and pass to mark_object.
3246 Lisp_Object symname;
3247 XSETSTRING (symname, sym->name);
3248 mark_object (symname);
3250 if (!symbol_next (sym))
3255 mark_object (sym->plist);
3256 /* Mark the rest of the symbols in the hash-chain */
3257 sym = symbol_next (sym);
3261 #endif /* !LRECORD_SYMBOL */
3263 /* Check for invalid Lisp_Object types */
3264 #if defined (ERROR_CHECK_GC) && ! defined (USE_MINIMAL_TAGBITS)
3266 case Lisp_Type_Char:
3271 #endif /* ERROR_CHECK_GC && ! USE_MINIMAL_TAGBITS */
3275 /* mark all of the conses in a list and mark the final cdr; but
3276 DO NOT mark the cars.
3278 Use only for internal lists! There should never be other pointers
3279 to the cons cells, because if so, the cars will remain unmarked
3280 even when they maybe should be marked. */
3282 mark_conses_in_list (Lisp_Object obj)
3286 for (rest = obj; CONSP (rest); rest = XCDR (rest))
3288 if (CONS_MARKED_P (XCONS (rest)))
3290 MARK_CONS (XCONS (rest));
3298 /* Simpler than mark-object, because pure structure can't
3299 have any circularities */
3302 pure_string_sizeof (Lisp_Object obj)
3304 struct Lisp_String *ptr = XSTRING (obj);
3306 if (string_data (ptr) != (Bufbyte *) ptr + sizeof (*ptr))
3308 /* string-data not allocated contiguously.
3309 Probably (better be!!) a pointer constant "C" data. */
3310 return sizeof (*ptr);
3314 size_t size = sizeof (*ptr) + string_length (ptr) + 1;
3315 size = ALIGN_SIZE (size, sizeof (Lisp_Object));
3321 pure_sizeof (Lisp_Object obj)
3323 if (!POINTER_TYPE_P (XTYPE (obj))
3324 || !PURIFIED (XPNTR (obj)))
3326 /* symbol sizes are accounted for separately */
3327 else if (SYMBOLP (obj))
3329 else if (STRINGP (obj))
3330 return pure_string_sizeof (obj);
3331 else if (LRECORDP (obj))
3333 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3334 CONST struct lrecord_implementation *implementation
3335 = LHEADER_IMPLEMENTATION (lheader);
3337 return implementation->size_in_bytes_method
3338 ? implementation->size_in_bytes_method (lheader)
3339 : implementation->static_size;
3341 #ifndef LRECORD_VECTOR
3342 else if (VECTORP (obj))
3343 return STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, XVECTOR_LENGTH (obj));
3344 #endif /* !LRECORD_VECTOR */
3346 #ifndef LRECORD_CONS
3347 else if (CONSP (obj))
3348 return sizeof (struct Lisp_Cons);
3349 #endif /* !LRECORD_CONS */
3351 /* Others can't be purified */
3353 return 0; /* unreached */
3355 #endif /* PURESTAT */
3360 /* Find all structures not marked, and free them. */
3362 #ifndef LRECORD_VECTOR
3363 static int gc_count_num_vector_used, gc_count_vector_total_size;
3364 static int gc_count_vector_storage;
3366 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
3367 static int gc_count_bit_vector_storage;
3368 static int gc_count_num_short_string_in_use;
3369 static int gc_count_string_total_size;
3370 static int gc_count_short_string_total_size;
3372 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3376 lrecord_type_index (CONST struct lrecord_implementation *implementation)
3378 int type_index = *(implementation->lrecord_type_index);
3379 /* Have to do this circuitous validation test because of problems
3380 dumping out initialized variables (ie can't set xxx_type_index to -1
3381 because that would make xxx_type_index read-only in a dumped emacs. */
3382 if (type_index < 0 || type_index > max_lrecord_type
3383 || lrecord_implementations_table[type_index] != implementation)
3385 assert (last_lrecord_type_index_assigned < max_lrecord_type);
3386 type_index = ++last_lrecord_type_index_assigned;
3387 lrecord_implementations_table[type_index] = implementation;
3388 *(implementation->lrecord_type_index) = type_index;
3393 /* stats on lcrecords in use - kinda kludgy */
3397 int instances_in_use;
3399 int instances_freed;
3401 int instances_on_free_list;
3402 } lcrecord_stats [countof (lrecord_implementations_table)];
3405 tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p)
3407 CONST struct lrecord_implementation *implementation =
3408 LHEADER_IMPLEMENTATION (h);
3409 int type_index = lrecord_type_index (implementation);
3411 if (((struct lcrecord_header *) h)->free)
3414 lcrecord_stats[type_index].instances_on_free_list++;
3418 size_t sz = (implementation->size_in_bytes_method
3419 ? implementation->size_in_bytes_method (h)
3420 : implementation->static_size);
3424 lcrecord_stats[type_index].instances_freed++;
3425 lcrecord_stats[type_index].bytes_freed += sz;
3429 lcrecord_stats[type_index].instances_in_use++;
3430 lcrecord_stats[type_index].bytes_in_use += sz;
3436 /* Free all unmarked records */
3438 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
3440 struct lcrecord_header *header;
3442 /* int total_size = 0; */
3444 xzero (lcrecord_stats); /* Reset all statistics to 0. */
3446 /* First go through and call all the finalize methods.
3447 Then go through and free the objects. There used to
3448 be only one loop here, with the call to the finalizer
3449 occurring directly before the xfree() below. That
3450 is marginally faster but much less safe -- if the
3451 finalize method for an object needs to reference any
3452 other objects contained within it (and many do),
3453 we could easily be screwed by having already freed that
3456 for (header = *prev; header; header = header->next)
3458 struct lrecord_header *h = &(header->lheader);
3459 if (!MARKED_RECORD_HEADER_P (h) && ! (header->free))
3461 if (LHEADER_IMPLEMENTATION (h)->finalizer)
3462 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
3466 for (header = *prev; header; )
3468 struct lrecord_header *h = &(header->lheader);
3469 if (MARKED_RECORD_HEADER_P (h))
3471 UNMARK_RECORD_HEADER (h);
3473 /* total_size += n->implementation->size_in_bytes (h);*/
3474 prev = &(header->next);
3476 tick_lcrecord_stats (h, 0);
3480 struct lcrecord_header *next = header->next;
3482 tick_lcrecord_stats (h, 1);
3483 /* used to call finalizer right here. */
3489 /* *total = total_size; */
3492 #ifndef LRECORD_VECTOR
3495 sweep_vectors_1 (Lisp_Object *prev,
3496 int *used, int *total, int *storage)
3501 int total_storage = 0;
3503 for (vector = *prev; VECTORP (vector); )
3505 Lisp_Vector *v = XVECTOR (vector);
3507 if (len < 0) /* marked */
3514 STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, len + 1);
3516 prev = &(vector_next (v));
3521 Lisp_Object next = vector_next (v);
3528 *total = total_size;
3529 *storage = total_storage;
3532 #endif /* ! LRECORD_VECTOR */
3535 sweep_bit_vectors_1 (Lisp_Object *prev,
3536 int *used, int *total, int *storage)
3538 Lisp_Object bit_vector;
3541 int total_storage = 0;
3543 /* BIT_VECTORP fails because the objects are marked, which changes
3544 their implementation */
3545 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
3547 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
3549 if (MARKED_RECORD_P (bit_vector))
3551 UNMARK_RECORD_HEADER (&(v->lheader));
3555 STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
3556 BIT_VECTOR_LONG_STORAGE (len));
3558 prev = &(bit_vector_next (v));
3563 Lisp_Object next = bit_vector_next (v);
3570 *total = total_size;
3571 *storage = total_storage;
3574 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3575 to make macros prettier. */
3577 #ifdef ERROR_CHECK_GC
3579 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3581 struct typename##_block *SFTB_current; \
3582 struct typename##_block **SFTB_prev; \
3584 int num_free = 0, num_used = 0; \
3586 for (SFTB_prev = ¤t_##typename##_block, \
3587 SFTB_current = current_##typename##_block, \
3588 SFTB_limit = current_##typename##_block_index; \
3594 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
3596 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
3598 if (FREE_STRUCT_P (SFTB_victim)) \
3602 else if (!MARKED_##typename##_P (SFTB_victim)) \
3605 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
3610 UNMARK_##typename (SFTB_victim); \
3613 SFTB_prev = &(SFTB_current->prev); \
3614 SFTB_current = SFTB_current->prev; \
3615 SFTB_limit = countof (current_##typename##_block->block); \
3618 gc_count_num_##typename##_in_use = num_used; \
3619 gc_count_num_##typename##_freelist = num_free; \
3622 #else /* !ERROR_CHECK_GC */
3624 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3626 struct typename##_block *SFTB_current; \
3627 struct typename##_block **SFTB_prev; \
3629 int num_free = 0, num_used = 0; \
3631 typename##_free_list = 0; \
3633 for (SFTB_prev = ¤t_##typename##_block, \
3634 SFTB_current = current_##typename##_block, \
3635 SFTB_limit = current_##typename##_block_index; \
3640 int SFTB_empty = 1; \
3641 obj_type *SFTB_old_free_list = typename##_free_list; \
3643 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
3645 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
3647 if (FREE_STRUCT_P (SFTB_victim)) \
3650 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
3652 else if (!MARKED_##typename##_P (SFTB_victim)) \
3655 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
3661 UNMARK_##typename (SFTB_victim); \
3666 SFTB_prev = &(SFTB_current->prev); \
3667 SFTB_current = SFTB_current->prev; \
3669 else if (SFTB_current == current_##typename##_block \
3670 && !SFTB_current->prev) \
3672 /* No real point in freeing sole allocation block */ \
3677 struct typename##_block *SFTB_victim_block = SFTB_current; \
3678 if (SFTB_victim_block == current_##typename##_block) \
3679 current_##typename##_block_index \
3680 = countof (current_##typename##_block->block); \
3681 SFTB_current = SFTB_current->prev; \
3683 *SFTB_prev = SFTB_current; \
3684 xfree (SFTB_victim_block); \
3685 /* Restore free list to what it was before victim was swept */ \
3686 typename##_free_list = SFTB_old_free_list; \
3687 num_free -= SFTB_limit; \
3690 SFTB_limit = countof (current_##typename##_block->block); \
3693 gc_count_num_##typename##_in_use = num_used; \
3694 gc_count_num_##typename##_freelist = num_free; \
3697 #endif /* !ERROR_CHECK_GC */
3705 #ifndef LRECORD_CONS
3706 # define MARKED_cons_P(ptr) XMARKBIT ((ptr)->car)
3707 # define UNMARK_cons(ptr) do { XUNMARK ((ptr)->car); } while (0)
3708 #else /* LRECORD_CONS */
3709 # define MARKED_cons_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3710 # define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3711 #endif /* LRECORD_CONS */
3712 #define ADDITIONAL_FREE_cons(ptr)
3714 SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons);
3717 /* Explicitly free a cons cell. */
3719 free_cons (struct Lisp_Cons *ptr)
3721 #ifdef ERROR_CHECK_GC
3722 /* If the CAR is not an int, then it will be a pointer, which will
3723 always be four-byte aligned. If this cons cell has already been
3724 placed on the free list, however, its car will probably contain
3725 a chain pointer to the next cons on the list, which has cleverly
3726 had all its 0's and 1's inverted. This allows for a quick
3727 check to make sure we're not freeing something already freed. */
3728 if (POINTER_TYPE_P (XTYPE (ptr->car)))
3729 ASSERT_VALID_POINTER (XPNTR (ptr->car));
3730 #endif /* ERROR_CHECK_GC */
3732 #ifndef ALLOC_NO_POOLS
3733 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, struct Lisp_Cons, ptr);
3734 #endif /* ALLOC_NO_POOLS */
3737 /* explicitly free a list. You **must make sure** that you have
3738 created all the cons cells that make up this list and that there
3739 are no pointers to any of these cons cells anywhere else. If there
3740 are, you will lose. */
3743 free_list (Lisp_Object list)
3745 Lisp_Object rest, next;
3747 for (rest = list; !NILP (rest); rest = next)
3750 free_cons (XCONS (rest));
3754 /* explicitly free an alist. You **must make sure** that you have
3755 created all the cons cells that make up this alist and that there
3756 are no pointers to any of these cons cells anywhere else. If there
3757 are, you will lose. */
3760 free_alist (Lisp_Object alist)
3762 Lisp_Object rest, next;
3764 for (rest = alist; !NILP (rest); rest = next)
3767 free_cons (XCONS (XCAR (rest)));
3768 free_cons (XCONS (rest));
3773 sweep_compiled_functions (void)
3775 #define MARKED_compiled_function_P(ptr) \
3776 MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3777 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3778 #define ADDITIONAL_FREE_compiled_function(ptr)
3780 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
3784 #ifdef LISP_FLOAT_TYPE
3788 #define MARKED_float_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3789 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3790 #define ADDITIONAL_FREE_float(ptr)
3792 SWEEP_FIXED_TYPE_BLOCK (float, struct Lisp_Float);
3794 #endif /* LISP_FLOAT_TYPE */
3797 sweep_symbols (void)
3799 #ifndef LRECORD_SYMBOL
3800 # define MARKED_symbol_P(ptr) XMARKBIT ((ptr)->plist)
3801 # define UNMARK_symbol(ptr) do { XUNMARK ((ptr)->plist); } while (0)
3803 # define MARKED_symbol_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3804 # define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3805 #endif /* !LRECORD_SYMBOL */
3806 #define ADDITIONAL_FREE_symbol(ptr)
3808 SWEEP_FIXED_TYPE_BLOCK (symbol, struct Lisp_Symbol);
3812 sweep_extents (void)
3814 #define MARKED_extent_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3815 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3816 #define ADDITIONAL_FREE_extent(ptr)
3818 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
3824 #define MARKED_event_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3825 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3826 #define ADDITIONAL_FREE_event(ptr)
3828 SWEEP_FIXED_TYPE_BLOCK (event, struct Lisp_Event);
3832 sweep_markers (void)
3834 #define MARKED_marker_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3835 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3836 #define ADDITIONAL_FREE_marker(ptr) \
3837 do { Lisp_Object tem; \
3838 XSETMARKER (tem, ptr); \
3839 unchain_marker (tem); \
3842 SWEEP_FIXED_TYPE_BLOCK (marker, struct Lisp_Marker);
3845 /* Explicitly free a marker. */
3847 free_marker (struct Lisp_Marker *ptr)
3849 #ifdef ERROR_CHECK_GC
3850 /* Perhaps this will catch freeing an already-freed marker. */
3852 XSETMARKER (temmy, ptr);
3853 assert (GC_MARKERP (temmy));
3854 #endif /* ERROR_CHECK_GC */
3856 #ifndef ALLOC_NO_POOLS
3857 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr);
3858 #endif /* ALLOC_NO_POOLS */
3862 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
3865 verify_string_chars_integrity (void)
3867 struct string_chars_block *sb;
3869 /* Scan each existing string block sequentially, string by string. */
3870 for (sb = first_string_chars_block; sb; sb = sb->next)
3873 /* POS is the index of the next string in the block. */
3874 while (pos < sb->pos)
3876 struct string_chars *s_chars =
3877 (struct string_chars *) &(sb->string_chars[pos]);
3878 struct Lisp_String *string;
3882 /* If the string_chars struct is marked as free (i.e. the STRING
3883 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3884 storage. (See below.) */
3886 if (FREE_STRUCT_P (s_chars))
3888 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3893 string = s_chars->string;
3894 /* Must be 32-bit aligned. */
3895 assert ((((int) string) & 3) == 0);
3897 size = string_length (string);
3898 fullsize = STRING_FULLSIZE (size);
3900 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3901 assert (string_data (string) == s_chars->chars);
3904 assert (pos == sb->pos);
3908 #endif /* MULE && ERROR_CHECK_GC */
3910 /* Compactify string chars, relocating the reference to each --
3911 free any empty string_chars_block we see. */
3913 compact_string_chars (void)
3915 struct string_chars_block *to_sb = first_string_chars_block;
3917 struct string_chars_block *from_sb;
3919 /* Scan each existing string block sequentially, string by string. */
3920 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3923 /* FROM_POS is the index of the next string in the block. */
3924 while (from_pos < from_sb->pos)
3926 struct string_chars *from_s_chars =
3927 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3928 struct string_chars *to_s_chars;
3929 struct Lisp_String *string;
3933 /* If the string_chars struct is marked as free (i.e. the STRING
3934 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3935 storage. This happens under Mule when a string's size changes
3936 in such a way that its fullsize changes. (Strings can change
3937 size because a different-length character can be substituted
3938 for another character.) In this case, after the bogus string
3939 pointer is the "fullsize" of this entry, i.e. how many bytes
3942 if (FREE_STRUCT_P (from_s_chars))
3944 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3945 from_pos += fullsize;
3949 string = from_s_chars->string;
3950 assert (!(FREE_STRUCT_P (string)));
3952 size = string_length (string);
3953 fullsize = STRING_FULLSIZE (size);
3955 if (BIG_STRING_FULLSIZE_P (fullsize))
3958 /* Just skip it if it isn't marked. */
3959 #ifdef LRECORD_STRING
3960 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3962 if (!XMARKBIT (string->plist))
3965 from_pos += fullsize;
3969 /* If it won't fit in what's left of TO_SB, close TO_SB out
3970 and go on to the next string_chars_block. We know that TO_SB
3971 cannot advance past FROM_SB here since FROM_SB is large enough
3972 to currently contain this string. */
3973 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3975 to_sb->pos = to_pos;
3976 to_sb = to_sb->next;
3980 /* Compute new address of this string
3981 and update TO_POS for the space being used. */
3982 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3984 /* Copy the string_chars to the new place. */
3985 if (from_s_chars != to_s_chars)
3986 memmove (to_s_chars, from_s_chars, fullsize);
3988 /* Relocate FROM_S_CHARS's reference */
3989 set_string_data (string, &(to_s_chars->chars[0]));
3991 from_pos += fullsize;
3996 /* Set current to the last string chars block still used and
3997 free any that follow. */
3999 struct string_chars_block *victim;
4001 for (victim = to_sb->next; victim; )
4003 struct string_chars_block *next = victim->next;
4008 current_string_chars_block = to_sb;
4009 current_string_chars_block->pos = to_pos;
4010 current_string_chars_block->next = 0;
4014 #if 1 /* Hack to debug missing purecopy's */
4015 static int debug_string_purity;
4018 debug_string_purity_print (struct Lisp_String *p)
4021 Charcount s = string_char_length (p);
4022 putc ('\"', stderr);
4023 for (i = 0; i < s; i++)
4025 Emchar ch = string_char (p, i);
4026 if (ch < 32 || ch >= 126)
4027 stderr_out ("\\%03o", ch);
4028 else if (ch == '\\' || ch == '\"')
4029 stderr_out ("\\%c", ch);
4031 stderr_out ("%c", ch);
4033 stderr_out ("\"\n");
4039 sweep_strings (void)
4041 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
4042 int debug = debug_string_purity;
4044 #ifdef LRECORD_STRING
4046 # define MARKED_string_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
4047 # define UNMARK_string(ptr) \
4048 do { struct Lisp_String *p = (ptr); \
4049 int size = string_length (p); \
4050 UNMARK_RECORD_HEADER (&(p->lheader)); \
4051 num_bytes += size; \
4052 if (!BIG_STRING_SIZE_P (size)) \
4053 { num_small_bytes += size; \
4056 if (debug) debug_string_purity_print (p); \
4058 # define ADDITIONAL_FREE_string(p) \
4059 do { int size = string_length (p); \
4060 if (BIG_STRING_SIZE_P (size)) \
4061 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
4066 # define MARKED_string_P(ptr) XMARKBIT ((ptr)->plist)
4067 # define UNMARK_string(ptr) \
4068 do { struct Lisp_String *p = (ptr); \
4069 int size = string_length (p); \
4070 XUNMARK (p->plist); \
4071 num_bytes += size; \
4072 if (!BIG_STRING_SIZE_P (size)) \
4073 { num_small_bytes += size; \
4076 if (debug) debug_string_purity_print (p); \
4078 # define ADDITIONAL_FREE_string(p) \
4079 do { int size = string_length (p); \
4080 if (BIG_STRING_SIZE_P (size)) \
4081 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
4084 #endif /* ! LRECORD_STRING */
4086 SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String);
4088 gc_count_num_short_string_in_use = num_small_used;
4089 gc_count_string_total_size = num_bytes;
4090 gc_count_short_string_total_size = num_small_bytes;
4094 /* I hate duplicating all this crap! */
4096 marked_p (Lisp_Object obj)
4098 #ifdef ERROR_CHECK_GC
4099 assert (! (GC_EQ (obj, Qnull_pointer)));
4101 /* Checks we used to perform. */
4102 /* if (EQ (obj, Qnull_pointer)) return 1; */
4103 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
4104 /* if (PURIFIED (XPNTR (obj))) return 1; */
4106 switch (XGCTYPE (obj))
4108 #ifndef LRECORD_CONS
4109 case Lisp_Type_Cons:
4111 struct Lisp_Cons *ptr = XCONS (obj);
4112 return PURIFIED (ptr) || XMARKBIT (ptr->car);
4115 case Lisp_Type_Record:
4117 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
4118 #if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION)
4119 assert (lheader->type <= last_lrecord_type_index_assigned);
4121 return PURIFIED (lheader) || MARKED_RECORD_HEADER_P (lheader);
4123 #ifndef LRECORD_STRING
4124 case Lisp_Type_String:
4126 struct Lisp_String *ptr = XSTRING (obj);
4127 return PURIFIED (ptr) || XMARKBIT (ptr->plist);
4129 #endif /* ! LRECORD_STRING */
4130 #ifndef LRECORD_VECTOR
4131 case Lisp_Type_Vector:
4133 struct Lisp_Vector *ptr = XVECTOR (obj);
4134 return PURIFIED (ptr) || vector_length (ptr) < 0;
4136 #endif /* !LRECORD_VECTOR */
4137 #ifndef LRECORD_SYMBOL
4138 case Lisp_Type_Symbol:
4140 struct Lisp_Symbol *ptr = XSYMBOL (obj);
4141 return PURIFIED (ptr) || XMARKBIT (ptr->plist);
4145 /* Ints and Chars don't need GC */
4146 #if defined (USE_MINIMAL_TAGBITS) || ! defined (ERROR_CHECK_GC)
4153 case Lisp_Type_Char:
4162 /* Free all unmarked records. Do this at the very beginning,
4163 before anything else, so that the finalize methods can safely
4164 examine items in the objects. sweep_lcrecords_1() makes
4165 sure to call all the finalize methods *before* freeing anything,
4166 to complete the safety. */
4169 sweep_lcrecords_1 (&all_lcrecords, &ignored);
4172 compact_string_chars ();
4174 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
4175 macros) must be *extremely* careful to make sure they're not
4176 referencing freed objects. The only two existing finalize
4177 methods (for strings and markers) pass muster -- the string
4178 finalizer doesn't look at anything but its own specially-
4179 created block, and the marker finalizer only looks at live
4180 buffers (which will never be freed) and at the markers before
4181 and after it in the chain (which, by induction, will never be
4182 freed because if so, they would have already removed themselves
4185 /* Put all unmarked strings on free list, free'ing the string chars
4186 of large unmarked strings */
4189 /* Put all unmarked conses on free list */
4192 #ifndef LRECORD_VECTOR
4193 /* Free all unmarked vectors */
4194 sweep_vectors_1 (&all_vectors,
4195 &gc_count_num_vector_used, &gc_count_vector_total_size,
4196 &gc_count_vector_storage);
4199 /* Free all unmarked bit vectors */
4200 sweep_bit_vectors_1 (&all_bit_vectors,
4201 &gc_count_num_bit_vector_used,
4202 &gc_count_bit_vector_total_size,
4203 &gc_count_bit_vector_storage);
4205 /* Free all unmarked compiled-function objects */
4206 sweep_compiled_functions ();
4208 #ifdef LISP_FLOAT_TYPE
4209 /* Put all unmarked floats on free list */
4213 /* Put all unmarked symbols on free list */
4216 /* Put all unmarked extents on free list */
4219 /* Put all unmarked markers on free list.
4220 Dechain each one first from the buffer into which it points. */
4227 /* Clearing for disksave. */
4230 disksave_object_finalization (void)
4232 /* It's important that certain information from the environment not get
4233 dumped with the executable (pathnames, environment variables, etc.).
4234 To make it easier to tell when this has happened with strings(1) we
4235 clear some known-to-be-garbage blocks of memory, so that leftover
4236 results of old evaluation don't look like potential problems.
4237 But first we set some notable variables to nil and do one more GC,
4238 to turn those strings into garbage.
4241 /* Yeah, this list is pretty ad-hoc... */
4242 Vprocess_environment = Qnil;
4243 Vexec_directory = Qnil;
4244 Vdata_directory = Qnil;
4245 Vsite_directory = Qnil;
4246 Vdoc_directory = Qnil;
4247 Vconfigure_info_directory = Qnil;
4250 /* Vdump_load_path = Qnil; */
4251 uncache_home_directory();
4253 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
4254 defined(LOADHIST_BUILTIN))
4255 Vload_history = Qnil;
4257 Vshell_file_name = Qnil;
4259 garbage_collect_1 ();
4261 /* Run the disksave finalization methods of all live objects. */
4262 disksave_object_finalization_1 ();
4264 #if 0 /* I don't see any point in this. The purespace starts out all 0's */
4265 /* Zero out the unused portion of purespace */
4267 memset ( (char *) (PUREBEG + pure_bytes_used), 0,
4268 (((char *) (PUREBEG + get_PURESIZE())) -
4269 ((char *) (PUREBEG + pure_bytes_used))));
4272 /* Zero out the uninitialized (really, unused) part of the containers
4273 for the live strings. */
4275 struct string_chars_block *scb;
4276 for (scb = first_string_chars_block; scb; scb = scb->next)
4278 int count = sizeof (scb->string_chars) - scb->pos;
4280 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
4282 /* from the block's fill ptr to the end */
4283 memset ((scb->string_chars + scb->pos), 0, count);
4288 /* There, that ought to be enough... */
4294 restore_gc_inhibit (Lisp_Object val)
4296 gc_currently_forbidden = XINT (val);
4300 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
4301 static int gc_hooks_inhibited;
4305 garbage_collect_1 (void)
4307 #if MAX_SAVE_STACK > 0
4308 char stack_top_variable;
4309 extern char *stack_bottom;
4315 Lisp_Object pre_gc_cursor;
4316 struct gcpro gcpro1;
4319 || gc_currently_forbidden
4321 || preparing_for_armageddon)
4324 /* We used to call selected_frame() here.
4326 The following functions cannot be called inside GC
4327 so we move to after the above tests. */
4330 Lisp_Object device = Fselected_device (Qnil);
4331 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
4333 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
4335 signal_simple_error ("No frames exist on device", device);
4339 pre_gc_cursor = Qnil;
4342 GCPRO1 (pre_gc_cursor);
4344 /* Very important to prevent GC during any of the following
4345 stuff that might run Lisp code; otherwise, we'll likely
4346 have infinite GC recursion. */
4347 speccount = specpdl_depth ();
4348 record_unwind_protect (restore_gc_inhibit,
4349 make_int (gc_currently_forbidden));
4350 gc_currently_forbidden = 1;
4352 if (!gc_hooks_inhibited)
4353 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
4355 /* Now show the GC cursor/message. */
4356 if (!noninteractive)
4358 if (FRAME_WIN_P (f))
4360 Lisp_Object frame = make_frame (f);
4361 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
4362 FRAME_SELECTED_WINDOW (f),
4364 pre_gc_cursor = f->pointer;
4365 if (POINTER_IMAGE_INSTANCEP (cursor)
4366 /* don't change if we don't know how to change back. */
4367 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
4370 Fset_frame_pointer (frame, cursor);
4374 /* Don't print messages to the stream device. */
4375 if (!cursor_changed && !FRAME_STREAM_P (f))
4377 char *msg = (STRINGP (Vgc_message)
4378 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
4380 Lisp_Object args[2], whole_msg;
4381 args[0] = build_string (msg ? msg :
4382 GETTEXT ((CONST char *) gc_default_message));
4383 args[1] = build_string ("...");
4384 whole_msg = Fconcat (2, args);
4385 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
4386 Qgarbage_collecting);
4390 /***** Now we actually start the garbage collection. */
4394 gc_generation_number[0]++;
4396 #if MAX_SAVE_STACK > 0
4398 /* Save a copy of the contents of the stack, for debugging. */
4401 /* Static buffer in which we save a copy of the C stack at each GC. */
4402 static char *stack_copy;
4403 static size_t stack_copy_size;
4405 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
4406 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
4407 if (stack_size < MAX_SAVE_STACK)
4409 if (stack_copy_size < stack_size)
4411 stack_copy = (char *) xrealloc (stack_copy, stack_size);
4412 stack_copy_size = stack_size;
4416 stack_diff > 0 ? stack_bottom : &stack_top_variable,
4420 #endif /* MAX_SAVE_STACK > 0 */
4422 /* Do some totally ad-hoc resource clearing. */
4423 /* #### generalize this? */
4424 clear_event_resource ();
4425 cleanup_specifiers ();
4427 /* Mark all the special slots that serve as the roots of accessibility. */
4430 struct catchtag *catch;
4431 struct backtrace *backlist;
4432 struct specbinding *bind;
4434 for (i = 0; i < staticidx; i++)
4436 mark_object (*(staticvec[i]));
4439 for (tail = gcprolist; tail; tail = tail->next)
4441 for (i = 0; i < tail->nvars; i++)
4442 mark_object (tail->var[i]);
4445 for (bind = specpdl; bind != specpdl_ptr; bind++)
4447 mark_object (bind->symbol);
4448 mark_object (bind->old_value);
4451 for (catch = catchlist; catch; catch = catch->next)
4453 mark_object (catch->tag);
4454 mark_object (catch->val);
4457 for (backlist = backtrace_list; backlist; backlist = backlist->next)
4459 int nargs = backlist->nargs;
4461 mark_object (*backlist->function);
4462 if (nargs == UNEVALLED || nargs == MANY)
4463 mark_object (backlist->args[0]);
4465 for (i = 0; i < nargs; i++)
4466 mark_object (backlist->args[i]);
4469 mark_redisplay (mark_object);
4470 mark_profiling_info (mark_object);
4473 /* OK, now do the after-mark stuff. This is for things that
4474 are only marked when something else is marked (e.g. weak hash tables).
4475 There may be complex dependencies between such objects -- e.g.
4476 a weak hash table might be unmarked, but after processing a later
4477 weak hash table, the former one might get marked. So we have to
4478 iterate until nothing more gets marked. */
4480 while (finish_marking_weak_hash_tables (marked_p, mark_object) > 0 ||
4481 finish_marking_weak_lists (marked_p, mark_object) > 0)
4484 /* And prune (this needs to be called after everything else has been
4485 marked and before we do any sweeping). */
4486 /* #### this is somewhat ad-hoc and should probably be an object
4488 prune_weak_hash_tables (marked_p);
4489 prune_weak_lists (marked_p);
4490 prune_specifiers (marked_p);
4491 prune_syntax_tables (marked_p);
4495 consing_since_gc = 0;
4496 #ifndef DEBUG_XEMACS
4497 /* Allow you to set it really fucking low if you really want ... */
4498 if (gc_cons_threshold < 10000)
4499 gc_cons_threshold = 10000;
4504 /******* End of garbage collection ********/
4506 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
4508 /* Now remove the GC cursor/message */
4509 if (!noninteractive)
4512 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
4513 else if (!FRAME_STREAM_P (f))
4515 char *msg = (STRINGP (Vgc_message)
4516 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
4519 /* Show "...done" only if the echo area would otherwise be empty. */
4520 if (NILP (clear_echo_area (selected_frame (),
4521 Qgarbage_collecting, 0)))
4523 Lisp_Object args[2], whole_msg;
4524 args[0] = build_string (msg ? msg :
4525 GETTEXT ((CONST char *)
4526 gc_default_message));
4527 args[1] = build_string ("... done");
4528 whole_msg = Fconcat (2, args);
4529 echo_area_message (selected_frame (), (Bufbyte *) 0,
4531 Qgarbage_collecting);
4536 /* now stop inhibiting GC */
4537 unbind_to (speccount, Qnil);
4539 if (!breathing_space)
4541 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
4548 /* Debugging aids. */
4551 gc_plist_hack (CONST char *name, int value, Lisp_Object tail)
4553 /* C doesn't have local functions (or closures, or GC, or readable syntax,
4554 or portable numeric datatypes, or bit-vectors, or characters, or
4555 arrays, or exceptions, or ...) */
4556 return cons3 (intern (name), make_int (value), tail);
4559 #define HACK_O_MATIC(type, name, pl) do { \
4561 struct type##_block *x = current_##type##_block; \
4562 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
4563 (pl) = gc_plist_hack ((name), s, (pl)); \
4566 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
4567 Reclaim storage for Lisp objects no longer needed.
4568 Return info on amount of space in use:
4569 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4570 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4572 where `PLIST' is a list of alternating keyword/value pairs providing
4573 more detailed information.
4574 Garbage collection happens automatically if you cons more than
4575 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4579 Lisp_Object pl = Qnil;
4581 #ifdef LRECORD_VECTOR
4582 int gc_count_vector_total_size = 0;
4585 if (purify_flag && pure_lossage)
4588 garbage_collect_1 ();
4590 for (i = 0; i < last_lrecord_type_index_assigned; i++)
4592 if (lcrecord_stats[i].bytes_in_use != 0
4593 || lcrecord_stats[i].bytes_freed != 0
4594 || lcrecord_stats[i].instances_on_free_list != 0)
4597 CONST char *name = lrecord_implementations_table[i]->name;
4598 int len = strlen (name);
4599 #ifdef LRECORD_VECTOR
4600 /* save this for the FSFmacs-compatible part of the summary */
4601 if (i == *lrecord_vector[0].lrecord_type_index)
4602 gc_count_vector_total_size =
4603 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
4605 sprintf (buf, "%s-storage", name);
4606 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
4607 /* Okay, simple pluralization check for `symbol-value-varalias' */
4608 if (name[len-1] == 's')
4609 sprintf (buf, "%ses-freed", name);
4611 sprintf (buf, "%ss-freed", name);
4612 if (lcrecord_stats[i].instances_freed != 0)
4613 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
4614 if (name[len-1] == 's')
4615 sprintf (buf, "%ses-on-free-list", name);
4617 sprintf (buf, "%ss-on-free-list", name);
4618 if (lcrecord_stats[i].instances_on_free_list != 0)
4619 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
4621 if (name[len-1] == 's')
4622 sprintf (buf, "%ses-used", name);
4624 sprintf (buf, "%ss-used", name);
4625 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
4629 HACK_O_MATIC (extent, "extent-storage", pl);
4630 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
4631 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
4632 HACK_O_MATIC (event, "event-storage", pl);
4633 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
4634 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
4635 HACK_O_MATIC (marker, "marker-storage", pl);
4636 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
4637 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
4638 #ifdef LISP_FLOAT_TYPE
4639 HACK_O_MATIC (float, "float-storage", pl);
4640 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
4641 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
4642 #endif /* LISP_FLOAT_TYPE */
4643 HACK_O_MATIC (string, "string-header-storage", pl);
4644 pl = gc_plist_hack ("long-strings-total-length",
4645 gc_count_string_total_size
4646 - gc_count_short_string_total_size, pl);
4647 HACK_O_MATIC (string_chars, "short-string-storage", pl);
4648 pl = gc_plist_hack ("short-strings-total-length",
4649 gc_count_short_string_total_size, pl);
4650 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
4651 pl = gc_plist_hack ("long-strings-used",
4652 gc_count_num_string_in_use
4653 - gc_count_num_short_string_in_use, pl);
4654 pl = gc_plist_hack ("short-strings-used",
4655 gc_count_num_short_string_in_use, pl);
4657 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
4658 pl = gc_plist_hack ("compiled-functions-free",
4659 gc_count_num_compiled_function_freelist, pl);
4660 pl = gc_plist_hack ("compiled-functions-used",
4661 gc_count_num_compiled_function_in_use, pl);
4663 #ifndef LRECORD_VECTOR
4664 pl = gc_plist_hack ("vector-storage", gc_count_vector_storage, pl);
4665 pl = gc_plist_hack ("vectors-total-length",
4666 gc_count_vector_total_size, pl);
4667 pl = gc_plist_hack ("vectors-used", gc_count_num_vector_used, pl);
4670 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
4671 pl = gc_plist_hack ("bit-vectors-total-length",
4672 gc_count_bit_vector_total_size, pl);
4673 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
4675 HACK_O_MATIC (symbol, "symbol-storage", pl);
4676 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
4677 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
4679 HACK_O_MATIC (cons, "cons-storage", pl);
4680 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
4681 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
4683 /* The things we do for backwards-compatibility */
4685 list6 (Fcons (make_int (gc_count_num_cons_in_use),
4686 make_int (gc_count_num_cons_freelist)),
4687 Fcons (make_int (gc_count_num_symbol_in_use),
4688 make_int (gc_count_num_symbol_freelist)),
4689 Fcons (make_int (gc_count_num_marker_in_use),
4690 make_int (gc_count_num_marker_freelist)),
4691 make_int (gc_count_string_total_size),
4692 make_int (gc_count_vector_total_size),
4697 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
4698 Return the number of bytes consed since the last garbage collection.
4699 \"Consed\" is a misnomer in that this actually counts allocation
4700 of all different kinds of objects, not just conses.
4702 If this value exceeds `gc-cons-threshold', a garbage collection happens.
4706 return make_int (consing_since_gc);
4709 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
4710 Return the address of the last byte Emacs has allocated, divided by 1024.
4711 This may be helpful in debugging Emacs's memory usage.
4712 The value is divided by 1024 to make sure it will fit in a lisp integer.
4716 return make_int ((EMACS_INT) sbrk (0) / 1024);
4722 object_dead_p (Lisp_Object obj)
4724 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
4725 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
4726 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
4727 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
4728 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
4729 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
4730 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
4733 #ifdef MEMORY_USAGE_STATS
4735 /* Attempt to determine the actual amount of space that is used for
4736 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
4738 It seems that the following holds:
4740 1. When using the old allocator (malloc.c):
4742 -- blocks are always allocated in chunks of powers of two. For
4743 each block, there is an overhead of 8 bytes if rcheck is not
4744 defined, 20 bytes if it is defined. In other words, a
4745 one-byte allocation needs 8 bytes of overhead for a total of
4746 9 bytes, and needs to have 16 bytes of memory chunked out for
4749 2. When using the new allocator (gmalloc.c):
4751 -- blocks are always allocated in chunks of powers of two up
4752 to 4096 bytes. Larger blocks are allocated in chunks of
4753 an integral multiple of 4096 bytes. The minimum block
4754 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
4755 is defined. There is no per-block overhead, but there
4756 is an overhead of 3*sizeof (size_t) for each 4096 bytes
4759 3. When using the system malloc, anything goes, but they are
4760 generally slower and more space-efficient than the GNU
4761 allocators. One possibly reasonable assumption to make
4762 for want of better data is that sizeof (void *), or maybe
4763 2 * sizeof (void *), is required as overhead and that
4764 blocks are allocated in the minimum required size except
4765 that some minimum block size is imposed (e.g. 16 bytes). */
4768 malloced_storage_size (void *ptr, size_t claimed_size,
4769 struct overhead_stats *stats)
4771 size_t orig_claimed_size = claimed_size;
4775 if (claimed_size < 2 * sizeof (void *))
4776 claimed_size = 2 * sizeof (void *);
4777 # ifdef SUNOS_LOCALTIME_BUG
4778 if (claimed_size < 16)
4781 if (claimed_size < 4096)
4785 /* compute the log base two, more or less, then use it to compute
4786 the block size needed. */
4788 /* It's big, it's heavy, it's wood! */
4789 while ((claimed_size /= 2) != 0)
4792 /* It's better than bad, it's good! */
4798 /* We have to come up with some average about the amount of
4800 if ((size_t) (rand () & 4095) < claimed_size)
4801 claimed_size += 3 * sizeof (void *);
4805 claimed_size += 4095;
4806 claimed_size &= ~4095;
4807 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
4810 #elif defined (SYSTEM_MALLOC)
4812 if (claimed_size < 16)
4814 claimed_size += 2 * sizeof (void *);
4816 #else /* old GNU allocator */
4818 # ifdef rcheck /* #### may not be defined here */
4826 /* compute the log base two, more or less, then use it to compute
4827 the block size needed. */
4829 /* It's big, it's heavy, it's wood! */
4830 while ((claimed_size /= 2) != 0)
4833 /* It's better than bad, it's good! */
4841 #endif /* old GNU allocator */
4845 stats->was_requested += orig_claimed_size;
4846 stats->malloc_overhead += claimed_size - orig_claimed_size;
4848 return claimed_size;
4852 fixed_type_block_overhead (size_t size)
4854 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
4855 size_t overhead = 0;
4856 size_t storage_size = malloced_storage_size (0, per_block, 0);
4857 while (size >= per_block)
4860 overhead += sizeof (void *) + per_block - storage_size;
4862 if (rand () % per_block < size)
4863 overhead += sizeof (void *) + per_block - storage_size;
4867 #endif /* MEMORY_USAGE_STATS */
4870 /* Initialization */
4872 init_alloc_once_early (void)
4876 last_lrecord_type_index_assigned = -1;
4877 for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
4879 lrecord_implementations_table[iii] = 0;
4882 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
4884 * If USE_INDEXED_LRECORD_IMPLEMENTATION is defined, all the staticly
4885 * defined subr lrecords were initialized with lheader->type == 0.
4886 * See subr_lheader_initializer in lisp.h. Force type index 0 to be
4887 * assigned to lrecord_subr so that those predefined indexes match
4890 lrecord_type_index (lrecord_subr);
4891 assert (*(lrecord_subr[0].lrecord_type_index) == 0);
4893 * The same is true for symbol_value_forward objects, except the
4896 lrecord_type_index (lrecord_symbol_value_forward);
4897 assert (*(lrecord_symbol_value_forward[0].lrecord_type_index) == 1);
4898 #endif /* USE_INDEXED_LRECORD_IMPLEMENTATION */
4900 symbols_initialized = 0;
4902 gc_generation_number[0] = 0;
4903 /* purify_flag 1 is correct even if CANNOT_DUMP.
4904 * loadup.el will set to nil at end. */
4906 pure_bytes_used = 0;
4908 breathing_space = 0;
4909 #ifndef LRECORD_VECTOR
4910 XSETINT (all_vectors, 0); /* Qzero may not be set yet. */
4912 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
4913 XSETINT (Vgc_message, 0);
4915 ignore_malloc_warnings = 1;
4916 #ifdef DOUG_LEA_MALLOC
4917 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
4918 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
4919 #if 0 /* Moved to emacs.c */
4920 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
4923 init_string_alloc ();
4924 init_string_chars_alloc ();
4926 init_symbol_alloc ();
4927 init_compiled_function_alloc ();
4928 #ifdef LISP_FLOAT_TYPE
4929 init_float_alloc ();
4930 #endif /* LISP_FLOAT_TYPE */
4931 init_marker_alloc ();
4932 init_extent_alloc ();
4933 init_event_alloc ();
4935 ignore_malloc_warnings = 0;
4937 consing_since_gc = 0;
4939 gc_cons_threshold = 500000; /* XEmacs change */
4941 gc_cons_threshold = 15000; /* debugging */
4943 #ifdef VIRT_ADDR_VARIES
4944 malloc_sbrk_unused = 1<<22; /* A large number */
4945 malloc_sbrk_used = 100000; /* as reasonable as any number */
4946 #endif /* VIRT_ADDR_VARIES */
4947 lrecord_uid_counter = 259;
4948 debug_string_purity = 0;
4951 gc_currently_forbidden = 0;
4952 gc_hooks_inhibited = 0;
4954 #ifdef ERROR_CHECK_TYPECHECK
4955 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4958 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
4960 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4962 #endif /* ERROR_CHECK_TYPECHECK */
4972 syms_of_alloc (void)
4974 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
4975 defsymbol (&Qpost_gc_hook, "post-gc-hook");
4976 defsymbol (&Qgarbage_collecting, "garbage-collecting");
4981 DEFSUBR (Fbit_vector);
4982 DEFSUBR (Fmake_byte_code);
4983 DEFSUBR (Fmake_list);
4984 DEFSUBR (Fmake_vector);
4985 DEFSUBR (Fmake_bit_vector);
4986 DEFSUBR (Fmake_string);
4988 DEFSUBR (Fmake_symbol);
4989 DEFSUBR (Fmake_marker);
4990 DEFSUBR (Fpurecopy);
4991 DEFSUBR (Fgarbage_collect);
4992 DEFSUBR (Fmemory_limit);
4993 DEFSUBR (Fconsing_since_gc);
4997 vars_of_alloc (void)
4999 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
5000 *Number of bytes of consing between garbage collections.
5001 \"Consing\" is a misnomer in that this actually counts allocation
5002 of all different kinds of objects, not just conses.
5003 Garbage collection can happen automatically once this many bytes have been
5004 allocated since the last garbage collection. All data types count.
5006 Garbage collection happens automatically when `eval' or `funcall' are
5007 called. (Note that `funcall' is called implicitly as part of evaluation.)
5008 By binding this temporarily to a large number, you can effectively
5009 prevent garbage collection during a part of the program.
5011 See also `consing-since-gc'.
5014 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
5015 Number of bytes of sharable Lisp data allocated so far.
5019 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
5020 Number of bytes of unshared memory allocated in this session.
5023 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
5024 Number of bytes of unshared memory remaining available in this session.
5029 DEFVAR_INT ("debug-allocation", &debug_allocation /*
5030 If non-zero, print out information to stderr about all objects allocated.
5031 See also `debug-allocation-backtrace-length'.
5033 debug_allocation = 0;
5035 DEFVAR_INT ("debug-allocation-backtrace-length",
5036 &debug_allocation_backtrace_length /*
5037 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
5039 debug_allocation_backtrace_length = 2;
5042 DEFVAR_BOOL ("purify-flag", &purify_flag /*
5043 Non-nil means loading Lisp code in order to dump an executable.
5044 This means that certain objects should be allocated in shared (pure) space.
5047 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
5048 Function or functions to be run just before each garbage collection.
5049 Interrupts, garbage collection, and errors are inhibited while this hook
5050 runs, so be extremely careful in what you add here. In particular, avoid
5051 consing, and do not interact with the user.
5053 Vpre_gc_hook = Qnil;
5055 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
5056 Function or functions to be run just after each garbage collection.
5057 Interrupts, garbage collection, and errors are inhibited while this hook
5058 runs, so be extremely careful in what you add here. In particular, avoid
5059 consing, and do not interact with the user.
5061 Vpost_gc_hook = Qnil;
5063 DEFVAR_LISP ("gc-message", &Vgc_message /*
5064 String to print to indicate that a garbage collection is in progress.
5065 This is printed in the echo area. If the selected frame is on a
5066 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
5067 image instance) in the domain of the selected frame, the mouse pointer
5068 will change instead of this message being printed.
5070 Vgc_message = make_pure_string ((CONST Bufbyte *) gc_default_message,
5071 countof (gc_default_message) - 1,
5074 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
5075 Pointer glyph used to indicate that a garbage collection is in progress.
5076 If the selected window is on a window system and this glyph specifies a
5077 value (i.e. a pointer image instance) in the domain of the selected
5078 window, the pointer will be changed as specified during garbage collection.
5079 Otherwise, a message will be printed in the echo area, as controlled
5085 complex_vars_of_alloc (void)
5087 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);