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. We make
639 sure certain symbols are always defined, so gdb doesn't complain
640 about expressions in src/gdbinit. See src/gdbinit or src/dbxrc to
641 see how this is used. */
643 #ifdef USE_MINIMAL_TAGBITS
644 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
645 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
646 unsigned char dbg_USE_MINIMAL_TAGBITS = 1;
647 unsigned char Lisp_Type_Int = 100;
649 EMACS_UINT dbg_valmask = (1UL << VALBITS) - 1;
650 EMACS_UINT dbg_typemask = ((1UL << GCTYPEBITS) - 1) << (VALBITS + GCMARKBITS);
651 unsigned char dbg_USE_MINIMAL_TAGBITS = 0;
654 #ifdef USE_UNION_TYPE
655 unsigned char dbg_USE_UNION_TYPE = 1;
657 unsigned char dbg_USE_UNION_TYPE = 0;
660 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
661 unsigned char dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1;
663 unsigned char dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0;
667 unsigned char Lisp_Type_Cons = 101;
669 unsigned char lrecord_cons;
672 #ifdef LRECORD_STRING
673 unsigned char Lisp_Type_String = 102;
675 unsigned char lrecord_string;
678 #ifdef LRECORD_VECTOR
679 unsigned char Lisp_Type_Vector = 103;
681 unsigned char lrecord_vector;
684 #ifdef LRECORD_SYMBOL
685 unsigned char Lisp_Type_Symbol = 104;
687 unsigned char lrecord_symbol;
691 unsigned char lrecord_char_table_entry;
692 unsigned char lrecord_charset;
694 unsigned char lrecord_coding_system;
698 #ifndef HAVE_TOOLBARS
699 unsigned char lrecord_toolbar_button;
703 unsigned char lrecord_tooltalk_message;
704 unsigned char lrecord_tooltalk_pattern;
707 #ifndef HAVE_DATABASE
708 unsigned char lrecord_database;
711 unsigned char dbg_valbits = VALBITS;
712 unsigned char dbg_gctypebits = GCTYPEBITS;
714 /* Macros turned into functions for ease of debugging.
715 Debuggers don't know about macros! */
716 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
718 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
720 return EQ (obj1, obj2);
724 /************************************************************************/
725 /* Fixed-size type macros */
726 /************************************************************************/
728 /* For fixed-size types that are commonly used, we malloc() large blocks
729 of memory at a time and subdivide them into chunks of the correct
730 size for an object of that type. This is more efficient than
731 malloc()ing each object separately because we save on malloc() time
732 and overhead due to the fewer number of malloc()ed blocks, and
733 also because we don't need any extra pointers within each object
734 to keep them threaded together for GC purposes. For less common
735 (and frequently large-size) types, we use lcrecords, which are
736 malloc()ed individually and chained together through a pointer
737 in the lcrecord header. lcrecords do not need to be fixed-size
738 (i.e. two objects of the same type need not have the same size;
739 however, the size of a particular object cannot vary dynamically).
740 It is also much easier to create a new lcrecord type because no
741 additional code needs to be added to alloc.c. Finally, lcrecords
742 may be more efficient when there are only a small number of them.
744 The types that are stored in these large blocks (or "frob blocks")
745 are cons, float, compiled-function, symbol, marker, extent, event,
748 Note that strings are special in that they are actually stored in
749 two parts: a structure containing information about the string, and
750 the actual data associated with the string. The former structure
751 (a struct Lisp_String) is a fixed-size structure and is managed the
752 same way as all the other such types. This structure contains a
753 pointer to the actual string data, which is stored in structures of
754 type struct string_chars_block. Each string_chars_block consists
755 of a pointer to a struct Lisp_String, followed by the data for that
756 string, followed by another pointer to a struct Lisp_String,
757 followed by the data for that string, etc. At GC time, the data in
758 these blocks is compacted by searching sequentially through all the
759 blocks and compressing out any holes created by unmarked strings.
760 Strings that are more than a certain size (bigger than the size of
761 a string_chars_block, although something like half as big might
762 make more sense) are malloc()ed separately and not stored in
763 string_chars_blocks. Furthermore, no one string stretches across
764 two string_chars_blocks.
766 Vectors are each malloc()ed separately, similar to lcrecords.
768 In the following discussion, we use conses, but it applies equally
769 well to the other fixed-size types.
771 We store cons cells inside of cons_blocks, allocating a new
772 cons_block with malloc() whenever necessary. Cons cells reclaimed
773 by GC are put on a free list to be reallocated before allocating
774 any new cons cells from the latest cons_block. Each cons_block is
775 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
776 the versions in malloc.c and gmalloc.c) really allocates in units
777 of powers of two and uses 4 bytes for its own overhead.
779 What GC actually does is to search through all the cons_blocks,
780 from the most recently allocated to the oldest, and put all
781 cons cells that are not marked (whether or not they're already
782 free) on a cons_free_list. The cons_free_list is a stack, and
783 so the cons cells in the oldest-allocated cons_block end up
784 at the head of the stack and are the first to be reallocated.
785 If any cons_block is entirely free, it is freed with free()
786 and its cons cells removed from the cons_free_list. Because
787 the cons_free_list ends up basically in memory order, we have
788 a high locality of reference (assuming a reasonable turnover
789 of allocating and freeing) and have a reasonable probability
790 of entirely freeing up cons_blocks that have been more recently
791 allocated. This stage is called the "sweep stage" of GC, and
792 is executed after the "mark stage", which involves starting
793 from all places that are known to point to in-use Lisp objects
794 (e.g. the obarray, where are all symbols are stored; the
795 current catches and condition-cases; the backtrace list of
796 currently executing functions; the gcpro list; etc.) and
797 recursively marking all objects that are accessible.
799 At the beginning of the sweep stage, the conses in the cons
800 blocks are in one of three states: in use and marked, in use
801 but not marked, and not in use (already freed). Any conses
802 that are marked have been marked in the mark stage just
803 executed, because as part of the sweep stage we unmark any
804 marked objects. The way we tell whether or not a cons cell
805 is in use is through the FREE_STRUCT_P macro. This basically
806 looks at the first 4 bytes (or however many bytes a pointer
807 fits in) to see if all the bits in those bytes are 1. The
808 resulting value (0xFFFFFFFF) is not a valid pointer and is
809 not a valid Lisp_Object. All current fixed-size types have
810 a pointer or Lisp_Object as their first element with the
811 exception of strings; they have a size value, which can
812 never be less than zero, and so 0xFFFFFFFF is invalid for
813 strings as well. Now assuming that a cons cell is in use,
814 the way we tell whether or not it is marked is to look at
815 the mark bit of its car (each Lisp_Object has one bit
816 reserved as a mark bit, in case it's needed). Note that
817 different types of objects use different fields to indicate
818 whether the object is marked, but the principle is the same.
820 Conses on the free_cons_list are threaded through a pointer
821 stored in the bytes directly after the bytes that are set
822 to 0xFFFFFFFF (we cannot overwrite these because the cons
823 is still in a cons_block and needs to remain marked as
824 not in use for the next time that GC happens). This
825 implies that all fixed-size types must be at least big
826 enough to store two pointers, which is indeed the case
827 for all current fixed-size types.
829 Some types of objects need additional "finalization" done
830 when an object is converted from in use to not in use;
831 this is the purpose of the ADDITIONAL_FREE_type macro.
832 For example, markers need to be removed from the chain
833 of markers that is kept in each buffer. This is because
834 markers in a buffer automatically disappear if the marker
835 is no longer referenced anywhere (the same does not
836 apply to extents, however).
838 WARNING: Things are in an extremely bizarre state when
839 the ADDITIONAL_FREE_type macros are called, so beware!
841 When ERROR_CHECK_GC is defined, we do things differently
842 so as to maximize our chances of catching places where
843 there is insufficient GCPROing. The thing we want to
844 avoid is having an object that we're using but didn't
845 GCPRO get freed by GC and then reallocated while we're
846 in the process of using it -- this will result in something
847 seemingly unrelated getting trashed, and is extremely
848 difficult to track down. If the object gets freed but
849 not reallocated, we can usually catch this because we
850 set all bytes of a freed object to 0xDEADBEEF. (The
851 first four bytes, however, are 0xFFFFFFFF, and the next
852 four are a pointer used to chain freed objects together;
853 we play some tricks with this pointer to make it more
854 bogus, so crashes are more likely to occur right away.)
856 We want freed objects to stay free as long as possible,
857 so instead of doing what we do above, we maintain the
858 free objects in a first-in first-out queue. We also
859 don't recompute the free list each GC, unlike above;
860 this ensures that the queue ordering is preserved.
861 [This means that we are likely to have worse locality
862 of reference, and that we can never free a frob block
863 once it's allocated. (Even if we know that all cells
864 in it are free, there's no easy way to remove all those
865 cells from the free list because the objects on the
866 free list are unlikely to be in memory order.)]
867 Furthermore, we never take objects off the free list
868 unless there's a large number (usually 1000, but
869 varies depending on type) of them already on the list.
870 This way, we ensure that an object that gets freed will
871 remain free for the next 1000 (or whatever) times that
872 an object of that type is allocated.
875 #ifndef MALLOC_OVERHEAD
877 #define MALLOC_OVERHEAD 0
878 #elif defined (rcheck)
879 #define MALLOC_OVERHEAD 20
881 #define MALLOC_OVERHEAD 8
883 #endif /* MALLOC_OVERHEAD */
885 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
886 /* If we released our reserve (due to running out of memory),
887 and we have a fair amount free once again,
888 try to set aside another reserve in case we run out once more.
890 This is called when a relocatable block is freed in ralloc.c. */
891 void refill_memory_reserve (void);
893 refill_memory_reserve ()
895 if (breathing_space == 0)
896 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
900 #ifdef ALLOC_NO_POOLS
901 # define TYPE_ALLOC_SIZE(type, structtype) 1
903 # define TYPE_ALLOC_SIZE(type, structtype) \
904 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
905 / sizeof (structtype))
906 #endif /* ALLOC_NO_POOLS */
908 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
910 struct type##_block \
912 struct type##_block *prev; \
913 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
916 static struct type##_block *current_##type##_block; \
917 static int current_##type##_block_index; \
919 static structtype *type##_free_list; \
920 static structtype *type##_free_list_tail; \
923 init_##type##_alloc (void) \
925 current_##type##_block = 0; \
926 current_##type##_block_index = \
927 countof (current_##type##_block->block); \
928 type##_free_list = 0; \
929 type##_free_list_tail = 0; \
932 static int gc_count_num_##type##_in_use; \
933 static int gc_count_num_##type##_freelist
935 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
936 if (current_##type##_block_index \
937 == countof (current_##type##_block->block)) \
939 struct type##_block *AFTFB_new = (struct type##_block *) \
940 allocate_lisp_storage (sizeof (struct type##_block)); \
941 AFTFB_new->prev = current_##type##_block; \
942 current_##type##_block = AFTFB_new; \
943 current_##type##_block_index = 0; \
946 &(current_##type##_block->block[current_##type##_block_index++]); \
949 /* Allocate an instance of a type that is stored in blocks.
950 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
953 #ifdef ERROR_CHECK_GC
955 /* Note: if you get crashes in this function, suspect incorrect calls
956 to free_cons() and friends. This happened once because the cons
957 cell was not GC-protected and was getting collected before
958 free_cons() was called. */
960 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
963 if (gc_count_num_##type##_freelist > \
964 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
966 result = type##_free_list; \
967 /* Before actually using the chain pointer, we complement all its \
968 bits; see FREE_FIXED_TYPE(). */ \
970 (structtype *) ~(unsigned long) \
971 (* (structtype **) ((char *) result + sizeof (void *))); \
972 gc_count_num_##type##_freelist--; \
975 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
976 MARK_STRUCT_AS_NOT_FREE (result); \
979 #else /* !ERROR_CHECK_GC */
981 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
984 if (type##_free_list) \
986 result = type##_free_list; \
988 * (structtype **) ((char *) result + sizeof (void *)); \
991 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
992 MARK_STRUCT_AS_NOT_FREE (result); \
995 #endif /* !ERROR_CHECK_GC */
997 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
1000 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
1001 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
1004 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
1007 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
1008 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
1011 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
1012 to a Lisp object and invalid as an actual Lisp_Object value. We have
1013 to make sure that this value cannot be an integer in Lisp_Object form.
1014 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
1015 On a 32-bit system, the type bits will be non-zero, making the value
1016 be a pointer, and the pointer will be misaligned.
1018 Even if Emacs is run on some weirdo system that allows and allocates
1019 byte-aligned pointers, this pointer is at the very top of the address
1020 space and so it's almost inconceivable that it could ever be valid. */
1023 # define INVALID_POINTER_VALUE 0xFFFFFFFF
1025 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
1027 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
1029 You have some weird system and need to supply a reasonable value here.
1032 #define FREE_STRUCT_P(ptr) \
1033 (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
1034 #define MARK_STRUCT_AS_FREE(ptr) \
1035 (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
1036 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
1037 (* (void **) ptr = 0)
1039 #ifdef ERROR_CHECK_GC
1041 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
1042 do { if (type##_free_list_tail) \
1044 /* When we store the chain pointer, we complement all \
1045 its bits; this should significantly increase its \
1046 bogosity in case someone tries to use the value, and \
1047 should make us dump faster if someone stores something \
1048 over the pointer because when it gets un-complemented in \
1049 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
1050 extremely bogus. */ \
1052 ((char *) type##_free_list_tail + sizeof (void *)) = \
1053 (structtype *) ~(unsigned long) ptr; \
1056 type##_free_list = ptr; \
1057 type##_free_list_tail = ptr; \
1060 #else /* !ERROR_CHECK_GC */
1062 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
1063 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
1065 type##_free_list = (ptr); \
1068 #endif /* !ERROR_CHECK_GC */
1070 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
1072 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
1073 structtype *FFT_ptr = (ptr); \
1074 ADDITIONAL_FREE_##type (FFT_ptr); \
1075 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
1076 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
1077 MARK_STRUCT_AS_FREE (FFT_ptr); \
1080 /* Like FREE_FIXED_TYPE() but used when we are explicitly
1081 freeing a structure through free_cons(), free_marker(), etc.
1082 rather than through the normal process of sweeping.
1083 We attempt to undo the changes made to the allocation counters
1084 as a result of this structure being allocated. This is not
1085 completely necessary but helps keep things saner: e.g. this way,
1086 repeatedly allocating and freeing a cons will not result in
1087 the consing-since-gc counter advancing, which would cause a GC
1088 and somewhat defeat the purpose of explicitly freeing. */
1090 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
1091 do { FREE_FIXED_TYPE (type, structtype, ptr); \
1092 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
1093 gc_count_num_##type##_freelist++; \
1098 /************************************************************************/
1099 /* Cons allocation */
1100 /************************************************************************/
1102 DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons);
1103 /* conses are used and freed so often that we set this really high */
1104 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
1105 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
1109 mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object))
1111 if (GC_NILP (XCDR (obj)))
1114 markobj (XCAR (obj));
1119 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
1121 while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1))
1125 if (! CONSP (ob1) || ! CONSP (ob2))
1126 return internal_equal (ob1, ob2, depth + 1);
1131 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
1132 mark_cons, print_cons, 0,
1135 * No `hash' method needed.
1136 * internal_hash knows how to
1141 #endif /* LRECORD_CONS */
1143 DEFUN ("cons", Fcons, 2, 2, 0, /*
1144 Create a new cons, give it CAR and CDR as components, and return it.
1148 /* This cannot GC. */
1150 struct Lisp_Cons *c;
1152 ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1154 set_lheader_implementation (&(c->lheader), lrecord_cons);
1162 /* This is identical to Fcons() but it used for conses that we're
1163 going to free later, and is useful when trying to track down
1166 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
1169 struct Lisp_Cons *c;
1171 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1173 set_lheader_implementation (&(c->lheader), lrecord_cons);
1181 DEFUN ("list", Flist, 0, MANY, 0, /*
1182 Return a newly created list with specified arguments as elements.
1183 Any number of arguments, even zero arguments, are allowed.
1185 (int nargs, Lisp_Object *args))
1187 Lisp_Object val = Qnil;
1188 Lisp_Object *argp = args + nargs;
1191 val = Fcons (*--argp, val);
1196 list1 (Lisp_Object obj0)
1198 /* This cannot GC. */
1199 return Fcons (obj0, Qnil);
1203 list2 (Lisp_Object obj0, Lisp_Object obj1)
1205 /* This cannot GC. */
1206 return Fcons (obj0, Fcons (obj1, Qnil));
1210 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1212 /* This cannot GC. */
1213 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1217 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1219 /* This cannot GC. */
1220 return Fcons (obj0, Fcons (obj1, obj2));
1224 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1226 return Fcons (Fcons (key, value), alist);
1230 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1232 /* This cannot GC. */
1233 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1237 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1240 /* This cannot GC. */
1241 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1245 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1246 Lisp_Object obj4, Lisp_Object obj5)
1248 /* This cannot GC. */
1249 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1252 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1253 Return a new list of length LENGTH, with each element being INIT.
1257 CHECK_NATNUM (length);
1260 Lisp_Object val = Qnil;
1261 int size = XINT (length);
1264 val = Fcons (init, val);
1270 /************************************************************************/
1271 /* Float allocation */
1272 /************************************************************************/
1274 #ifdef LISP_FLOAT_TYPE
1276 DECLARE_FIXED_TYPE_ALLOC (float, struct Lisp_Float);
1277 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1280 make_float (double float_value)
1283 struct Lisp_Float *f;
1285 ALLOCATE_FIXED_TYPE (float, struct Lisp_Float, f);
1286 set_lheader_implementation (&(f->lheader), lrecord_float);
1287 float_data (f) = float_value;
1292 #endif /* LISP_FLOAT_TYPE */
1295 /************************************************************************/
1296 /* Vector allocation */
1297 /************************************************************************/
1299 #ifdef LRECORD_VECTOR
1301 mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
1303 Lisp_Vector *ptr = XVECTOR (obj);
1304 int len = vector_length (ptr);
1307 for (i = 0; i < len - 1; i++)
1308 markobj (ptr->contents[i]);
1309 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1313 size_vector (CONST void *lheader)
1315 return STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents,
1316 ((Lisp_Vector *) lheader)->size);
1320 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1322 int len = XVECTOR_LENGTH (obj1);
1323 if (len != XVECTOR_LENGTH (obj2))
1327 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1328 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1330 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1336 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1337 mark_vector, print_vector, 0,
1340 * No `hash' method needed for
1341 * vectors. internal_hash
1342 * knows how to handle vectors.
1345 size_vector, Lisp_Vector);
1347 /* #### should allocate `small' vectors from a frob-block */
1348 static Lisp_Vector *
1349 make_vector_internal (size_t sizei)
1351 /* no vector_next */
1352 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1353 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, lrecord_vector);
1359 #else /* ! LRECORD_VECTOR */
1361 static Lisp_Object all_vectors;
1363 /* #### should allocate `small' vectors from a frob-block */
1364 static Lisp_Vector *
1365 make_vector_internal (size_t sizei)
1367 /* + 1 to account for vector_next */
1368 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei+1);
1369 Lisp_Vector *p = (Lisp_Vector *) allocate_lisp_storage (sizem);
1371 INCREMENT_CONS_COUNTER (sizem, "vector");
1374 vector_next (p) = all_vectors;
1375 XSETVECTOR (all_vectors, p);
1379 #endif /* ! LRECORD_VECTOR */
1382 make_vector (size_t length, Lisp_Object init)
1384 Lisp_Vector *vecp = make_vector_internal (length);
1385 Lisp_Object *p = vector_data (vecp);
1392 XSETVECTOR (vector, vecp);
1397 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1398 Return a new vector of length LENGTH, with each element being INIT.
1399 See also the function `vector'.
1403 CONCHECK_NATNUM (length);
1404 return make_vector (XINT (length), init);
1407 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1408 Return a newly created vector with specified arguments as elements.
1409 Any number of arguments, even zero arguments, are allowed.
1411 (int nargs, Lisp_Object *args))
1413 Lisp_Vector *vecp = make_vector_internal (nargs);
1414 Lisp_Object *p = vector_data (vecp);
1421 XSETVECTOR (vector, vecp);
1427 vector1 (Lisp_Object obj0)
1429 return Fvector (1, &obj0);
1433 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1435 Lisp_Object args[2];
1438 return Fvector (2, args);
1442 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1444 Lisp_Object args[3];
1448 return Fvector (3, args);
1451 #if 0 /* currently unused */
1454 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1457 Lisp_Object args[4];
1462 return Fvector (4, args);
1466 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1467 Lisp_Object obj3, Lisp_Object obj4)
1469 Lisp_Object args[5];
1475 return Fvector (5, args);
1479 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1480 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1482 Lisp_Object args[6];
1489 return Fvector (6, args);
1493 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1494 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1497 Lisp_Object args[7];
1505 return Fvector (7, args);
1509 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1510 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1511 Lisp_Object obj6, Lisp_Object obj7)
1513 Lisp_Object args[8];
1522 return Fvector (8, args);
1526 /************************************************************************/
1527 /* Bit Vector allocation */
1528 /************************************************************************/
1530 static Lisp_Object all_bit_vectors;
1532 /* #### should allocate `small' bit vectors from a frob-block */
1533 static struct Lisp_Bit_Vector *
1534 make_bit_vector_internal (size_t sizei)
1536 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1537 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1538 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1539 set_lheader_implementation (&(p->lheader), lrecord_bit_vector);
1541 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1543 bit_vector_length (p) = sizei;
1544 bit_vector_next (p) = all_bit_vectors;
1545 /* make sure the extra bits in the last long are 0; the calling
1546 functions might not set them. */
1547 p->bits[num_longs - 1] = 0;
1548 XSETBIT_VECTOR (all_bit_vectors, p);
1553 make_bit_vector (size_t length, Lisp_Object init)
1555 struct Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1556 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1561 memset (p->bits, 0, num_longs * sizeof (long));
1564 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1565 memset (p->bits, ~0, num_longs * sizeof (long));
1566 /* But we have to make sure that the unused bits in the
1567 last long are 0, so that equal/hash is easy. */
1569 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1573 Lisp_Object bit_vector;
1574 XSETBIT_VECTOR (bit_vector, p);
1580 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1583 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1585 for (i = 0; i < length; i++)
1586 set_bit_vector_bit (p, i, bytevec[i]);
1589 Lisp_Object bit_vector;
1590 XSETBIT_VECTOR (bit_vector, p);
1595 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1596 Return a new bit vector of length LENGTH. with each bit being INIT.
1597 Each element is set to INIT. See also the function `bit-vector'.
1601 CONCHECK_NATNUM (length);
1603 return make_bit_vector (XINT (length), init);
1606 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1607 Return a newly created bit vector with specified arguments as elements.
1608 Any number of arguments, even zero arguments, are allowed.
1610 (int nargs, Lisp_Object *args))
1613 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1615 for (i = 0; i < nargs; i++)
1617 CHECK_BIT (args[i]);
1618 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1622 Lisp_Object bit_vector;
1623 XSETBIT_VECTOR (bit_vector, p);
1629 /************************************************************************/
1630 /* Compiled-function allocation */
1631 /************************************************************************/
1633 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1634 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1637 make_compiled_function (int make_pure)
1639 Lisp_Compiled_Function *f;
1641 size_t size = sizeof (Lisp_Compiled_Function);
1643 if (make_pure && check_purespace (size))
1645 f = (Lisp_Compiled_Function *) (PUREBEG + pure_bytes_used);
1646 set_lheader_implementation (&(f->lheader), lrecord_compiled_function);
1647 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
1648 f->lheader.pure = 1;
1650 pure_bytes_used += size;
1651 bump_purestat (&purestat_function, size);
1655 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1656 set_lheader_implementation (&(f->lheader), lrecord_compiled_function);
1659 f->specpdl_depth = 0;
1660 f->flags.documentationp = 0;
1661 f->flags.interactivep = 0;
1662 f->flags.domainp = 0; /* I18N3 */
1663 f->instructions = Qzero;
1664 f->constants = Qzero;
1666 f->doc_and_interactive = Qnil;
1667 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1668 f->annotated = Qnil;
1670 XSETCOMPILED_FUNCTION (fun, f);
1674 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1675 Return a new compiled-function object.
1676 Usage: (arglist instructions constants stack-depth
1677 &optional doc-string interactive)
1678 Note that, unlike all other emacs-lisp functions, calling this with five
1679 arguments is NOT the same as calling it with six arguments, the last of
1680 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1681 that this function was defined with `(interactive)'. If the arg is not
1682 specified, then that means the function is not interactive.
1683 This is terrible behavior which is retained for compatibility with old
1684 `.elc' files which expect these semantics.
1686 (int nargs, Lisp_Object *args))
1688 /* In a non-insane world this function would have this arglist...
1689 (arglist instructions constants stack_depth &optional doc_string interactive)
1691 Lisp_Object fun = make_compiled_function (purify_flag);
1692 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1694 Lisp_Object arglist = args[0];
1695 Lisp_Object instructions = args[1];
1696 Lisp_Object constants = args[2];
1697 Lisp_Object stack_depth = args[3];
1698 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1699 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1701 /* Don't purecopy the doc references in instructions because it's
1702 wasteful; they will get fixed up later.
1704 #### If something goes wrong and they don't get fixed up,
1705 we're screwed, because pure stuff isn't marked and thus the
1706 cons references won't be marked and will get reused.
1708 Note: there will be a window after the byte code is created and
1709 before the doc references are fixed up in which there will be
1710 impure objects inside a pure object, which apparently won't
1711 get marked, leading to trouble. But during that entire window,
1712 the objects are sitting on Vload_force_doc_string_list, which
1713 is staticpro'd, so we're OK. */
1714 Lisp_Object (*cons) (Lisp_Object, Lisp_Object)
1715 = purify_flag ? pure_cons : Fcons;
1717 if (nargs < 4 || nargs > 6)
1718 return Fsignal (Qwrong_number_of_arguments,
1719 list2 (intern ("make-byte-code"), make_int (nargs)));
1721 /* Check for valid formal parameter list now, to allow us to use
1722 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1724 Lisp_Object symbol, tail;
1725 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1727 CHECK_SYMBOL (symbol);
1728 if (EQ (symbol, Qt) ||
1729 EQ (symbol, Qnil) ||
1730 SYMBOL_IS_KEYWORD (symbol))
1731 signal_simple_error_2
1732 ("Invalid constant symbol in formal parameter list",
1736 f->arglist = arglist;
1738 /* `instructions' is a string or a cons (string . int) for a
1739 lazy-loaded function. */
1740 if (CONSP (instructions))
1742 CHECK_STRING (XCAR (instructions));
1743 CHECK_INT (XCDR (instructions));
1747 CHECK_STRING (instructions);
1749 f->instructions = instructions;
1751 if (!NILP (constants))
1752 CHECK_VECTOR (constants);
1753 f->constants = constants;
1755 CHECK_NATNUM (stack_depth);
1756 f->stack_depth = XINT (stack_depth);
1758 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1759 if (!NILP (Vcurrent_compiled_function_annotation))
1760 f->annotated = Fpurecopy (Vcurrent_compiled_function_annotation);
1761 else if (!NILP (Vload_file_name_internal_the_purecopy))
1762 f->annotated = Vload_file_name_internal_the_purecopy;
1763 else if (!NILP (Vload_file_name_internal))
1765 struct gcpro gcpro1;
1766 GCPRO1 (fun); /* don't let fun get reaped */
1767 Vload_file_name_internal_the_purecopy =
1768 Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
1769 f->annotated = Vload_file_name_internal_the_purecopy;
1772 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1774 /* doc_string may be nil, string, int, or a cons (string . int).
1775 interactive may be list or string (or unbound). */
1776 f->doc_and_interactive = Qunbound;
1778 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1779 f->doc_and_interactive = Vfile_domain;
1781 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1785 interactive = Fpurecopy (interactive);
1786 if (STRINGP (interactive))
1787 bump_purestat (&purestat_string_interactive,
1788 pure_sizeof (interactive));
1790 f->doc_and_interactive
1791 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1792 cons (interactive, f->doc_and_interactive));
1794 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1798 doc_string = Fpurecopy (doc_string);
1799 if (STRINGP (doc_string))
1800 /* These should have been snagged by make-docfile... */
1801 bump_purestat (&purestat_string_documentation,
1802 pure_sizeof (doc_string));
1804 f->doc_and_interactive
1805 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1806 cons (doc_string, f->doc_and_interactive));
1808 if (UNBOUNDP (f->doc_and_interactive))
1809 f->doc_and_interactive = Qnil;
1814 if (!purified (f->arglist))
1815 f->arglist = Fpurecopy (f->arglist);
1817 /* Statistics are kept differently for the constants */
1818 if (!purified (f->constants))
1821 int old = purecopying_function_constants;
1822 purecopying_function_constants = 1;
1823 f->constants = Fpurecopy (f->constants);
1824 bump_purestat (&purestat_vector_constants,
1825 pure_sizeof (f->constants));
1826 purecopying_function_constants = old;
1828 f->constants = Fpurecopy (f->constants);
1829 #endif /* PURESTAT */
1832 optimize_compiled_function (fun);
1834 bump_purestat (&purestat_opaque_instructions,
1835 pure_sizeof (f->instructions));
1842 /************************************************************************/
1843 /* Symbol allocation */
1844 /************************************************************************/
1846 DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol);
1847 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1849 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1850 Return a newly allocated uninterned symbol whose name is NAME.
1851 Its value and function definition are void, and its property list is nil.
1856 struct Lisp_Symbol *p;
1858 CHECK_STRING (name);
1860 ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p);
1861 #ifdef LRECORD_SYMBOL
1862 set_lheader_implementation (&(p->lheader), lrecord_symbol);
1864 p->name = XSTRING (name);
1866 p->value = Qunbound;
1867 p->function = Qunbound;
1869 symbol_next (p) = 0;
1870 XSETSYMBOL (val, p);
1875 /************************************************************************/
1876 /* Extent allocation */
1877 /************************************************************************/
1879 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1880 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1883 allocate_extent (void)
1887 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1888 set_lheader_implementation (&(e->lheader), lrecord_extent);
1889 extent_object (e) = Qnil;
1890 set_extent_start (e, -1);
1891 set_extent_end (e, -1);
1896 extent_face (e) = Qnil;
1897 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1898 e->flags.detachable = 1;
1904 /************************************************************************/
1905 /* Event allocation */
1906 /************************************************************************/
1908 DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event);
1909 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1912 allocate_event (void)
1915 struct Lisp_Event *e;
1917 ALLOCATE_FIXED_TYPE (event, struct Lisp_Event, e);
1918 set_lheader_implementation (&(e->lheader), lrecord_event);
1925 /************************************************************************/
1926 /* Marker allocation */
1927 /************************************************************************/
1929 DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker);
1930 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1932 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1933 Return a new marker which does not point at any place.
1938 struct Lisp_Marker *p;
1940 ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1941 set_lheader_implementation (&(p->lheader), lrecord_marker);
1944 marker_next (p) = 0;
1945 marker_prev (p) = 0;
1946 p->insertion_type = 0;
1947 XSETMARKER (val, p);
1952 noseeum_make_marker (void)
1955 struct Lisp_Marker *p;
1957 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1958 set_lheader_implementation (&(p->lheader), lrecord_marker);
1961 marker_next (p) = 0;
1962 marker_prev (p) = 0;
1963 p->insertion_type = 0;
1964 XSETMARKER (val, p);
1969 /************************************************************************/
1970 /* String allocation */
1971 /************************************************************************/
1973 /* The data for "short" strings generally resides inside of structs of type
1974 string_chars_block. The Lisp_String structure is allocated just like any
1975 other Lisp object (except for vectors), and these are freelisted when
1976 they get garbage collected. The data for short strings get compacted,
1977 but the data for large strings do not.
1979 Previously Lisp_String structures were relocated, but this caused a lot
1980 of bus-errors because the C code didn't include enough GCPRO's for
1981 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1982 that the reference would get relocated).
1984 This new method makes things somewhat bigger, but it is MUCH safer. */
1986 DECLARE_FIXED_TYPE_ALLOC (string, struct Lisp_String);
1987 /* strings are used and freed quite often */
1988 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1989 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1991 #ifdef LRECORD_STRING
1993 mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object))
1995 struct Lisp_String *ptr = XSTRING (obj);
1997 if (GC_CONSP (ptr->plist) && GC_EXTENT_INFOP (XCAR (ptr->plist)))
1998 flush_cached_extent_info (XCAR (ptr->plist));
2003 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2006 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
2007 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
2010 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
2011 mark_string, print_string,
2013 * No `finalize', or `hash' methods.
2014 * internal_hash already knows how
2015 * to hash strings and finalization
2017 * ADDITIONAL_FREE_string macro,
2018 * which is the standard way to do
2019 * finalization when using
2020 * SWEEP_FIXED_TYPE_BLOCK().
2023 struct Lisp_String);
2024 #endif /* LRECORD_STRING */
2026 /* String blocks contain this many useful bytes. */
2027 #define STRING_CHARS_BLOCK_SIZE \
2028 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
2029 ((2 * sizeof (struct string_chars_block *)) \
2030 + sizeof (EMACS_INT))))
2031 /* Block header for small strings. */
2032 struct string_chars_block
2035 struct string_chars_block *next;
2036 struct string_chars_block *prev;
2037 /* Contents of string_chars_block->string_chars are interleaved
2038 string_chars structures (see below) and the actual string data */
2039 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
2042 struct string_chars_block *first_string_chars_block;
2043 struct string_chars_block *current_string_chars_block;
2045 /* If SIZE is the length of a string, this returns how many bytes
2046 * the string occupies in string_chars_block->string_chars
2047 * (including alignment padding).
2049 #define STRING_FULLSIZE(s) \
2050 ALIGN_SIZE (((s) + 1 + sizeof (struct Lisp_String *)),\
2051 ALIGNOF (struct Lisp_String *))
2053 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
2054 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
2056 #define CHARS_TO_STRING_CHAR(x) \
2057 ((struct string_chars *) \
2058 (((char *) (x)) - (slot_offset (struct string_chars, chars[0]))))
2063 struct Lisp_String *string;
2064 unsigned char chars[1];
2067 struct unused_string_chars
2069 struct Lisp_String *string;
2074 init_string_chars_alloc (void)
2076 first_string_chars_block = xnew (struct string_chars_block);
2077 first_string_chars_block->prev = 0;
2078 first_string_chars_block->next = 0;
2079 first_string_chars_block->pos = 0;
2080 current_string_chars_block = first_string_chars_block;
2083 static struct string_chars *
2084 allocate_string_chars_struct (struct Lisp_String *string_it_goes_with,
2087 struct string_chars *s_chars;
2089 /* Allocate the string's actual data */
2090 if (BIG_STRING_FULLSIZE_P (fullsize))
2092 s_chars = (struct string_chars *) xmalloc (fullsize);
2094 else if (fullsize <=
2095 (countof (current_string_chars_block->string_chars)
2096 - current_string_chars_block->pos))
2098 /* This string can fit in the current string chars block */
2099 s_chars = (struct string_chars *)
2100 (current_string_chars_block->string_chars
2101 + current_string_chars_block->pos);
2102 current_string_chars_block->pos += fullsize;
2106 /* Make a new current string chars block */
2107 struct string_chars_block *new_scb = xnew (struct string_chars_block);
2109 current_string_chars_block->next = new_scb;
2110 new_scb->prev = current_string_chars_block;
2112 current_string_chars_block = new_scb;
2113 new_scb->pos = fullsize;
2114 s_chars = (struct string_chars *)
2115 current_string_chars_block->string_chars;
2118 s_chars->string = string_it_goes_with;
2120 INCREMENT_CONS_COUNTER (fullsize, "string chars");
2126 make_uninit_string (Bytecount length)
2128 struct Lisp_String *s;
2129 struct string_chars *s_chars;
2130 EMACS_INT fullsize = STRING_FULLSIZE (length);
2133 if ((length < 0) || (fullsize <= 0))
2136 /* Allocate the string header */
2137 ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
2138 #ifdef LRECORD_STRING
2139 set_lheader_implementation (&(s->lheader), lrecord_string);
2142 s_chars = allocate_string_chars_struct (s, fullsize);
2144 set_string_data (s, &(s_chars->chars[0]));
2145 set_string_length (s, length);
2148 set_string_byte (s, length, 0);
2150 XSETSTRING (val, s);
2154 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2155 static void verify_string_chars_integrity (void);
2158 /* Resize the string S so that DELTA bytes can be inserted starting
2159 at POS. If DELTA < 0, it means deletion starting at POS. If
2160 POS < 0, resize the string but don't copy any characters. Use
2161 this if you're planning on completely overwriting the string.
2165 resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta)
2167 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2168 verify_string_chars_integrity ();
2171 #ifdef ERROR_CHECK_BUFPOS
2174 assert (pos <= string_length (s));
2176 assert (pos + (-delta) <= string_length (s));
2181 assert ((-delta) <= string_length (s));
2183 #endif /* ERROR_CHECK_BUFPOS */
2185 if (pos >= 0 && delta < 0)
2186 /* If DELTA < 0, the functions below will delete the characters
2187 before POS. We want to delete characters *after* POS, however,
2188 so convert this to the appropriate form. */
2192 /* simplest case: no size change. */
2196 Bytecount oldfullsize = STRING_FULLSIZE (string_length (s));
2197 Bytecount newfullsize = STRING_FULLSIZE (string_length (s) + delta);
2199 if (oldfullsize == newfullsize)
2201 /* next simplest case; size change but the necessary
2202 allocation size won't change (up or down; code somewhere
2203 depends on there not being any unused allocation space,
2204 modulo any alignment constraints). */
2207 Bufbyte *addroff = pos + string_data (s);
2209 memmove (addroff + delta, addroff,
2210 /* +1 due to zero-termination. */
2211 string_length (s) + 1 - pos);
2214 else if (BIG_STRING_FULLSIZE_P (oldfullsize) &&
2215 BIG_STRING_FULLSIZE_P (newfullsize))
2217 /* next simplest case; the string is big enough to be malloc()ed
2218 itself, so we just realloc.
2220 It's important not to let the string get below the threshold
2221 for making big strings and still remain malloc()ed; if that
2222 were the case, repeated calls to this function on the same
2223 string could result in memory leakage. */
2224 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
2228 Bufbyte *addroff = pos + string_data (s);
2230 memmove (addroff + delta, addroff,
2231 /* +1 due to zero-termination. */
2232 string_length (s) + 1 - pos);
2237 /* worst case. We make a new string_chars struct and copy
2238 the string's data into it, inserting/deleting the delta
2239 in the process. The old string data will either get
2240 freed by us (if it was malloc()ed) or will be reclaimed
2241 in the normal course of garbage collection. */
2242 struct string_chars *s_chars =
2243 allocate_string_chars_struct (s, newfullsize);
2244 Bufbyte *new_addr = &(s_chars->chars[0]);
2245 Bufbyte *old_addr = string_data (s);
2248 memcpy (new_addr, old_addr, pos);
2249 memcpy (new_addr + pos + delta, old_addr + pos,
2250 string_length (s) + 1 - pos);
2252 set_string_data (s, new_addr);
2253 if (BIG_STRING_FULLSIZE_P (oldfullsize))
2257 /* We need to mark this chunk of the string_chars_block
2258 as unused so that compact_string_chars() doesn't
2260 struct string_chars *old_s_chars =
2261 (struct string_chars *) ((char *) old_addr -
2262 sizeof (struct Lisp_String *));
2263 /* Sanity check to make sure we aren't hosed by strange
2264 alignment/padding. */
2265 assert (old_s_chars->string == s);
2266 MARK_STRUCT_AS_FREE (old_s_chars);
2267 ((struct unused_string_chars *) old_s_chars)->fullsize =
2272 set_string_length (s, string_length (s) + delta);
2273 /* If pos < 0, the string won't be zero-terminated.
2274 Terminate now just to make sure. */
2275 string_data (s)[string_length (s)] = '\0';
2281 XSETSTRING (string, s);
2282 /* We also have to adjust all of the extent indices after the
2283 place we did the change. We say "pos - 1" because
2284 adjust_extents() is exclusive of the starting position
2286 adjust_extents (string, pos - 1, string_length (s),
2291 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2292 verify_string_chars_integrity ();
2299 set_string_char (struct Lisp_String *s, Charcount i, Emchar c)
2301 Bufbyte newstr[MAX_EMCHAR_LEN];
2302 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2303 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2304 Bytecount newlen = set_charptr_emchar (newstr, c);
2306 if (oldlen != newlen)
2307 resize_string (s, bytoff, newlen - oldlen);
2308 /* Remember, string_data (s) might have changed so we can't cache it. */
2309 memcpy (string_data (s) + bytoff, newstr, newlen);
2314 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2315 Return a new string of length LENGTH, with each character being INIT.
2316 LENGTH must be an integer and INIT must be a character.
2320 CHECK_NATNUM (length);
2321 CHECK_CHAR_COERCE_INT (init);
2323 Bufbyte init_str[MAX_EMCHAR_LEN];
2324 int len = set_charptr_emchar (init_str, XCHAR (init));
2325 Lisp_Object val = make_uninit_string (len * XINT (length));
2328 /* Optimize the single-byte case */
2329 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2333 Bufbyte *ptr = XSTRING_DATA (val);
2335 for (i = XINT (length); i; i--)
2337 Bufbyte *init_ptr = init_str;
2340 case 4: *ptr++ = *init_ptr++;
2341 case 3: *ptr++ = *init_ptr++;
2342 case 2: *ptr++ = *init_ptr++;
2343 case 1: *ptr++ = *init_ptr++;
2351 DEFUN ("string", Fstring, 0, MANY, 0, /*
2352 Concatenate all the argument characters and make the result a string.
2354 (int nargs, Lisp_Object *args))
2356 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2357 Bufbyte *p = storage;
2359 for (; nargs; nargs--, args++)
2361 Lisp_Object lisp_char = *args;
2362 CHECK_CHAR_COERCE_INT (lisp_char);
2363 p += set_charptr_emchar (p, XCHAR (lisp_char));
2365 return make_string (storage, p - storage);
2368 /* Take some raw memory, which MUST already be in internal format,
2369 and package it up into a Lisp string. */
2371 make_string (CONST Bufbyte *contents, Bytecount length)
2375 /* Make sure we find out about bad make_string's when they happen */
2376 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2377 bytecount_to_charcount (contents, length); /* Just for the assertions */
2380 val = make_uninit_string (length);
2381 memcpy (XSTRING_DATA (val), contents, length);
2385 /* Take some raw memory, encoded in some external data format,
2386 and convert it into a Lisp string. */
2388 make_ext_string (CONST Extbyte *contents, EMACS_INT length,
2389 enum external_data_format fmt)
2394 GET_CHARPTR_INT_DATA_ALLOCA (contents, length, fmt, intstr, intlen);
2395 return make_string (intstr, intlen);
2399 build_string (CONST char *str)
2401 /* Some strlen's crash and burn if passed null. */
2402 return make_string ((CONST Bufbyte *) str, (str ? strlen(str) : 0));
2406 build_ext_string (CONST char *str, enum external_data_format fmt)
2408 /* Some strlen's crash and burn if passed null. */
2409 return make_ext_string ((CONST Extbyte *) str, (str ? strlen(str) : 0), fmt);
2413 build_translated_string (CONST char *str)
2415 return build_string (GETTEXT (str));
2419 /************************************************************************/
2420 /* lcrecord lists */
2421 /************************************************************************/
2423 /* Lcrecord lists are used to manage the allocation of particular
2424 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2425 malloc() and garbage-collection junk) as much as possible.
2426 It is similar to the Blocktype class.
2430 1) Create an lcrecord-list object using make_lcrecord_list().
2431 This is often done at initialization. Remember to staticpro
2432 this object! The arguments to make_lcrecord_list() are the
2433 same as would be passed to alloc_lcrecord().
2434 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2435 and pass the lcrecord-list earlier created.
2436 3) When done with the lcrecord, call free_managed_lcrecord().
2437 The standard freeing caveats apply: ** make sure there are no
2438 pointers to the object anywhere! **
2439 4) Calling free_managed_lcrecord() is just like kissing the
2440 lcrecord goodbye as if it were garbage-collected. This means:
2441 -- the contents of the freed lcrecord are undefined, and the
2442 contents of something produced by allocate_managed_lcrecord()
2443 are undefined, just like for alloc_lcrecord().
2444 -- the mark method for the lcrecord's type will *NEVER* be called
2446 -- the finalize method for the lcrecord's type will be called
2447 at the time that free_managed_lcrecord() is called.
2452 mark_lcrecord_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
2454 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2455 Lisp_Object chain = list->free;
2457 while (!NILP (chain))
2459 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2460 struct free_lcrecord_header *free_header =
2461 (struct free_lcrecord_header *) lheader;
2463 #ifdef ERROR_CHECK_GC
2464 CONST struct lrecord_implementation *implementation
2465 = LHEADER_IMPLEMENTATION(lheader);
2467 /* There should be no other pointers to the free list. */
2468 assert (!MARKED_RECORD_HEADER_P (lheader));
2469 /* Only lcrecords should be here. */
2470 assert (!implementation->basic_p);
2471 /* Only free lcrecords should be here. */
2472 assert (free_header->lcheader.free);
2473 /* The type of the lcrecord must be right. */
2474 assert (implementation == list->implementation);
2475 /* So must the size. */
2476 assert (implementation->static_size == 0
2477 || implementation->static_size == list->size);
2478 #endif /* ERROR_CHECK_GC */
2480 MARK_RECORD_HEADER (lheader);
2481 chain = free_header->chain;
2487 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2488 mark_lcrecord_list, internal_object_printer,
2489 0, 0, 0, struct lcrecord_list);
2491 make_lcrecord_list (size_t size,
2492 CONST struct lrecord_implementation *implementation)
2494 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2495 lrecord_lcrecord_list);
2498 p->implementation = implementation;
2501 XSETLCRECORD_LIST (val, p);
2506 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2508 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2509 if (!NILP (list->free))
2511 Lisp_Object val = list->free;
2512 struct free_lcrecord_header *free_header =
2513 (struct free_lcrecord_header *) XPNTR (val);
2515 #ifdef ERROR_CHECK_GC
2516 struct lrecord_header *lheader =
2517 (struct lrecord_header *) free_header;
2518 CONST struct lrecord_implementation *implementation
2519 = LHEADER_IMPLEMENTATION (lheader);
2521 /* There should be no other pointers to the free list. */
2522 assert (!MARKED_RECORD_HEADER_P (lheader));
2523 /* Only lcrecords should be here. */
2524 assert (!implementation->basic_p);
2525 /* Only free lcrecords should be here. */
2526 assert (free_header->lcheader.free);
2527 /* The type of the lcrecord must be right. */
2528 assert (implementation == list->implementation);
2529 /* So must the size. */
2530 assert (implementation->static_size == 0
2531 || implementation->static_size == list->size);
2532 #endif /* ERROR_CHECK_GC */
2533 list->free = free_header->chain;
2534 free_header->lcheader.free = 0;
2541 XSETOBJ (val, Lisp_Type_Record,
2542 alloc_lcrecord (list->size, list->implementation));
2548 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2550 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2551 struct free_lcrecord_header *free_header =
2552 (struct free_lcrecord_header *) XPNTR (lcrecord);
2553 struct lrecord_header *lheader =
2554 (struct lrecord_header *) free_header;
2555 CONST struct lrecord_implementation *implementation
2556 = LHEADER_IMPLEMENTATION (lheader);
2558 #ifdef ERROR_CHECK_GC
2559 /* Make sure the size is correct. This will catch, for example,
2560 putting a window configuration on the wrong free list. */
2561 if (implementation->size_in_bytes_method)
2562 assert (implementation->size_in_bytes_method (lheader) == list->size);
2564 assert (implementation->static_size == list->size);
2565 #endif /* ERROR_CHECK_GC */
2567 if (implementation->finalizer)
2568 implementation->finalizer (lheader, 0);
2569 free_header->chain = list->free;
2570 free_header->lcheader.free = 1;
2571 list->free = lcrecord;
2575 /************************************************************************/
2576 /* Purity of essence, peace on earth */
2577 /************************************************************************/
2579 static int symbols_initialized;
2582 make_pure_string (CONST Bufbyte *data, Bytecount length,
2583 Lisp_Object plist, int no_need_to_copy_data)
2586 size_t size = sizeof (Lisp_String) +
2587 (no_need_to_copy_data ? 0 : (length + 1)); /* + 1 for terminating 0 */
2588 size = ALIGN_SIZE (size, ALIGNOF (Lisp_Object));
2590 if (symbols_initialized && !pure_lossage)
2592 /* Try to share some names. Saves a few kbytes. */
2593 Lisp_Object tem = oblookup (Vobarray, data, length);
2596 s = XSYMBOL (tem)->name;
2597 if (!PURIFIED (s)) abort ();
2601 XSETSTRING (string, s);
2607 if (!check_purespace (size))
2608 return make_string (data, length);
2610 s = (Lisp_String *) (PUREBEG + pure_bytes_used);
2611 #ifdef LRECORD_STRING
2612 set_lheader_implementation (&(s->lheader), lrecord_string);
2613 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2614 s->lheader.pure = 1;
2617 set_string_length (s, length);
2618 if (no_need_to_copy_data)
2620 set_string_data (s, (Bufbyte *) data);
2624 set_string_data (s, (Bufbyte *) s + sizeof (Lisp_String));
2625 memcpy (string_data (s), data, length);
2626 set_string_byte (s, length, 0);
2629 pure_bytes_used += size;
2632 bump_purestat (&purestat_string_all, size);
2633 if (purecopying_function_constants)
2634 bump_purestat (&purestat_string_other_function, size);
2635 #endif /* PURESTAT */
2637 /* Do this after the official "completion" of the purecopying. */
2638 s->plist = Fpurecopy (plist);
2642 XSETSTRING (string, s);
2649 make_pure_pname (CONST Bufbyte *data, Bytecount length,
2650 int no_need_to_copy_data)
2652 Lisp_Object name = make_pure_string (data, length, Qnil,
2653 no_need_to_copy_data);
2654 bump_purestat (&purestat_string_pname, pure_sizeof (name));
2656 /* We've made (at least) Qnil now, and Vobarray will soon be set up. */
2657 symbols_initialized = 1;
2664 pure_cons (Lisp_Object car, Lisp_Object cdr)
2668 if (!check_purespace (sizeof (Lisp_Cons)))
2669 return Fcons (Fpurecopy (car), Fpurecopy (cdr));
2671 c = (Lisp_Cons *) (PUREBEG + pure_bytes_used);
2673 set_lheader_implementation (&(c->lheader), lrecord_cons);
2674 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2675 c->lheader.pure = 1;
2678 pure_bytes_used += sizeof (Lisp_Cons);
2679 bump_purestat (&purestat_cons, sizeof (Lisp_Cons));
2681 c->car = Fpurecopy (car);
2682 c->cdr = Fpurecopy (cdr);
2692 pure_list (int nargs, Lisp_Object *args)
2694 Lisp_Object val = Qnil;
2696 for (--nargs; nargs >= 0; nargs--)
2697 val = pure_cons (args[nargs], val);
2702 #ifdef LISP_FLOAT_TYPE
2705 make_pure_float (double num)
2707 struct Lisp_Float *f;
2710 /* Make sure that PUREBEG + pure_bytes_used is aligned on at least a sizeof
2711 (double) boundary. Some architectures (like the sparc) require
2712 this, and I suspect that floats are rare enough that it's no
2713 tragedy for those that don't. */
2715 #if defined (__GNUC__) && (__GNUC__ >= 2)
2716 /* In gcc, we can directly ask what the alignment constraints of a
2717 structure are, but in general, that's not possible... Arrgh!!
2719 int alignment = __alignof (struct Lisp_Float);
2721 /* Best guess is to make the `double' slot be aligned to the size
2722 of double (which is probably 8 bytes). This assumes that it's
2723 ok to align the beginning of the structure to the same boundary
2724 that the `double' slot in it is supposed to be aligned to; this
2725 should be ok because presumably there is padding in the layout
2726 of the struct to account for this.
2728 int alignment = sizeof (float_data (f));
2730 char *p = ((char *) PUREBEG + pure_bytes_used);
2732 p = (char *) (((EMACS_UINT) p + alignment - 1) & - alignment);
2733 pure_bytes_used = p - (char *) PUREBEG;
2736 if (!check_purespace (sizeof (struct Lisp_Float)))
2737 return make_float (num);
2739 f = (struct Lisp_Float *) (PUREBEG + pure_bytes_used);
2740 set_lheader_implementation (&(f->lheader), lrecord_float);
2741 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2742 f->lheader.pure = 1;
2744 pure_bytes_used += sizeof (struct Lisp_Float);
2745 bump_purestat (&purestat_float, sizeof (struct Lisp_Float));
2747 float_data (f) = num;
2752 #endif /* LISP_FLOAT_TYPE */
2755 make_pure_vector (size_t len, Lisp_Object init)
2758 size_t size = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, len);
2760 init = Fpurecopy (init);
2762 if (!check_purespace (size))
2763 return make_vector (len, init);
2765 v = (Lisp_Vector *) (PUREBEG + pure_bytes_used);
2766 #ifdef LRECORD_VECTOR
2767 set_lheader_implementation (&(v->header.lheader), lrecord_vector);
2768 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2769 v->header.lheader.pure = 1;
2772 pure_bytes_used += size;
2773 bump_purestat (&purestat_vector_all, size);
2777 for (size = 0; size < len; size++)
2778 v->contents[size] = init;
2782 XSETVECTOR (vector, v);
2788 /* Presently unused */
2790 alloc_pure_lrecord (int size, struct lrecord_implementation *implementation)
2792 struct lrecord_header *header = (void *) (PUREBEG + pure_bytes_used);
2794 if (pure_bytes_used + size > get_PURESIZE())
2795 pure_storage_exhausted ();
2797 set_lheader_implementation (header, implementation);
2805 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2806 Make a copy of OBJECT in pure storage.
2807 Recursively copies contents of vectors and cons cells.
2808 Does not copy symbols.
2816 else if (!POINTER_TYPE_P (XTYPE (obj))
2817 || PURIFIED (XPNTR (obj))
2818 /* happens when bootstrapping Qnil */
2819 || EQ (obj, Qnull_pointer))
2823 /* Order of subsequent tests determined via profiling. */
2824 else if (SYMBOLP (obj))
2826 /* Symbols can't be made pure (and thus read-only), because
2827 assigning to their function, value or plist slots would
2828 produced a SEGV in the dumped XEmacs. So we previously would
2829 just return the symbol unchanged.
2831 But purified aggregate objects like lists and vectors can
2832 contain uninterned symbols. If there are no other non-pure
2833 references to the symbol, then the symbol is not protected
2834 from garbage collection because the collector does not mark
2835 the contents of purified objects. So to protect the symbols,
2836 an impure reference has to be kept for each uninterned symbol
2837 that is referenced by a pure object. All such symbols are
2838 stored in the hash table pointed to by
2839 Vpure_uninterned_symbol_table, which is itself
2841 if (NILP (XSYMBOL (obj)->obarray))
2842 Fputhash (obj, Qnil, Vpure_uninterned_symbol_table);
2845 else if (CONSP (obj))
2847 return pure_cons (XCAR (obj), XCDR (obj));
2849 else if (STRINGP (obj))
2851 return make_pure_string (XSTRING_DATA (obj),
2852 XSTRING_LENGTH (obj),
2853 XSTRING (obj)->plist,
2856 else if (VECTORP (obj))
2859 Lisp_Vector *o = XVECTOR (obj);
2860 Lisp_Object pure_obj = make_pure_vector (vector_length (o), Qnil);
2861 for (i = 0; i < vector_length (o); i++)
2862 XVECTOR_DATA (pure_obj)[i] = Fpurecopy (o->contents[i]);
2865 #ifdef LISP_FLOAT_TYPE
2866 else if (FLOATP (obj))
2868 return make_pure_float (XFLOAT_DATA (obj));
2871 else if (COMPILED_FUNCTIONP (obj))
2873 Lisp_Object pure_obj = make_compiled_function (1);
2874 Lisp_Compiled_Function *o = XCOMPILED_FUNCTION (obj);
2875 Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (pure_obj);
2876 n->flags = o->flags;
2877 n->instructions = o->instructions;
2878 n->constants = Fpurecopy (o->constants);
2879 n->arglist = Fpurecopy (o->arglist);
2880 n->doc_and_interactive = Fpurecopy (o->doc_and_interactive);
2881 n->stack_depth = o->stack_depth;
2882 optimize_compiled_function (pure_obj);
2885 else if (OPAQUEP (obj))
2887 Lisp_Object pure_obj;
2888 Lisp_Opaque *old_opaque = XOPAQUE (obj);
2889 Lisp_Opaque *new_opaque = (Lisp_Opaque *) (PUREBEG + pure_bytes_used);
2890 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2891 CONST struct lrecord_implementation *implementation
2892 = LHEADER_IMPLEMENTATION (lheader);
2893 size_t size = implementation->size_in_bytes_method (lheader);
2894 size_t pure_size = ALIGN_SIZE (size, ALIGNOF (Lisp_Object));
2895 if (!check_purespace (pure_size))
2897 pure_bytes_used += pure_size;
2899 memcpy (new_opaque, old_opaque, size);
2900 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2903 new_opaque->header.next = 0;
2905 XSETOPAQUE (pure_obj, new_opaque);
2910 signal_simple_error ("Can't purecopy %S", obj);
2912 return obj; /* Unreached */
2918 puresize_adjust_h (size_t puresize)
2920 FILE *stream = fopen ("puresize-adjust.h", "w");
2923 report_file_error ("Opening puresize adjustment file",
2924 Fcons (build_string ("puresize-adjust.h"), Qnil));
2927 "/*\tDo not edit this file!\n"
2928 "\tAutomatically generated by XEmacs */\n"
2929 "# define PURESIZE_ADJUSTMENT (%ld)\n",
2930 (long) (puresize - RAW_PURESIZE));
2935 report_pure_usage (int report_impurities,
2936 int die_if_pure_storage_exceeded)
2942 message ("\n****\tPure Lisp storage exhausted!\n"
2943 "\tPurespace usage: %ld of %ld\n"
2945 (long) get_PURESIZE() + pure_lossage,
2946 (long) get_PURESIZE());
2947 if (die_if_pure_storage_exceeded)
2949 puresize_adjust_h (get_PURESIZE() + pure_lossage);
2958 size_t lost = (get_PURESIZE() - pure_bytes_used) / 1024;
2960 /* extern Lisp_Object Vemacs_beta_version; */
2961 /* This used to be NILP(Vemacs_beta_version) ? 512 : 4; */
2962 #ifndef PURESIZE_SLOP
2963 #define PURESIZE_SLOP 0
2965 size_t slop = PURESIZE_SLOP;
2967 sprintf (buf, "Purespace usage: %ld of %ld (%d%%",
2968 (long) pure_bytes_used,
2969 (long) get_PURESIZE(),
2970 (int) (pure_bytes_used / (get_PURESIZE() / 100.0) + 0.5));
2971 if (lost > ((slop ? slop : 1) / 1024)) {
2972 sprintf (buf + strlen (buf), " -- %ldk wasted", (long)lost);
2973 if (die_if_pure_storage_exceeded) {
2974 puresize_adjust_h (pure_bytes_used + slop);
2983 message ("%s", buf);
2988 purestat_vector_other.nbytes =
2989 purestat_vector_all.nbytes -
2990 purestat_vector_constants.nbytes;
2991 purestat_vector_other.nobjects =
2992 purestat_vector_all.nobjects -
2993 purestat_vector_constants.nobjects;
2995 purestat_string_other.nbytes =
2996 purestat_string_all.nbytes -
2997 (purestat_string_pname.nbytes +
2998 purestat_string_interactive.nbytes +
2999 purestat_string_documentation.nbytes +
3001 purestat_string_domain.nbytes +
3003 purestat_string_other_function.nbytes);
3005 purestat_string_other.nobjects =
3006 purestat_string_all.nobjects -
3007 (purestat_string_pname.nobjects +
3008 purestat_string_interactive.nobjects +
3009 purestat_string_documentation.nobjects +
3011 purestat_string_domain.nobjects +
3013 purestat_string_other_function.nobjects);
3015 message (" %-34s Objects Bytes", "");
3017 print_purestat (&purestat_cons);
3018 print_purestat (&purestat_float);
3019 print_purestat (&purestat_string_pname);
3020 print_purestat (&purestat_function);
3021 print_purestat (&purestat_opaque_instructions);
3022 print_purestat (&purestat_vector_constants);
3023 print_purestat (&purestat_string_interactive);
3025 print_purestat (&purestat_string_domain);
3027 print_purestat (&purestat_string_documentation);
3028 print_purestat (&purestat_string_other_function);
3029 print_purestat (&purestat_vector_other);
3030 print_purestat (&purestat_string_other);
3031 print_purestat (&purestat_string_all);
3032 print_purestat (&purestat_vector_all);
3034 #endif /* PURESTAT */
3037 if (report_impurities)
3040 struct gcpro gcpro1;
3041 plist = XCAR (XCDR (XCDR (XCDR (XCDR (XCDR (Fgarbage_collect()))))));
3043 message ("\nImpurities:");
3044 for (; CONSP (plist); plist = XCDR (XCDR (plist)))
3046 Lisp_Object symbol = XCAR (plist);
3047 int size = XINT (XCAR (XCDR (plist)));
3053 string_data (XSYMBOL (symbol)->name),
3054 string_length (XSYMBOL (symbol)->name) + 1);
3055 while (*s++) if (*s == '-') *s = ' ';
3056 *(s-1) = ':'; *s = 0;
3057 message (" %-34s %6d", buf, size);
3061 garbage_collect_1 (); /* collect Fgarbage_collect()'s garbage */
3066 unlink("SATISFIED");
3067 fatal ("Pure size adjusted, Don't Panic! I will restart the `make'");
3068 } else if (pure_lossage && die_if_pure_storage_exceeded) {
3069 fatal ("Pure storage exhausted");
3074 /************************************************************************/
3075 /* Garbage Collection */
3076 /************************************************************************/
3078 /* This will be used more extensively In The Future */
3079 static int last_lrecord_type_index_assigned;
3081 CONST struct lrecord_implementation *lrecord_implementations_table[128];
3082 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
3084 struct gcpro *gcprolist;
3086 /* 415 used Mly 29-Jun-93 */
3087 /* 1327 used slb 28-Feb-98 */
3089 #define NSTATICS 4000
3091 #define NSTATICS 2000
3093 /* Not "static" because of linker lossage on some systems */
3094 Lisp_Object *staticvec[NSTATICS]
3095 /* Force it into data space! */
3097 static int staticidx;
3099 /* Put an entry in staticvec, pointing at the variable whose address is given
3102 staticpro (Lisp_Object *varaddress)
3104 if (staticidx >= countof (staticvec))
3105 /* #### This is now a dubious abort() since this routine may be called */
3106 /* by Lisp attempting to load a DLL. */
3108 staticvec[staticidx++] = varaddress;
3112 /* Mark reference to a Lisp_Object. If the object referred to has not been
3113 seen yet, recursively mark all the references contained in it. */
3116 mark_object (Lisp_Object obj)
3120 #ifdef ERROR_CHECK_GC
3121 assert (! (GC_EQ (obj, Qnull_pointer)));
3123 /* Checks we used to perform */
3124 /* if (EQ (obj, Qnull_pointer)) return; */
3125 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
3126 /* if (PURIFIED (XPNTR (obj))) return; */
3128 switch (XGCTYPE (obj))
3130 #ifndef LRECORD_CONS
3131 case Lisp_Type_Cons:
3133 struct Lisp_Cons *ptr = XCONS (obj);
3136 if (CONS_MARKED_P (ptr))
3139 /* If the cdr is nil, tail-recurse on the car. */
3140 if (GC_NILP (ptr->cdr))
3146 mark_object (ptr->car);
3153 case Lisp_Type_Record:
3155 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3156 #if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION)
3157 assert (lheader->type <= last_lrecord_type_index_assigned);
3159 if (PURIFIED (lheader))
3162 if (! MARKED_RECORD_HEADER_P (lheader) &&
3163 ! UNMARKABLE_RECORD_HEADER_P (lheader))
3165 CONST struct lrecord_implementation *implementation =
3166 LHEADER_IMPLEMENTATION (lheader);
3167 MARK_RECORD_HEADER (lheader);
3168 #ifdef ERROR_CHECK_GC
3169 if (!implementation->basic_p)
3170 assert (! ((struct lcrecord_header *) lheader)->free);
3172 if (implementation->marker)
3174 obj = implementation->marker (obj, mark_object);
3175 if (!GC_NILP (obj)) goto tail_recurse;
3181 #ifndef LRECORD_STRING
3182 case Lisp_Type_String:
3184 struct Lisp_String *ptr = XSTRING (obj);
3188 if (!XMARKBIT (ptr->plist))
3190 if (CONSP (ptr->plist) &&
3191 EXTENT_INFOP (XCAR (ptr->plist)))
3192 flush_cached_extent_info (XCAR (ptr->plist));
3199 #endif /* ! LRECORD_STRING */
3201 #ifndef LRECORD_VECTOR
3202 case Lisp_Type_Vector:
3204 struct Lisp_Vector *ptr = XVECTOR (obj);
3210 len = vector_length (ptr);
3213 break; /* Already marked */
3214 ptr->size = -1 - len; /* Else mark it */
3215 for (i = 0; i < len - 1; i++) /* and then mark its elements */
3216 mark_object (ptr->contents[i]);
3219 obj = ptr->contents[len - 1];
3224 #endif /* !LRECORD_VECTOR */
3226 #ifndef LRECORD_SYMBOL
3227 case Lisp_Type_Symbol:
3229 struct Lisp_Symbol *sym = XSYMBOL (obj);
3234 while (!XMARKBIT (sym->plist))
3237 mark_object (sym->value);
3238 mark_object (sym->function);
3241 * symbol->name is a struct Lisp_String *, not a
3242 * Lisp_Object. Fix it up and pass to mark_object.
3244 Lisp_Object symname;
3245 XSETSTRING (symname, sym->name);
3246 mark_object (symname);
3248 if (!symbol_next (sym))
3253 mark_object (sym->plist);
3254 /* Mark the rest of the symbols in the hash-chain */
3255 sym = symbol_next (sym);
3259 #endif /* !LRECORD_SYMBOL */
3261 /* Check for invalid Lisp_Object types */
3262 #if defined (ERROR_CHECK_GC) && ! defined (USE_MINIMAL_TAGBITS)
3264 case Lisp_Type_Char:
3269 #endif /* ERROR_CHECK_GC && ! USE_MINIMAL_TAGBITS */
3273 /* mark all of the conses in a list and mark the final cdr; but
3274 DO NOT mark the cars.
3276 Use only for internal lists! There should never be other pointers
3277 to the cons cells, because if so, the cars will remain unmarked
3278 even when they maybe should be marked. */
3280 mark_conses_in_list (Lisp_Object obj)
3284 for (rest = obj; CONSP (rest); rest = XCDR (rest))
3286 if (CONS_MARKED_P (XCONS (rest)))
3288 MARK_CONS (XCONS (rest));
3296 /* Simpler than mark-object, because pure structure can't
3297 have any circularities */
3300 pure_string_sizeof (Lisp_Object obj)
3302 struct Lisp_String *ptr = XSTRING (obj);
3304 if (string_data (ptr) != (Bufbyte *) ptr + sizeof (*ptr))
3306 /* string-data not allocated contiguously.
3307 Probably (better be!!) a pointer constant "C" data. */
3308 return sizeof (*ptr);
3312 size_t size = sizeof (*ptr) + string_length (ptr) + 1;
3313 size = ALIGN_SIZE (size, sizeof (Lisp_Object));
3319 pure_sizeof (Lisp_Object obj)
3321 if (!POINTER_TYPE_P (XTYPE (obj))
3322 || !PURIFIED (XPNTR (obj)))
3324 /* symbol sizes are accounted for separately */
3325 else if (SYMBOLP (obj))
3327 else if (STRINGP (obj))
3328 return pure_string_sizeof (obj);
3329 else if (LRECORDP (obj))
3331 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3332 CONST struct lrecord_implementation *implementation
3333 = LHEADER_IMPLEMENTATION (lheader);
3335 return implementation->size_in_bytes_method
3336 ? implementation->size_in_bytes_method (lheader)
3337 : implementation->static_size;
3339 #ifndef LRECORD_VECTOR
3340 else if (VECTORP (obj))
3341 return STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, XVECTOR_LENGTH (obj));
3342 #endif /* !LRECORD_VECTOR */
3344 #ifndef LRECORD_CONS
3345 else if (CONSP (obj))
3346 return sizeof (struct Lisp_Cons);
3347 #endif /* !LRECORD_CONS */
3349 /* Others can't be purified */
3351 return 0; /* unreached */
3353 #endif /* PURESTAT */
3358 /* Find all structures not marked, and free them. */
3360 #ifndef LRECORD_VECTOR
3361 static int gc_count_num_vector_used, gc_count_vector_total_size;
3362 static int gc_count_vector_storage;
3364 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
3365 static int gc_count_bit_vector_storage;
3366 static int gc_count_num_short_string_in_use;
3367 static int gc_count_string_total_size;
3368 static int gc_count_short_string_total_size;
3370 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3374 lrecord_type_index (CONST struct lrecord_implementation *implementation)
3376 int type_index = *(implementation->lrecord_type_index);
3377 /* Have to do this circuitous validation test because of problems
3378 dumping out initialized variables (ie can't set xxx_type_index to -1
3379 because that would make xxx_type_index read-only in a dumped emacs. */
3380 if (type_index < 0 || type_index > max_lrecord_type
3381 || lrecord_implementations_table[type_index] != implementation)
3383 assert (last_lrecord_type_index_assigned < max_lrecord_type);
3384 type_index = ++last_lrecord_type_index_assigned;
3385 lrecord_implementations_table[type_index] = implementation;
3386 *(implementation->lrecord_type_index) = type_index;
3391 /* stats on lcrecords in use - kinda kludgy */
3395 int instances_in_use;
3397 int instances_freed;
3399 int instances_on_free_list;
3400 } lcrecord_stats [countof (lrecord_implementations_table)];
3403 tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p)
3405 CONST struct lrecord_implementation *implementation =
3406 LHEADER_IMPLEMENTATION (h);
3407 int type_index = lrecord_type_index (implementation);
3409 if (((struct lcrecord_header *) h)->free)
3412 lcrecord_stats[type_index].instances_on_free_list++;
3416 size_t sz = (implementation->size_in_bytes_method
3417 ? implementation->size_in_bytes_method (h)
3418 : implementation->static_size);
3422 lcrecord_stats[type_index].instances_freed++;
3423 lcrecord_stats[type_index].bytes_freed += sz;
3427 lcrecord_stats[type_index].instances_in_use++;
3428 lcrecord_stats[type_index].bytes_in_use += sz;
3434 /* Free all unmarked records */
3436 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
3438 struct lcrecord_header *header;
3440 /* int total_size = 0; */
3442 xzero (lcrecord_stats); /* Reset all statistics to 0. */
3444 /* First go through and call all the finalize methods.
3445 Then go through and free the objects. There used to
3446 be only one loop here, with the call to the finalizer
3447 occurring directly before the xfree() below. That
3448 is marginally faster but much less safe -- if the
3449 finalize method for an object needs to reference any
3450 other objects contained within it (and many do),
3451 we could easily be screwed by having already freed that
3454 for (header = *prev; header; header = header->next)
3456 struct lrecord_header *h = &(header->lheader);
3457 if (!MARKED_RECORD_HEADER_P (h) && ! (header->free))
3459 if (LHEADER_IMPLEMENTATION (h)->finalizer)
3460 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
3464 for (header = *prev; header; )
3466 struct lrecord_header *h = &(header->lheader);
3467 if (MARKED_RECORD_HEADER_P (h))
3469 UNMARK_RECORD_HEADER (h);
3471 /* total_size += n->implementation->size_in_bytes (h);*/
3472 prev = &(header->next);
3474 tick_lcrecord_stats (h, 0);
3478 struct lcrecord_header *next = header->next;
3480 tick_lcrecord_stats (h, 1);
3481 /* used to call finalizer right here. */
3487 /* *total = total_size; */
3490 #ifndef LRECORD_VECTOR
3493 sweep_vectors_1 (Lisp_Object *prev,
3494 int *used, int *total, int *storage)
3499 int total_storage = 0;
3501 for (vector = *prev; VECTORP (vector); )
3503 Lisp_Vector *v = XVECTOR (vector);
3505 if (len < 0) /* marked */
3512 STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, len + 1);
3514 prev = &(vector_next (v));
3519 Lisp_Object next = vector_next (v);
3526 *total = total_size;
3527 *storage = total_storage;
3530 #endif /* ! LRECORD_VECTOR */
3533 sweep_bit_vectors_1 (Lisp_Object *prev,
3534 int *used, int *total, int *storage)
3536 Lisp_Object bit_vector;
3539 int total_storage = 0;
3541 /* BIT_VECTORP fails because the objects are marked, which changes
3542 their implementation */
3543 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
3545 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
3547 if (MARKED_RECORD_P (bit_vector))
3549 UNMARK_RECORD_HEADER (&(v->lheader));
3553 STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
3554 BIT_VECTOR_LONG_STORAGE (len));
3556 prev = &(bit_vector_next (v));
3561 Lisp_Object next = bit_vector_next (v);
3568 *total = total_size;
3569 *storage = total_storage;
3572 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3573 to make macros prettier. */
3575 #ifdef ERROR_CHECK_GC
3577 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3579 struct typename##_block *SFTB_current; \
3580 struct typename##_block **SFTB_prev; \
3582 int num_free = 0, num_used = 0; \
3584 for (SFTB_prev = ¤t_##typename##_block, \
3585 SFTB_current = current_##typename##_block, \
3586 SFTB_limit = current_##typename##_block_index; \
3592 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
3594 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
3596 if (FREE_STRUCT_P (SFTB_victim)) \
3600 else if (!MARKED_##typename##_P (SFTB_victim)) \
3603 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
3608 UNMARK_##typename (SFTB_victim); \
3611 SFTB_prev = &(SFTB_current->prev); \
3612 SFTB_current = SFTB_current->prev; \
3613 SFTB_limit = countof (current_##typename##_block->block); \
3616 gc_count_num_##typename##_in_use = num_used; \
3617 gc_count_num_##typename##_freelist = num_free; \
3620 #else /* !ERROR_CHECK_GC */
3622 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3624 struct typename##_block *SFTB_current; \
3625 struct typename##_block **SFTB_prev; \
3627 int num_free = 0, num_used = 0; \
3629 typename##_free_list = 0; \
3631 for (SFTB_prev = ¤t_##typename##_block, \
3632 SFTB_current = current_##typename##_block, \
3633 SFTB_limit = current_##typename##_block_index; \
3638 int SFTB_empty = 1; \
3639 obj_type *SFTB_old_free_list = typename##_free_list; \
3641 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
3643 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
3645 if (FREE_STRUCT_P (SFTB_victim)) \
3648 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
3650 else if (!MARKED_##typename##_P (SFTB_victim)) \
3653 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
3659 UNMARK_##typename (SFTB_victim); \
3664 SFTB_prev = &(SFTB_current->prev); \
3665 SFTB_current = SFTB_current->prev; \
3667 else if (SFTB_current == current_##typename##_block \
3668 && !SFTB_current->prev) \
3670 /* No real point in freeing sole allocation block */ \
3675 struct typename##_block *SFTB_victim_block = SFTB_current; \
3676 if (SFTB_victim_block == current_##typename##_block) \
3677 current_##typename##_block_index \
3678 = countof (current_##typename##_block->block); \
3679 SFTB_current = SFTB_current->prev; \
3681 *SFTB_prev = SFTB_current; \
3682 xfree (SFTB_victim_block); \
3683 /* Restore free list to what it was before victim was swept */ \
3684 typename##_free_list = SFTB_old_free_list; \
3685 num_free -= SFTB_limit; \
3688 SFTB_limit = countof (current_##typename##_block->block); \
3691 gc_count_num_##typename##_in_use = num_used; \
3692 gc_count_num_##typename##_freelist = num_free; \
3695 #endif /* !ERROR_CHECK_GC */
3703 #ifndef LRECORD_CONS
3704 # define MARKED_cons_P(ptr) XMARKBIT ((ptr)->car)
3705 # define UNMARK_cons(ptr) do { XUNMARK ((ptr)->car); } while (0)
3706 #else /* LRECORD_CONS */
3707 # define MARKED_cons_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3708 # define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3709 #endif /* LRECORD_CONS */
3710 #define ADDITIONAL_FREE_cons(ptr)
3712 SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons);
3715 /* Explicitly free a cons cell. */
3717 free_cons (struct Lisp_Cons *ptr)
3719 #ifdef ERROR_CHECK_GC
3720 /* If the CAR is not an int, then it will be a pointer, which will
3721 always be four-byte aligned. If this cons cell has already been
3722 placed on the free list, however, its car will probably contain
3723 a chain pointer to the next cons on the list, which has cleverly
3724 had all its 0's and 1's inverted. This allows for a quick
3725 check to make sure we're not freeing something already freed. */
3726 if (POINTER_TYPE_P (XTYPE (ptr->car)))
3727 ASSERT_VALID_POINTER (XPNTR (ptr->car));
3728 #endif /* ERROR_CHECK_GC */
3730 #ifndef ALLOC_NO_POOLS
3731 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, struct Lisp_Cons, ptr);
3732 #endif /* ALLOC_NO_POOLS */
3735 /* explicitly free a list. You **must make sure** that you have
3736 created all the cons cells that make up this list and that there
3737 are no pointers to any of these cons cells anywhere else. If there
3738 are, you will lose. */
3741 free_list (Lisp_Object list)
3743 Lisp_Object rest, next;
3745 for (rest = list; !NILP (rest); rest = next)
3748 free_cons (XCONS (rest));
3752 /* explicitly free an alist. You **must make sure** that you have
3753 created all the cons cells that make up this alist and that there
3754 are no pointers to any of these cons cells anywhere else. If there
3755 are, you will lose. */
3758 free_alist (Lisp_Object alist)
3760 Lisp_Object rest, next;
3762 for (rest = alist; !NILP (rest); rest = next)
3765 free_cons (XCONS (XCAR (rest)));
3766 free_cons (XCONS (rest));
3771 sweep_compiled_functions (void)
3773 #define MARKED_compiled_function_P(ptr) \
3774 MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3775 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3776 #define ADDITIONAL_FREE_compiled_function(ptr)
3778 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
3782 #ifdef LISP_FLOAT_TYPE
3786 #define MARKED_float_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3787 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3788 #define ADDITIONAL_FREE_float(ptr)
3790 SWEEP_FIXED_TYPE_BLOCK (float, struct Lisp_Float);
3792 #endif /* LISP_FLOAT_TYPE */
3795 sweep_symbols (void)
3797 #ifndef LRECORD_SYMBOL
3798 # define MARKED_symbol_P(ptr) XMARKBIT ((ptr)->plist)
3799 # define UNMARK_symbol(ptr) do { XUNMARK ((ptr)->plist); } while (0)
3801 # define MARKED_symbol_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3802 # define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3803 #endif /* !LRECORD_SYMBOL */
3804 #define ADDITIONAL_FREE_symbol(ptr)
3806 SWEEP_FIXED_TYPE_BLOCK (symbol, struct Lisp_Symbol);
3810 sweep_extents (void)
3812 #define MARKED_extent_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3813 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3814 #define ADDITIONAL_FREE_extent(ptr)
3816 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
3822 #define MARKED_event_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3823 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3824 #define ADDITIONAL_FREE_event(ptr)
3826 SWEEP_FIXED_TYPE_BLOCK (event, struct Lisp_Event);
3830 sweep_markers (void)
3832 #define MARKED_marker_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3833 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3834 #define ADDITIONAL_FREE_marker(ptr) \
3835 do { Lisp_Object tem; \
3836 XSETMARKER (tem, ptr); \
3837 unchain_marker (tem); \
3840 SWEEP_FIXED_TYPE_BLOCK (marker, struct Lisp_Marker);
3843 /* Explicitly free a marker. */
3845 free_marker (struct Lisp_Marker *ptr)
3847 #ifdef ERROR_CHECK_GC
3848 /* Perhaps this will catch freeing an already-freed marker. */
3850 XSETMARKER (temmy, ptr);
3851 assert (GC_MARKERP (temmy));
3852 #endif /* ERROR_CHECK_GC */
3854 #ifndef ALLOC_NO_POOLS
3855 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr);
3856 #endif /* ALLOC_NO_POOLS */
3860 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
3863 verify_string_chars_integrity (void)
3865 struct string_chars_block *sb;
3867 /* Scan each existing string block sequentially, string by string. */
3868 for (sb = first_string_chars_block; sb; sb = sb->next)
3871 /* POS is the index of the next string in the block. */
3872 while (pos < sb->pos)
3874 struct string_chars *s_chars =
3875 (struct string_chars *) &(sb->string_chars[pos]);
3876 struct Lisp_String *string;
3880 /* If the string_chars struct is marked as free (i.e. the STRING
3881 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3882 storage. (See below.) */
3884 if (FREE_STRUCT_P (s_chars))
3886 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3891 string = s_chars->string;
3892 /* Must be 32-bit aligned. */
3893 assert ((((int) string) & 3) == 0);
3895 size = string_length (string);
3896 fullsize = STRING_FULLSIZE (size);
3898 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3899 assert (string_data (string) == s_chars->chars);
3902 assert (pos == sb->pos);
3906 #endif /* MULE && ERROR_CHECK_GC */
3908 /* Compactify string chars, relocating the reference to each --
3909 free any empty string_chars_block we see. */
3911 compact_string_chars (void)
3913 struct string_chars_block *to_sb = first_string_chars_block;
3915 struct string_chars_block *from_sb;
3917 /* Scan each existing string block sequentially, string by string. */
3918 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3921 /* FROM_POS is the index of the next string in the block. */
3922 while (from_pos < from_sb->pos)
3924 struct string_chars *from_s_chars =
3925 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3926 struct string_chars *to_s_chars;
3927 struct Lisp_String *string;
3931 /* If the string_chars struct is marked as free (i.e. the STRING
3932 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3933 storage. This happens under Mule when a string's size changes
3934 in such a way that its fullsize changes. (Strings can change
3935 size because a different-length character can be substituted
3936 for another character.) In this case, after the bogus string
3937 pointer is the "fullsize" of this entry, i.e. how many bytes
3940 if (FREE_STRUCT_P (from_s_chars))
3942 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3943 from_pos += fullsize;
3947 string = from_s_chars->string;
3948 assert (!(FREE_STRUCT_P (string)));
3950 size = string_length (string);
3951 fullsize = STRING_FULLSIZE (size);
3953 if (BIG_STRING_FULLSIZE_P (fullsize))
3956 /* Just skip it if it isn't marked. */
3957 #ifdef LRECORD_STRING
3958 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3960 if (!XMARKBIT (string->plist))
3963 from_pos += fullsize;
3967 /* If it won't fit in what's left of TO_SB, close TO_SB out
3968 and go on to the next string_chars_block. We know that TO_SB
3969 cannot advance past FROM_SB here since FROM_SB is large enough
3970 to currently contain this string. */
3971 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3973 to_sb->pos = to_pos;
3974 to_sb = to_sb->next;
3978 /* Compute new address of this string
3979 and update TO_POS for the space being used. */
3980 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3982 /* Copy the string_chars to the new place. */
3983 if (from_s_chars != to_s_chars)
3984 memmove (to_s_chars, from_s_chars, fullsize);
3986 /* Relocate FROM_S_CHARS's reference */
3987 set_string_data (string, &(to_s_chars->chars[0]));
3989 from_pos += fullsize;
3994 /* Set current to the last string chars block still used and
3995 free any that follow. */
3997 struct string_chars_block *victim;
3999 for (victim = to_sb->next; victim; )
4001 struct string_chars_block *next = victim->next;
4006 current_string_chars_block = to_sb;
4007 current_string_chars_block->pos = to_pos;
4008 current_string_chars_block->next = 0;
4012 #if 1 /* Hack to debug missing purecopy's */
4013 static int debug_string_purity;
4016 debug_string_purity_print (struct Lisp_String *p)
4019 Charcount s = string_char_length (p);
4020 putc ('\"', stderr);
4021 for (i = 0; i < s; i++)
4023 Emchar ch = string_char (p, i);
4024 if (ch < 32 || ch >= 126)
4025 stderr_out ("\\%03o", ch);
4026 else if (ch == '\\' || ch == '\"')
4027 stderr_out ("\\%c", ch);
4029 stderr_out ("%c", ch);
4031 stderr_out ("\"\n");
4037 sweep_strings (void)
4039 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
4040 int debug = debug_string_purity;
4042 #ifdef LRECORD_STRING
4044 # define MARKED_string_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
4045 # define UNMARK_string(ptr) \
4046 do { struct Lisp_String *p = (ptr); \
4047 int size = string_length (p); \
4048 UNMARK_RECORD_HEADER (&(p->lheader)); \
4049 num_bytes += size; \
4050 if (!BIG_STRING_SIZE_P (size)) \
4051 { num_small_bytes += size; \
4054 if (debug) debug_string_purity_print (p); \
4056 # define ADDITIONAL_FREE_string(p) \
4057 do { int size = string_length (p); \
4058 if (BIG_STRING_SIZE_P (size)) \
4059 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
4064 # define MARKED_string_P(ptr) XMARKBIT ((ptr)->plist)
4065 # define UNMARK_string(ptr) \
4066 do { struct Lisp_String *p = (ptr); \
4067 int size = string_length (p); \
4068 XUNMARK (p->plist); \
4069 num_bytes += size; \
4070 if (!BIG_STRING_SIZE_P (size)) \
4071 { num_small_bytes += size; \
4074 if (debug) debug_string_purity_print (p); \
4076 # define ADDITIONAL_FREE_string(p) \
4077 do { int size = string_length (p); \
4078 if (BIG_STRING_SIZE_P (size)) \
4079 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
4082 #endif /* ! LRECORD_STRING */
4084 SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String);
4086 gc_count_num_short_string_in_use = num_small_used;
4087 gc_count_string_total_size = num_bytes;
4088 gc_count_short_string_total_size = num_small_bytes;
4092 /* I hate duplicating all this crap! */
4094 marked_p (Lisp_Object obj)
4096 #ifdef ERROR_CHECK_GC
4097 assert (! (GC_EQ (obj, Qnull_pointer)));
4099 /* Checks we used to perform. */
4100 /* if (EQ (obj, Qnull_pointer)) return 1; */
4101 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
4102 /* if (PURIFIED (XPNTR (obj))) return 1; */
4104 switch (XGCTYPE (obj))
4106 #ifndef LRECORD_CONS
4107 case Lisp_Type_Cons:
4109 struct Lisp_Cons *ptr = XCONS (obj);
4110 return PURIFIED (ptr) || XMARKBIT (ptr->car);
4113 case Lisp_Type_Record:
4115 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
4116 #if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION)
4117 assert (lheader->type <= last_lrecord_type_index_assigned);
4119 return PURIFIED (lheader) || MARKED_RECORD_HEADER_P (lheader);
4121 #ifndef LRECORD_STRING
4122 case Lisp_Type_String:
4124 struct Lisp_String *ptr = XSTRING (obj);
4125 return PURIFIED (ptr) || XMARKBIT (ptr->plist);
4127 #endif /* ! LRECORD_STRING */
4128 #ifndef LRECORD_VECTOR
4129 case Lisp_Type_Vector:
4131 struct Lisp_Vector *ptr = XVECTOR (obj);
4132 return PURIFIED (ptr) || vector_length (ptr) < 0;
4134 #endif /* !LRECORD_VECTOR */
4135 #ifndef LRECORD_SYMBOL
4136 case Lisp_Type_Symbol:
4138 struct Lisp_Symbol *ptr = XSYMBOL (obj);
4139 return PURIFIED (ptr) || XMARKBIT (ptr->plist);
4143 /* Ints and Chars don't need GC */
4144 #if defined (USE_MINIMAL_TAGBITS) || ! defined (ERROR_CHECK_GC)
4151 case Lisp_Type_Char:
4160 /* Free all unmarked records. Do this at the very beginning,
4161 before anything else, so that the finalize methods can safely
4162 examine items in the objects. sweep_lcrecords_1() makes
4163 sure to call all the finalize methods *before* freeing anything,
4164 to complete the safety. */
4167 sweep_lcrecords_1 (&all_lcrecords, &ignored);
4170 compact_string_chars ();
4172 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
4173 macros) must be *extremely* careful to make sure they're not
4174 referencing freed objects. The only two existing finalize
4175 methods (for strings and markers) pass muster -- the string
4176 finalizer doesn't look at anything but its own specially-
4177 created block, and the marker finalizer only looks at live
4178 buffers (which will never be freed) and at the markers before
4179 and after it in the chain (which, by induction, will never be
4180 freed because if so, they would have already removed themselves
4183 /* Put all unmarked strings on free list, free'ing the string chars
4184 of large unmarked strings */
4187 /* Put all unmarked conses on free list */
4190 #ifndef LRECORD_VECTOR
4191 /* Free all unmarked vectors */
4192 sweep_vectors_1 (&all_vectors,
4193 &gc_count_num_vector_used, &gc_count_vector_total_size,
4194 &gc_count_vector_storage);
4197 /* Free all unmarked bit vectors */
4198 sweep_bit_vectors_1 (&all_bit_vectors,
4199 &gc_count_num_bit_vector_used,
4200 &gc_count_bit_vector_total_size,
4201 &gc_count_bit_vector_storage);
4203 /* Free all unmarked compiled-function objects */
4204 sweep_compiled_functions ();
4206 #ifdef LISP_FLOAT_TYPE
4207 /* Put all unmarked floats on free list */
4211 /* Put all unmarked symbols on free list */
4214 /* Put all unmarked extents on free list */
4217 /* Put all unmarked markers on free list.
4218 Dechain each one first from the buffer into which it points. */
4225 /* Clearing for disksave. */
4228 disksave_object_finalization (void)
4230 /* It's important that certain information from the environment not get
4231 dumped with the executable (pathnames, environment variables, etc.).
4232 To make it easier to tell when this has happened with strings(1) we
4233 clear some known-to-be-garbage blocks of memory, so that leftover
4234 results of old evaluation don't look like potential problems.
4235 But first we set some notable variables to nil and do one more GC,
4236 to turn those strings into garbage.
4239 /* Yeah, this list is pretty ad-hoc... */
4240 Vprocess_environment = Qnil;
4241 Vexec_directory = Qnil;
4242 Vdata_directory = Qnil;
4243 Vsite_directory = Qnil;
4244 Vdoc_directory = Qnil;
4245 Vconfigure_info_directory = Qnil;
4248 /* Vdump_load_path = Qnil; */
4249 /* Release hash tables for locate_file */
4250 Fset (intern ("early-package-load-path"), Qnil);
4251 Fset (intern ("late-package-load-path"), Qnil);
4252 Fset (intern ("last-package-load-path"), Qnil);
4253 uncache_home_directory();
4255 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
4256 defined(LOADHIST_BUILTIN))
4257 Vload_history = Qnil;
4259 Vshell_file_name = Qnil;
4261 garbage_collect_1 ();
4263 /* Run the disksave finalization methods of all live objects. */
4264 disksave_object_finalization_1 ();
4266 #if 0 /* I don't see any point in this. The purespace starts out all 0's */
4267 /* Zero out the unused portion of purespace */
4269 memset ( (char *) (PUREBEG + pure_bytes_used), 0,
4270 (((char *) (PUREBEG + get_PURESIZE())) -
4271 ((char *) (PUREBEG + pure_bytes_used))));
4274 /* Zero out the uninitialized (really, unused) part of the containers
4275 for the live strings. */
4277 struct string_chars_block *scb;
4278 for (scb = first_string_chars_block; scb; scb = scb->next)
4280 int count = sizeof (scb->string_chars) - scb->pos;
4282 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
4284 /* from the block's fill ptr to the end */
4285 memset ((scb->string_chars + scb->pos), 0, count);
4290 /* There, that ought to be enough... */
4296 restore_gc_inhibit (Lisp_Object val)
4298 gc_currently_forbidden = XINT (val);
4302 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
4303 static int gc_hooks_inhibited;
4307 garbage_collect_1 (void)
4309 #if MAX_SAVE_STACK > 0
4310 char stack_top_variable;
4311 extern char *stack_bottom;
4316 Lisp_Object pre_gc_cursor;
4317 struct gcpro gcpro1;
4320 || gc_currently_forbidden
4322 || preparing_for_armageddon)
4325 /* We used to call selected_frame() here.
4327 The following functions cannot be called inside GC
4328 so we move to after the above tests. */
4331 Lisp_Object device = Fselected_device (Qnil);
4332 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
4334 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
4336 signal_simple_error ("No frames exist on device", device);
4340 pre_gc_cursor = Qnil;
4343 GCPRO1 (pre_gc_cursor);
4345 /* Very important to prevent GC during any of the following
4346 stuff that might run Lisp code; otherwise, we'll likely
4347 have infinite GC recursion. */
4348 speccount = specpdl_depth ();
4349 record_unwind_protect (restore_gc_inhibit,
4350 make_int (gc_currently_forbidden));
4351 gc_currently_forbidden = 1;
4353 if (!gc_hooks_inhibited)
4354 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
4356 /* Now show the GC cursor/message. */
4357 if (!noninteractive)
4359 if (FRAME_WIN_P (f))
4361 Lisp_Object frame = make_frame (f);
4362 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
4363 FRAME_SELECTED_WINDOW (f),
4365 pre_gc_cursor = f->pointer;
4366 if (POINTER_IMAGE_INSTANCEP (cursor)
4367 /* don't change if we don't know how to change back. */
4368 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
4371 Fset_frame_pointer (frame, cursor);
4375 /* Don't print messages to the stream device. */
4376 if (!cursor_changed && !FRAME_STREAM_P (f))
4378 char *msg = (STRINGP (Vgc_message)
4379 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
4381 Lisp_Object args[2], whole_msg;
4382 args[0] = build_string (msg ? msg :
4383 GETTEXT ((CONST char *) gc_default_message));
4384 args[1] = build_string ("...");
4385 whole_msg = Fconcat (2, args);
4386 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
4387 Qgarbage_collecting);
4391 /***** Now we actually start the garbage collection. */
4395 gc_generation_number[0]++;
4397 #if MAX_SAVE_STACK > 0
4399 /* Save a copy of the contents of the stack, for debugging. */
4402 /* Static buffer in which we save a copy of the C stack at each GC. */
4403 static char *stack_copy;
4404 static size_t stack_copy_size;
4406 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
4407 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
4408 if (stack_size < MAX_SAVE_STACK)
4410 if (stack_copy_size < stack_size)
4412 stack_copy = (char *) xrealloc (stack_copy, stack_size);
4413 stack_copy_size = stack_size;
4417 stack_diff > 0 ? stack_bottom : &stack_top_variable,
4421 #endif /* MAX_SAVE_STACK > 0 */
4423 /* Do some totally ad-hoc resource clearing. */
4424 /* #### generalize this? */
4425 clear_event_resource ();
4426 cleanup_specifiers ();
4428 /* Mark all the special slots that serve as the roots of accessibility. */
4432 for (i = 0; i < staticidx; i++)
4433 mark_object (*(staticvec[i]));
4439 for (tail = gcprolist; tail; tail = tail->next)
4440 for (i = 0; i < tail->nvars; i++)
4441 mark_object (tail->var[i]);
4445 struct specbinding *bind;
4446 for (bind = specpdl; bind != specpdl_ptr; bind++)
4448 mark_object (bind->symbol);
4449 mark_object (bind->old_value);
4454 struct catchtag *catch;
4455 for (catch = catchlist; catch; catch = catch->next)
4457 mark_object (catch->tag);
4458 mark_object (catch->val);
4463 struct backtrace *backlist;
4464 for (backlist = backtrace_list; backlist; backlist = backlist->next)
4466 int nargs = backlist->nargs;
4469 mark_object (*backlist->function);
4470 if (nargs == UNEVALLED || nargs == MANY)
4471 mark_object (backlist->args[0]);
4473 for (i = 0; i < nargs; i++)
4474 mark_object (backlist->args[i]);
4478 mark_redisplay (mark_object);
4479 mark_profiling_info (mark_object);
4481 /* OK, now do the after-mark stuff. This is for things that
4482 are only marked when something else is marked (e.g. weak hash tables).
4483 There may be complex dependencies between such objects -- e.g.
4484 a weak hash table might be unmarked, but after processing a later
4485 weak hash table, the former one might get marked. So we have to
4486 iterate until nothing more gets marked. */
4488 while (finish_marking_weak_hash_tables (marked_p, mark_object) > 0 ||
4489 finish_marking_weak_lists (marked_p, mark_object) > 0)
4492 /* And prune (this needs to be called after everything else has been
4493 marked and before we do any sweeping). */
4494 /* #### this is somewhat ad-hoc and should probably be an object
4496 prune_weak_hash_tables (marked_p);
4497 prune_weak_lists (marked_p);
4498 prune_specifiers (marked_p);
4499 prune_syntax_tables (marked_p);
4503 consing_since_gc = 0;
4504 #ifndef DEBUG_XEMACS
4505 /* Allow you to set it really fucking low if you really want ... */
4506 if (gc_cons_threshold < 10000)
4507 gc_cons_threshold = 10000;
4512 /******* End of garbage collection ********/
4514 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
4516 /* Now remove the GC cursor/message */
4517 if (!noninteractive)
4520 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
4521 else if (!FRAME_STREAM_P (f))
4523 char *msg = (STRINGP (Vgc_message)
4524 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
4527 /* Show "...done" only if the echo area would otherwise be empty. */
4528 if (NILP (clear_echo_area (selected_frame (),
4529 Qgarbage_collecting, 0)))
4531 Lisp_Object args[2], whole_msg;
4532 args[0] = build_string (msg ? msg :
4533 GETTEXT ((CONST char *)
4534 gc_default_message));
4535 args[1] = build_string ("... done");
4536 whole_msg = Fconcat (2, args);
4537 echo_area_message (selected_frame (), (Bufbyte *) 0,
4539 Qgarbage_collecting);
4544 /* now stop inhibiting GC */
4545 unbind_to (speccount, Qnil);
4547 if (!breathing_space)
4549 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
4556 /* Debugging aids. */
4559 gc_plist_hack (CONST char *name, int value, Lisp_Object tail)
4561 /* C doesn't have local functions (or closures, or GC, or readable syntax,
4562 or portable numeric datatypes, or bit-vectors, or characters, or
4563 arrays, or exceptions, or ...) */
4564 return cons3 (intern (name), make_int (value), tail);
4567 #define HACK_O_MATIC(type, name, pl) do { \
4569 struct type##_block *x = current_##type##_block; \
4570 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
4571 (pl) = gc_plist_hack ((name), s, (pl)); \
4574 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
4575 Reclaim storage for Lisp objects no longer needed.
4576 Return info on amount of space in use:
4577 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4578 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4580 where `PLIST' is a list of alternating keyword/value pairs providing
4581 more detailed information.
4582 Garbage collection happens automatically if you cons more than
4583 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4587 Lisp_Object pl = Qnil;
4589 #ifdef LRECORD_VECTOR
4590 int gc_count_vector_total_size = 0;
4593 if (purify_flag && pure_lossage)
4596 garbage_collect_1 ();
4598 for (i = 0; i < last_lrecord_type_index_assigned; i++)
4600 if (lcrecord_stats[i].bytes_in_use != 0
4601 || lcrecord_stats[i].bytes_freed != 0
4602 || lcrecord_stats[i].instances_on_free_list != 0)
4605 CONST char *name = lrecord_implementations_table[i]->name;
4606 int len = strlen (name);
4607 #ifdef LRECORD_VECTOR
4608 /* save this for the FSFmacs-compatible part of the summary */
4609 if (i == *lrecord_vector[0].lrecord_type_index)
4610 gc_count_vector_total_size =
4611 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
4613 sprintf (buf, "%s-storage", name);
4614 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
4615 /* Okay, simple pluralization check for `symbol-value-varalias' */
4616 if (name[len-1] == 's')
4617 sprintf (buf, "%ses-freed", name);
4619 sprintf (buf, "%ss-freed", name);
4620 if (lcrecord_stats[i].instances_freed != 0)
4621 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
4622 if (name[len-1] == 's')
4623 sprintf (buf, "%ses-on-free-list", name);
4625 sprintf (buf, "%ss-on-free-list", name);
4626 if (lcrecord_stats[i].instances_on_free_list != 0)
4627 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
4629 if (name[len-1] == 's')
4630 sprintf (buf, "%ses-used", name);
4632 sprintf (buf, "%ss-used", name);
4633 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
4637 HACK_O_MATIC (extent, "extent-storage", pl);
4638 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
4639 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
4640 HACK_O_MATIC (event, "event-storage", pl);
4641 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
4642 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
4643 HACK_O_MATIC (marker, "marker-storage", pl);
4644 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
4645 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
4646 #ifdef LISP_FLOAT_TYPE
4647 HACK_O_MATIC (float, "float-storage", pl);
4648 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
4649 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
4650 #endif /* LISP_FLOAT_TYPE */
4651 HACK_O_MATIC (string, "string-header-storage", pl);
4652 pl = gc_plist_hack ("long-strings-total-length",
4653 gc_count_string_total_size
4654 - gc_count_short_string_total_size, pl);
4655 HACK_O_MATIC (string_chars, "short-string-storage", pl);
4656 pl = gc_plist_hack ("short-strings-total-length",
4657 gc_count_short_string_total_size, pl);
4658 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
4659 pl = gc_plist_hack ("long-strings-used",
4660 gc_count_num_string_in_use
4661 - gc_count_num_short_string_in_use, pl);
4662 pl = gc_plist_hack ("short-strings-used",
4663 gc_count_num_short_string_in_use, pl);
4665 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
4666 pl = gc_plist_hack ("compiled-functions-free",
4667 gc_count_num_compiled_function_freelist, pl);
4668 pl = gc_plist_hack ("compiled-functions-used",
4669 gc_count_num_compiled_function_in_use, pl);
4671 #ifndef LRECORD_VECTOR
4672 pl = gc_plist_hack ("vector-storage", gc_count_vector_storage, pl);
4673 pl = gc_plist_hack ("vectors-total-length",
4674 gc_count_vector_total_size, pl);
4675 pl = gc_plist_hack ("vectors-used", gc_count_num_vector_used, pl);
4678 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
4679 pl = gc_plist_hack ("bit-vectors-total-length",
4680 gc_count_bit_vector_total_size, pl);
4681 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
4683 HACK_O_MATIC (symbol, "symbol-storage", pl);
4684 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
4685 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
4687 HACK_O_MATIC (cons, "cons-storage", pl);
4688 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
4689 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
4691 /* The things we do for backwards-compatibility */
4693 list6 (Fcons (make_int (gc_count_num_cons_in_use),
4694 make_int (gc_count_num_cons_freelist)),
4695 Fcons (make_int (gc_count_num_symbol_in_use),
4696 make_int (gc_count_num_symbol_freelist)),
4697 Fcons (make_int (gc_count_num_marker_in_use),
4698 make_int (gc_count_num_marker_freelist)),
4699 make_int (gc_count_string_total_size),
4700 make_int (gc_count_vector_total_size),
4705 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
4706 Return the number of bytes consed since the last garbage collection.
4707 \"Consed\" is a misnomer in that this actually counts allocation
4708 of all different kinds of objects, not just conses.
4710 If this value exceeds `gc-cons-threshold', a garbage collection happens.
4714 return make_int (consing_since_gc);
4717 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
4718 Return the address of the last byte Emacs has allocated, divided by 1024.
4719 This may be helpful in debugging Emacs's memory usage.
4720 The value is divided by 1024 to make sure it will fit in a lisp integer.
4724 return make_int ((EMACS_INT) sbrk (0) / 1024);
4730 object_dead_p (Lisp_Object obj)
4732 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
4733 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
4734 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
4735 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
4736 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
4737 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
4738 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
4741 #ifdef MEMORY_USAGE_STATS
4743 /* Attempt to determine the actual amount of space that is used for
4744 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
4746 It seems that the following holds:
4748 1. When using the old allocator (malloc.c):
4750 -- blocks are always allocated in chunks of powers of two. For
4751 each block, there is an overhead of 8 bytes if rcheck is not
4752 defined, 20 bytes if it is defined. In other words, a
4753 one-byte allocation needs 8 bytes of overhead for a total of
4754 9 bytes, and needs to have 16 bytes of memory chunked out for
4757 2. When using the new allocator (gmalloc.c):
4759 -- blocks are always allocated in chunks of powers of two up
4760 to 4096 bytes. Larger blocks are allocated in chunks of
4761 an integral multiple of 4096 bytes. The minimum block
4762 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
4763 is defined. There is no per-block overhead, but there
4764 is an overhead of 3*sizeof (size_t) for each 4096 bytes
4767 3. When using the system malloc, anything goes, but they are
4768 generally slower and more space-efficient than the GNU
4769 allocators. One possibly reasonable assumption to make
4770 for want of better data is that sizeof (void *), or maybe
4771 2 * sizeof (void *), is required as overhead and that
4772 blocks are allocated in the minimum required size except
4773 that some minimum block size is imposed (e.g. 16 bytes). */
4776 malloced_storage_size (void *ptr, size_t claimed_size,
4777 struct overhead_stats *stats)
4779 size_t orig_claimed_size = claimed_size;
4783 if (claimed_size < 2 * sizeof (void *))
4784 claimed_size = 2 * sizeof (void *);
4785 # ifdef SUNOS_LOCALTIME_BUG
4786 if (claimed_size < 16)
4789 if (claimed_size < 4096)
4793 /* compute the log base two, more or less, then use it to compute
4794 the block size needed. */
4796 /* It's big, it's heavy, it's wood! */
4797 while ((claimed_size /= 2) != 0)
4800 /* It's better than bad, it's good! */
4806 /* We have to come up with some average about the amount of
4808 if ((size_t) (rand () & 4095) < claimed_size)
4809 claimed_size += 3 * sizeof (void *);
4813 claimed_size += 4095;
4814 claimed_size &= ~4095;
4815 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
4818 #elif defined (SYSTEM_MALLOC)
4820 if (claimed_size < 16)
4822 claimed_size += 2 * sizeof (void *);
4824 #else /* old GNU allocator */
4826 # ifdef rcheck /* #### may not be defined here */
4834 /* compute the log base two, more or less, then use it to compute
4835 the block size needed. */
4837 /* It's big, it's heavy, it's wood! */
4838 while ((claimed_size /= 2) != 0)
4841 /* It's better than bad, it's good! */
4849 #endif /* old GNU allocator */
4853 stats->was_requested += orig_claimed_size;
4854 stats->malloc_overhead += claimed_size - orig_claimed_size;
4856 return claimed_size;
4860 fixed_type_block_overhead (size_t size)
4862 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
4863 size_t overhead = 0;
4864 size_t storage_size = malloced_storage_size (0, per_block, 0);
4865 while (size >= per_block)
4868 overhead += sizeof (void *) + per_block - storage_size;
4870 if (rand () % per_block < size)
4871 overhead += sizeof (void *) + per_block - storage_size;
4875 #endif /* MEMORY_USAGE_STATS */
4878 /* Initialization */
4880 init_alloc_once_early (void)
4884 last_lrecord_type_index_assigned = -1;
4885 for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
4887 lrecord_implementations_table[iii] = 0;
4890 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
4892 * If USE_INDEXED_LRECORD_IMPLEMENTATION is defined, all the staticly
4893 * defined subr lrecords were initialized with lheader->type == 0.
4894 * See subr_lheader_initializer in lisp.h. Force type index 0 to be
4895 * assigned to lrecord_subr so that those predefined indexes match
4898 lrecord_type_index (lrecord_subr);
4899 assert (*(lrecord_subr[0].lrecord_type_index) == 0);
4901 * The same is true for symbol_value_forward objects, except the
4904 lrecord_type_index (lrecord_symbol_value_forward);
4905 assert (*(lrecord_symbol_value_forward[0].lrecord_type_index) == 1);
4906 #endif /* USE_INDEXED_LRECORD_IMPLEMENTATION */
4908 symbols_initialized = 0;
4910 gc_generation_number[0] = 0;
4911 /* purify_flag 1 is correct even if CANNOT_DUMP.
4912 * loadup.el will set to nil at end. */
4914 pure_bytes_used = 0;
4916 breathing_space = 0;
4917 #ifndef LRECORD_VECTOR
4918 XSETINT (all_vectors, 0); /* Qzero may not be set yet. */
4920 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
4921 XSETINT (Vgc_message, 0);
4923 ignore_malloc_warnings = 1;
4924 #ifdef DOUG_LEA_MALLOC
4925 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
4926 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
4927 #if 0 /* Moved to emacs.c */
4928 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
4931 init_string_alloc ();
4932 init_string_chars_alloc ();
4934 init_symbol_alloc ();
4935 init_compiled_function_alloc ();
4936 #ifdef LISP_FLOAT_TYPE
4937 init_float_alloc ();
4938 #endif /* LISP_FLOAT_TYPE */
4939 init_marker_alloc ();
4940 init_extent_alloc ();
4941 init_event_alloc ();
4943 ignore_malloc_warnings = 0;
4945 consing_since_gc = 0;
4947 gc_cons_threshold = 500000; /* XEmacs change */
4949 gc_cons_threshold = 15000; /* debugging */
4951 #ifdef VIRT_ADDR_VARIES
4952 malloc_sbrk_unused = 1<<22; /* A large number */
4953 malloc_sbrk_used = 100000; /* as reasonable as any number */
4954 #endif /* VIRT_ADDR_VARIES */
4955 lrecord_uid_counter = 259;
4956 debug_string_purity = 0;
4959 gc_currently_forbidden = 0;
4960 gc_hooks_inhibited = 0;
4962 #ifdef ERROR_CHECK_TYPECHECK
4963 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4966 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
4968 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4970 #endif /* ERROR_CHECK_TYPECHECK */
4980 syms_of_alloc (void)
4982 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
4983 defsymbol (&Qpost_gc_hook, "post-gc-hook");
4984 defsymbol (&Qgarbage_collecting, "garbage-collecting");
4989 DEFSUBR (Fbit_vector);
4990 DEFSUBR (Fmake_byte_code);
4991 DEFSUBR (Fmake_list);
4992 DEFSUBR (Fmake_vector);
4993 DEFSUBR (Fmake_bit_vector);
4994 DEFSUBR (Fmake_string);
4996 DEFSUBR (Fmake_symbol);
4997 DEFSUBR (Fmake_marker);
4998 DEFSUBR (Fpurecopy);
4999 DEFSUBR (Fgarbage_collect);
5000 DEFSUBR (Fmemory_limit);
5001 DEFSUBR (Fconsing_since_gc);
5005 vars_of_alloc (void)
5007 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
5008 *Number of bytes of consing between garbage collections.
5009 \"Consing\" is a misnomer in that this actually counts allocation
5010 of all different kinds of objects, not just conses.
5011 Garbage collection can happen automatically once this many bytes have been
5012 allocated since the last garbage collection. All data types count.
5014 Garbage collection happens automatically when `eval' or `funcall' are
5015 called. (Note that `funcall' is called implicitly as part of evaluation.)
5016 By binding this temporarily to a large number, you can effectively
5017 prevent garbage collection during a part of the program.
5019 See also `consing-since-gc'.
5022 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
5023 Number of bytes of sharable Lisp data allocated so far.
5027 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
5028 Number of bytes of unshared memory allocated in this session.
5031 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
5032 Number of bytes of unshared memory remaining available in this session.
5037 DEFVAR_INT ("debug-allocation", &debug_allocation /*
5038 If non-zero, print out information to stderr about all objects allocated.
5039 See also `debug-allocation-backtrace-length'.
5041 debug_allocation = 0;
5043 DEFVAR_INT ("debug-allocation-backtrace-length",
5044 &debug_allocation_backtrace_length /*
5045 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
5047 debug_allocation_backtrace_length = 2;
5050 DEFVAR_BOOL ("purify-flag", &purify_flag /*
5051 Non-nil means loading Lisp code in order to dump an executable.
5052 This means that certain objects should be allocated in shared (pure) space.
5055 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
5056 Function or functions to be run just before 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 Vpre_gc_hook = Qnil;
5063 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
5064 Function or functions to be run just after each garbage collection.
5065 Interrupts, garbage collection, and errors are inhibited while this hook
5066 runs, so be extremely careful in what you add here. In particular, avoid
5067 consing, and do not interact with the user.
5069 Vpost_gc_hook = Qnil;
5071 DEFVAR_LISP ("gc-message", &Vgc_message /*
5072 String to print to indicate that a garbage collection is in progress.
5073 This is printed in the echo area. If the selected frame is on a
5074 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
5075 image instance) in the domain of the selected frame, the mouse pointer
5076 will change instead of this message being printed.
5078 Vgc_message = make_pure_string ((CONST Bufbyte *) gc_default_message,
5079 countof (gc_default_message) - 1,
5082 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
5083 Pointer glyph used to indicate that a garbage collection is in progress.
5084 If the selected window is on a window system and this glyph specifies a
5085 value (i.e. a pointer image instance) in the domain of the selected
5086 window, the pointer will be changed as specified during garbage collection.
5087 Otherwise, a message will be printed in the echo area, as controlled
5093 complex_vars_of_alloc (void)
5095 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);