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"
54 #include "redisplay.h"
55 #include "specifier.h"
59 #ifdef DOUG_LEA_MALLOC
63 EXFUN (Fgarbage_collect, 0);
65 /* #define GDB_SUCKS */
67 #if 0 /* this is _way_ too slow to be part of the standard debug options */
68 #if defined(DEBUG_XEMACS) && defined(MULE)
69 #define VERIFY_STRING_CHARS_INTEGRITY
73 /* Define this to see where all that space is going... */
74 /* But the length of the printout is obnoxious, so limit it to testers */
75 /* If somebody wants to see this they can ask for it.
81 /* Define this to use malloc/free with no freelist for all datatypes,
82 the hope being that some debugging tools may help detect
83 freed memory references */
84 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
86 #define ALLOC_NO_POOLS
94 int debug_allocation_backtrace_length;
97 /* Number of bytes of consing done since the last gc */
98 EMACS_INT consing_since_gc;
100 extern void cadillac_record_backtrace ();
101 #define INCREMENT_CONS_COUNTER_1(size) \
103 EMACS_INT __sz__ = ((EMACS_INT) (size)); \
104 consing_since_gc += __sz__; \
105 cadillac_record_backtrace (2, __sz__); \
108 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
109 #endif /* EMACS_BTL */
111 #define debug_allocation_backtrace() \
113 if (debug_allocation_backtrace_length > 0) \
114 debug_short_backtrace (debug_allocation_backtrace_length); \
118 #define INCREMENT_CONS_COUNTER(foosize, type) \
120 if (debug_allocation) \
122 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
123 debug_allocation_backtrace (); \
125 INCREMENT_CONS_COUNTER_1 (foosize); \
127 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
129 if (debug_allocation > 1) \
131 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
132 debug_allocation_backtrace (); \
134 INCREMENT_CONS_COUNTER_1 (foosize); \
137 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
138 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
139 INCREMENT_CONS_COUNTER_1 (size)
142 #define DECREMENT_CONS_COUNTER(size) \
144 EMACS_INT __sz__ = ((EMACS_INT) (size)); \
145 if (consing_since_gc >= __sz__) \
146 consing_since_gc -= __sz__; \
148 consing_since_gc = 0; \
151 /* Number of bytes of consing since gc before another gc should be done. */
152 EMACS_INT gc_cons_threshold;
154 /* Nonzero during gc */
157 /* Number of times GC has happened at this level or below.
158 * Level 0 is most volatile, contrary to usual convention.
159 * (Of course, there's only one level at present) */
160 EMACS_INT gc_generation_number[1];
162 /* This is just for use by the printer, to allow things to print uniquely */
163 static int lrecord_uid_counter;
165 /* Nonzero when calling certain hooks or doing other things where
167 int gc_currently_forbidden;
170 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
171 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
173 /* "Garbage collecting" */
174 Lisp_Object Vgc_message;
175 Lisp_Object Vgc_pointer_glyph;
176 static CONST char gc_default_message[] = "Garbage collecting";
177 Lisp_Object Qgarbage_collecting;
179 #ifndef VIRT_ADDR_VARIES
181 #endif /* VIRT_ADDR_VARIES */
182 EMACS_INT malloc_sbrk_used;
184 #ifndef VIRT_ADDR_VARIES
186 #endif /* VIRT_ADDR_VARIES */
187 EMACS_INT malloc_sbrk_unused;
189 /* Non-zero means defun should do purecopy on the function definition */
193 extern void sheap_adjust_h();
196 #define PUREBEG ((char *) pure)
198 #if 0 /* This is breathing_space in XEmacs */
199 /* Points to memory space allocated as "spare",
200 to be freed if we run out of memory. */
201 static char *spare_memory;
203 /* Amount of spare memory to keep in reserve. */
204 #define SPARE_MEMORY (1 << 14)
207 /* Index in pure at which next pure object will be allocated. */
208 static size_t pure_bytes_used;
210 #define PURIFIED(ptr) \
211 ((char *) (ptr) >= PUREBEG && \
212 (char *) (ptr) < PUREBEG + get_PURESIZE())
214 /* Non-zero if pure_bytes_used > get_PURESIZE(); accounts for excess purespace needs. */
215 static size_t pure_lossage;
217 #ifdef ERROR_CHECK_TYPECHECK
219 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
224 purified (Lisp_Object obj)
226 return POINTER_TYPE_P (XGCTYPE (obj)) && PURIFIED (XPNTR (obj));
230 purespace_usage (void)
232 return pure_bytes_used;
236 check_purespace (size_t size)
240 pure_lossage += size;
243 else if (pure_bytes_used + size > get_PURESIZE())
245 /* This can cause recursive bad behavior, we'll yell at the end */
246 /* when we're done. */
247 /* message ("\nERROR: Pure Lisp storage exhausted!\n"); */
259 #define bump_purestat(p,b) DO_NOTHING
263 static int purecopying_for_bytecode;
265 static size_t pure_sizeof (Lisp_Object /*, int recurse */);
267 /* Keep statistics on how much of what is in purespace */
268 static struct purestat
274 purestat_cons = {0, 0, "cons cells"},
275 purestat_float = {0, 0, "float objects"},
276 purestat_string_pname = {0, 0, "symbol-name strings"},
277 purestat_bytecode = {0, 0, "compiled-function objects"},
278 purestat_string_bytecodes = {0, 0, "byte-code strings"},
279 purestat_vector_bytecode_constants = {0, 0, "byte-constant vectors"},
280 purestat_string_interactive = {0, 0, "interactive strings"},
282 purestat_string_domain = {0, 0, "domain strings"},
284 purestat_string_documentation = {0, 0, "documentation strings"},
285 purestat_string_other_function = {0, 0, "other function strings"},
286 purestat_vector_other = {0, 0, "other vectors"},
287 purestat_string_other = {0, 0, "other strings"},
288 purestat_string_all = {0, 0, "all strings"},
289 purestat_vector_all = {0, 0, "all vectors"};
291 static struct purestat *purestats[] =
295 &purestat_string_pname,
297 &purestat_string_bytecodes,
298 &purestat_vector_bytecode_constants,
299 &purestat_string_interactive,
301 &purestat_string_domain,
303 &purestat_string_documentation,
304 &purestat_string_other_function,
305 &purestat_vector_other,
306 &purestat_string_other,
308 &purestat_string_all,
313 bump_purestat (struct purestat *purestat, size_t nbytes)
315 if (pure_lossage) return;
316 purestat->nobjects += 1;
317 purestat->nbytes += nbytes;
319 #endif /* PURESTAT */
322 /* Maximum amount of C stack to save when a GC happens. */
324 #ifndef MAX_SAVE_STACK
325 #define MAX_SAVE_STACK 16000
328 /* Non-zero means ignore malloc warnings. Set during initialization. */
329 int ignore_malloc_warnings;
332 static void *breathing_space;
335 release_breathing_space (void)
339 void *tmp = breathing_space;
345 /* malloc calls this if it finds we are near exhausting storage */
347 malloc_warning (CONST char *str)
349 if (ignore_malloc_warnings)
355 "Killing some buffers may delay running out of memory.\n"
356 "However, certainly by the time you receive the 95%% warning,\n"
357 "you should clean up, kill this Emacs, and start a new one.",
361 /* Called if malloc returns zero */
365 /* Force a GC next time eval is called.
366 It's better to loop garbage-collecting (we might reclaim enough
367 to win) than to loop beeping and barfing "Memory exhausted"
369 consing_since_gc = gc_cons_threshold + 1;
370 release_breathing_space ();
372 /* Flush some histories which might conceivably contain garbalogical
374 if (!NILP (Fboundp (Qvalues)))
375 Fset (Qvalues, Qnil);
376 Vcommand_history = Qnil;
378 error ("Memory exhausted");
381 /* like malloc and realloc but check for no memory left, and block input. */
388 xmalloc (size_t size)
390 void *val = (void *) malloc (size);
392 if (!val && (size != 0)) memory_full ();
397 xmalloc_and_zero (size_t size)
399 void *val = xmalloc (size);
400 memset (val, 0, size);
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 = (void *) (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 if (size <= 0) abort ();
521 if (implementation->static_size == 0)
523 if (!implementation->size_in_bytes_method)
526 else if (implementation->static_size != size)
529 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
530 set_lheader_implementation(&(lcheader->lheader), implementation);
531 lcheader->next = all_lcrecords;
532 #if 1 /* mly prefers to see small ID numbers */
533 lcheader->uid = lrecord_uid_counter++;
534 #else /* jwz prefers to see real addrs */
535 lcheader->uid = (int) &lcheader;
538 all_lcrecords = lcheader;
539 INCREMENT_CONS_COUNTER (size, implementation->name);
543 #if 0 /* Presently unused */
544 /* Very, very poor man's EGC?
545 * This may be slow and thrash pages all over the place.
546 * Only call it if you really feel you must (and if the
547 * lrecord was fairly recently allocated).
548 * Otherwise, just let the GC do its job -- that's what it's there for
551 free_lcrecord (struct lcrecord_header *lcrecord)
553 if (all_lcrecords == lcrecord)
555 all_lcrecords = lcrecord->next;
559 struct lrecord_header *header = all_lcrecords;
562 struct lrecord_header *next = header->next;
563 if (next == lcrecord)
565 header->next = lrecord->next;
574 if (lrecord->implementation->finalizer)
575 ((lrecord->implementation->finalizer) (lrecord, 0));
583 disksave_object_finalization_1 (void)
585 struct lcrecord_header *header;
587 for (header = all_lcrecords; header; header = header->next)
589 if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
591 ((LHEADER_IMPLEMENTATION(&header->lheader)->finalizer)
597 /* This must not be called -- it just serves as for EQ test
598 * If lheader->implementation->finalizer is this_marks_a_marked_record,
599 * then lrecord has been marked by the GC sweeper
600 * header->implementation is put back to its correct value by
603 this_marks_a_marked_record (void *dummy0, int dummy1)
608 /* Semi-kludge -- lrecord_symbol_value_forward objects get stuck
609 in CONST space and you get SEGV's if you attempt to mark them.
610 This sits in lheader->implementation->marker. */
613 this_one_is_unmarkable (Lisp_Object obj, void (*markobj) (Lisp_Object))
619 /* XGCTYPE for records */
621 gc_record_type_p (Lisp_Object frob, CONST struct lrecord_implementation *type)
623 CONST struct lrecord_implementation *imp;
625 if (XGCTYPE (frob) != Lisp_Type_Record)
628 imp = XRECORD_LHEADER_IMPLEMENTATION (frob);
629 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
632 return imp == type || imp == type + 1;
637 /**********************************************************************/
638 /* Debugger support */
639 /**********************************************************************/
640 /* Give gdb/dbx enough information to decode Lisp Objects.
641 We make sure certain symbols are defined, so gdb doesn't complain
642 about expressions in src/gdbinit. Values are randomly chosen.
643 See src/gdbinit or src/dbxrc to see how this is used. */
647 #ifdef USE_MINIMAL_TAGBITS
648 dbg_valmask = (EMACS_INT) (((1UL << VALBITS) - 1) << GCBITS),
649 dbg_typemask = (EMACS_INT) ((1UL << GCTYPEBITS) - 1),
650 dbg_USE_MINIMAL_TAGBITS = 1,
651 dbg_Lisp_Type_Int = 100,
652 #else /* ! USE_MIMIMAL_TAGBITS */
653 dbg_valmask = (EMACS_INT) ((1UL << VALBITS) - 1),
654 dbg_typemask = (EMACS_INT) (((1UL << GCTYPEBITS) - 1) << (VALBITS + GCMARKBITS)),
655 dbg_USE_MINIMAL_TAGBITS = 0,
656 dbg_Lisp_Type_Int = Lisp_Type_Int,
657 #endif /* ! USE_MIMIMAL_TAGBITS */
658 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
659 dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1,
661 dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0,
663 dbg_Lisp_Type_Char = Lisp_Type_Char,
664 dbg_Lisp_Type_Record = Lisp_Type_Record,
666 dbg_Lisp_Type_Cons = 101,
668 dbg_Lisp_Type_Cons = Lisp_Type_Cons,
671 #ifdef LRECORD_STRING
672 dbg_Lisp_Type_String = 102,
674 dbg_Lisp_Type_String = Lisp_Type_String,
675 lrecord_string = 202,
677 #ifdef LRECORD_VECTOR
678 dbg_Lisp_Type_Vector = 103,
680 dbg_Lisp_Type_Vector = Lisp_Type_Vector,
681 lrecord_vector = 203,
683 #ifdef LRECORD_SYMBOL
684 dbg_Lisp_Type_Symbol = 104,
686 dbg_Lisp_Type_Symbol = Lisp_Type_Symbol,
687 lrecord_symbol = 204,
690 lrecord_char_table_entry = 205,
691 lrecord_charset = 206,
692 lrecord_coding_system = 207,
694 #ifndef HAVE_TOOLBARS
695 lrecord_toolbar_button = 208,
697 #ifndef HAVE_TOOLTALK
698 lrecord_tooltalk_message = 210,
699 lrecord_tooltalk_pattern = 211,
701 #ifndef HAVE_DATABASE
702 lrecord_database = 212,
704 dbg_valbits = VALBITS,
705 dbg_gctypebits = GCTYPEBITS
706 /* If we don't have an actual object of this enum, pgcc (and perhaps
707 other compilers) might optimize away the entire type declaration :-( */
711 /**********************************************************************/
712 /* Fixed-size type macros */
713 /**********************************************************************/
715 /* For fixed-size types that are commonly used, we malloc() large blocks
716 of memory at a time and subdivide them into chunks of the correct
717 size for an object of that type. This is more efficient than
718 malloc()ing each object separately because we save on malloc() time
719 and overhead due to the fewer number of malloc()ed blocks, and
720 also because we don't need any extra pointers within each object
721 to keep them threaded together for GC purposes. For less common
722 (and frequently large-size) types, we use lcrecords, which are
723 malloc()ed individually and chained together through a pointer
724 in the lcrecord header. lcrecords do not need to be fixed-size
725 (i.e. two objects of the same type need not have the same size;
726 however, the size of a particular object cannot vary dynamically).
727 It is also much easier to create a new lcrecord type because no
728 additional code needs to be added to alloc.c. Finally, lcrecords
729 may be more efficient when there are only a small number of them.
731 The types that are stored in these large blocks (or "frob blocks")
732 are cons, float, compiled-function, symbol, marker, extent, event,
735 Note that strings are special in that they are actually stored in
736 two parts: a structure containing information about the string, and
737 the actual data associated with the string. The former structure
738 (a struct Lisp_String) is a fixed-size structure and is managed the
739 same way as all the other such types. This structure contains a
740 pointer to the actual string data, which is stored in structures of
741 type struct string_chars_block. Each string_chars_block consists
742 of a pointer to a struct Lisp_String, followed by the data for that
743 string, followed by another pointer to a struct Lisp_String,
744 followed by the data for that string, etc. At GC time, the data in
745 these blocks is compacted by searching sequentially through all the
746 blocks and compressing out any holes created by unmarked strings.
747 Strings that are more than a certain size (bigger than the size of
748 a string_chars_block, although something like half as big might
749 make more sense) are malloc()ed separately and not stored in
750 string_chars_blocks. Furthermore, no one string stretches across
751 two string_chars_blocks.
753 Vectors are each malloc()ed separately, similar to lcrecords.
755 In the following discussion, we use conses, but it applies equally
756 well to the other fixed-size types.
758 We store cons cells inside of cons_blocks, allocating a new
759 cons_block with malloc() whenever necessary. Cons cells reclaimed
760 by GC are put on a free list to be reallocated before allocating
761 any new cons cells from the latest cons_block. Each cons_block is
762 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
763 the versions in malloc.c and gmalloc.c) really allocates in units
764 of powers of two and uses 4 bytes for its own overhead.
766 What GC actually does is to search through all the cons_blocks,
767 from the most recently allocated to the oldest, and put all
768 cons cells that are not marked (whether or not they're already
769 free) on a cons_free_list. The cons_free_list is a stack, and
770 so the cons cells in the oldest-allocated cons_block end up
771 at the head of the stack and are the first to be reallocated.
772 If any cons_block is entirely free, it is freed with free()
773 and its cons cells removed from the cons_free_list. Because
774 the cons_free_list ends up basically in memory order, we have
775 a high locality of reference (assuming a reasonable turnover
776 of allocating and freeing) and have a reasonable probability
777 of entirely freeing up cons_blocks that have been more recently
778 allocated. This stage is called the "sweep stage" of GC, and
779 is executed after the "mark stage", which involves starting
780 from all places that are known to point to in-use Lisp objects
781 (e.g. the obarray, where are all symbols are stored; the
782 current catches and condition-cases; the backtrace list of
783 currently executing functions; the gcpro list; etc.) and
784 recursively marking all objects that are accessible.
786 At the beginning of the sweep stage, the conses in the cons
787 blocks are in one of three states: in use and marked, in use
788 but not marked, and not in use (already freed). Any conses
789 that are marked have been marked in the mark stage just
790 executed, because as part of the sweep stage we unmark any
791 marked objects. The way we tell whether or not a cons cell
792 is in use is through the FREE_STRUCT_P macro. This basically
793 looks at the first 4 bytes (or however many bytes a pointer
794 fits in) to see if all the bits in those bytes are 1. The
795 resulting value (0xFFFFFFFF) is not a valid pointer and is
796 not a valid Lisp_Object. All current fixed-size types have
797 a pointer or Lisp_Object as their first element with the
798 exception of strings; they have a size value, which can
799 never be less than zero, and so 0xFFFFFFFF is invalid for
800 strings as well. Now assuming that a cons cell is in use,
801 the way we tell whether or not it is marked is to look at
802 the mark bit of its car (each Lisp_Object has one bit
803 reserved as a mark bit, in case it's needed). Note that
804 different types of objects use different fields to indicate
805 whether the object is marked, but the principle is the same.
807 Conses on the free_cons_list are threaded through a pointer
808 stored in the bytes directly after the bytes that are set
809 to 0xFFFFFFFF (we cannot overwrite these because the cons
810 is still in a cons_block and needs to remain marked as
811 not in use for the next time that GC happens). This
812 implies that all fixed-size types must be at least big
813 enough to store two pointers, which is indeed the case
814 for all current fixed-size types.
816 Some types of objects need additional "finalization" done
817 when an object is converted from in use to not in use;
818 this is the purpose of the ADDITIONAL_FREE_type macro.
819 For example, markers need to be removed from the chain
820 of markers that is kept in each buffer. This is because
821 markers in a buffer automatically disappear if the marker
822 is no longer referenced anywhere (the same does not
823 apply to extents, however).
825 WARNING: Things are in an extremely bizarre state when
826 the ADDITIONAL_FREE_type macros are called, so beware!
828 When ERROR_CHECK_GC is defined, we do things differently
829 so as to maximize our chances of catching places where
830 there is insufficient GCPROing. The thing we want to
831 avoid is having an object that we're using but didn't
832 GCPRO get freed by GC and then reallocated while we're
833 in the process of using it -- this will result in something
834 seemingly unrelated getting trashed, and is extremely
835 difficult to track down. If the object gets freed but
836 not reallocated, we can usually catch this because we
837 set all bytes of a freed object to 0xDEADBEEF. (The
838 first four bytes, however, are 0xFFFFFFFF, and the next
839 four are a pointer used to chain freed objects together;
840 we play some tricks with this pointer to make it more
841 bogus, so crashes are more likely to occur right away.)
843 We want freed objects to stay free as long as possible,
844 so instead of doing what we do above, we maintain the
845 free objects in a first-in first-out queue. We also
846 don't recompute the free list each GC, unlike above;
847 this ensures that the queue ordering is preserved.
848 [This means that we are likely to have worse locality
849 of reference, and that we can never free a frob block
850 once it's allocated. (Even if we know that all cells
851 in it are free, there's no easy way to remove all those
852 cells from the free list because the objects on the
853 free list are unlikely to be in memory order.)]
854 Furthermore, we never take objects off the free list
855 unless there's a large number (usually 1000, but
856 varies depending on type) of them already on the list.
857 This way, we ensure that an object that gets freed will
858 remain free for the next 1000 (or whatever) times that
859 an object of that type is allocated.
862 #ifndef MALLOC_OVERHEAD
864 #define MALLOC_OVERHEAD 0
865 #elif defined (rcheck)
866 #define MALLOC_OVERHEAD 20
868 #define MALLOC_OVERHEAD 8
870 #endif /* MALLOC_OVERHEAD */
872 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
873 /* If we released our reserve (due to running out of memory),
874 and we have a fair amount free once again,
875 try to set aside another reserve in case we run out once more.
877 This is called when a relocatable block is freed in ralloc.c. */
878 void refill_memory_reserve (void);
880 refill_memory_reserve ()
882 if (breathing_space == 0)
883 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
887 #ifdef ALLOC_NO_POOLS
888 # define TYPE_ALLOC_SIZE(type, structtype) 1
890 # define TYPE_ALLOC_SIZE(type, structtype) \
891 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
892 / sizeof (structtype))
893 #endif /* ALLOC_NO_POOLS */
895 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
897 struct type##_block \
899 struct type##_block *prev; \
900 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
903 static struct type##_block *current_##type##_block; \
904 static int current_##type##_block_index; \
906 static structtype *type##_free_list; \
907 static structtype *type##_free_list_tail; \
910 init_##type##_alloc (void) \
912 current_##type##_block = 0; \
913 current_##type##_block_index = countof (current_##type##_block->block); \
914 type##_free_list = 0; \
915 type##_free_list_tail = 0; \
918 static int gc_count_num_##type##_in_use, gc_count_num_##type##_freelist
920 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) \
922 if (current_##type##_block_index \
923 == countof (current_##type##_block->block)) \
925 struct type##_block *__new__ = (struct type##_block *) \
926 allocate_lisp_storage (sizeof (struct type##_block)); \
927 __new__->prev = current_##type##_block; \
928 current_##type##_block = __new__; \
929 current_##type##_block_index = 0; \
932 &(current_##type##_block->block[current_##type##_block_index++]); \
935 /* Allocate an instance of a type that is stored in blocks.
936 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
939 #ifdef ERROR_CHECK_GC
941 /* Note: if you get crashes in this function, suspect incorrect calls
942 to free_cons() and friends. This happened once because the cons
943 cell was not GC-protected and was getting collected before
944 free_cons() was called. */
946 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
949 if (gc_count_num_##type##_freelist > \
950 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
952 result = type##_free_list; \
953 /* Before actually using the chain pointer, we complement all its \
954 bits; see FREE_FIXED_TYPE(). */ \
956 (structtype *) ~(unsigned long) \
957 (* (structtype **) ((char *) result + sizeof (void *))); \
958 gc_count_num_##type##_freelist--; \
961 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
962 MARK_STRUCT_AS_NOT_FREE (result); \
965 #else /* !ERROR_CHECK_GC */
967 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
970 if (type##_free_list) \
972 result = type##_free_list; \
974 * (structtype **) ((char *) result + sizeof (void *)); \
977 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
978 MARK_STRUCT_AS_NOT_FREE (result); \
981 #endif /* !ERROR_CHECK_GC */
983 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
986 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
987 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
990 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
993 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
994 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
997 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
998 to a Lisp object and invalid as an actual Lisp_Object value. We have
999 to make sure that this value cannot be an integer in Lisp_Object form.
1000 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
1001 On a 32-bit system, the type bits will be non-zero, making the value
1002 be a pointer, and the pointer will be misaligned.
1004 Even if Emacs is run on some weirdo system that allows and allocates
1005 byte-aligned pointers, this pointer is at the very top of the address
1006 space and so it's almost inconceivable that it could ever be valid. */
1009 # define INVALID_POINTER_VALUE 0xFFFFFFFF
1011 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
1013 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
1015 You have some weird system and need to supply a reasonable value here.
1018 #define FREE_STRUCT_P(ptr) \
1019 (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
1020 #define MARK_STRUCT_AS_FREE(ptr) \
1021 (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
1022 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
1023 (* (void **) ptr = 0)
1025 #ifdef ERROR_CHECK_GC
1027 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
1028 do { if (type##_free_list_tail) \
1030 /* When we store the chain pointer, we complement all \
1031 its bits; this should significantly increase its \
1032 bogosity in case someone tries to use the value, and \
1033 should make us dump faster if someone stores something \
1034 over the pointer because when it gets un-complemented in \
1035 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
1036 extremely bogus. */ \
1038 ((char *) type##_free_list_tail + sizeof (void *)) = \
1039 (structtype *) ~(unsigned long) ptr; \
1042 type##_free_list = ptr; \
1043 type##_free_list_tail = ptr; \
1046 #else /* !ERROR_CHECK_GC */
1048 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
1049 do { * (structtype **) ((char *) ptr + sizeof (void *)) = \
1051 type##_free_list = ptr; \
1054 #endif /* !ERROR_CHECK_GC */
1056 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
1058 #define FREE_FIXED_TYPE(type, structtype, ptr) \
1059 do { structtype *_weird_ = (ptr); \
1060 ADDITIONAL_FREE_##type (_weird_); \
1061 deadbeef_memory (ptr, sizeof (structtype)); \
1062 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, ptr); \
1063 MARK_STRUCT_AS_FREE (_weird_); \
1066 /* Like FREE_FIXED_TYPE() but used when we are explicitly
1067 freeing a structure through free_cons(), free_marker(), etc.
1068 rather than through the normal process of sweeping.
1069 We attempt to undo the changes made to the allocation counters
1070 as a result of this structure being allocated. This is not
1071 completely necessary but helps keep things saner: e.g. this way,
1072 repeatedly allocating and freeing a cons will not result in
1073 the consing-since-gc counter advancing, which would cause a GC
1074 and somewhat defeat the purpose of explicitly freeing. */
1076 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
1077 do { FREE_FIXED_TYPE (type, structtype, ptr); \
1078 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
1079 gc_count_num_##type##_freelist++; \
1084 /**********************************************************************/
1085 /* Cons allocation */
1086 /**********************************************************************/
1088 DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons);
1089 /* conses are used and freed so often that we set this really high */
1090 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
1091 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
1095 mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object))
1097 if (NILP (XCDR (obj)))
1100 (markobj) (XCAR (obj));
1105 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
1107 while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1))
1111 if (! CONSP (ob1) || ! CONSP (ob2))
1112 return internal_equal (ob1, ob2, depth + 1);
1117 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
1118 mark_cons, print_cons, 0,
1121 * No `hash' method needed.
1122 * internal_hash knows how to
1127 #endif /* LRECORD_CONS */
1129 DEFUN ("cons", Fcons, 2, 2, 0, /*
1130 Create a new cons, give it CAR and CDR as components, and return it.
1134 /* This cannot GC. */
1136 struct Lisp_Cons *c;
1138 ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1140 set_lheader_implementation (&(c->lheader), lrecord_cons);
1148 /* This is identical to Fcons() but it used for conses that we're
1149 going to free later, and is useful when trying to track down
1152 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
1155 struct Lisp_Cons *c;
1157 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1159 set_lheader_implementation (&(c->lheader), lrecord_cons);
1167 DEFUN ("list", Flist, 0, MANY, 0, /*
1168 Return a newly created list with specified arguments as elements.
1169 Any number of arguments, even zero arguments, are allowed.
1171 (int nargs, Lisp_Object *args))
1173 Lisp_Object val = Qnil;
1174 Lisp_Object *argp = args + nargs;
1177 val = Fcons (*--argp, val);
1182 list1 (Lisp_Object obj0)
1184 /* This cannot GC. */
1185 return Fcons (obj0, Qnil);
1189 list2 (Lisp_Object obj0, Lisp_Object obj1)
1191 /* This cannot GC. */
1192 return Fcons (obj0, Fcons (obj1, Qnil));
1196 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1198 /* This cannot GC. */
1199 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1203 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1205 /* This cannot GC. */
1206 return Fcons (obj0, Fcons (obj1, obj2));
1210 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1212 return Fcons (Fcons (key, value), alist);
1216 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1218 /* This cannot GC. */
1219 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1223 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1226 /* This cannot GC. */
1227 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1231 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1232 Lisp_Object obj4, Lisp_Object obj5)
1234 /* This cannot GC. */
1235 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1238 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1239 Return a new list of length LENGTH, with each element being INIT.
1243 CHECK_NATNUM (length);
1246 Lisp_Object val = Qnil;
1247 int size = XINT (length);
1250 val = Fcons (init, val);
1256 /**********************************************************************/
1257 /* Float allocation */
1258 /**********************************************************************/
1260 #ifdef LISP_FLOAT_TYPE
1262 DECLARE_FIXED_TYPE_ALLOC (float, struct Lisp_Float);
1263 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1266 make_float (double float_value)
1269 struct Lisp_Float *f;
1271 ALLOCATE_FIXED_TYPE (float, struct Lisp_Float, f);
1272 set_lheader_implementation (&(f->lheader), lrecord_float);
1273 float_data (f) = float_value;
1278 #endif /* LISP_FLOAT_TYPE */
1281 /**********************************************************************/
1282 /* Vector allocation */
1283 /**********************************************************************/
1285 #ifdef LRECORD_VECTOR
1287 mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
1289 struct Lisp_Vector *ptr = XVECTOR (obj);
1290 int len = vector_length (ptr);
1293 for (i = 0; i < len - 1; i++)
1294 (markobj) (ptr->contents[i]);
1295 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1299 size_vector (CONST void *lheader)
1301 /* * -1 because struct Lisp_Vector includes 1 slot */
1302 return sizeof (struct Lisp_Vector) +
1303 ((((struct Lisp_Vector *) lheader)->size - 1) * sizeof (Lisp_Object));
1307 vector_equal (Lisp_Object o1, Lisp_Object o2, int depth)
1310 int len = XVECTOR_LENGTH (o1);
1311 if (len != XVECTOR_LENGTH (o2))
1313 for (indice = 0; indice < len; indice++)
1315 if (!internal_equal (XVECTOR_DATA (o1) [indice],
1316 XVECTOR_DATA (o2) [indice],
1323 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1324 mark_vector, print_vector, 0,
1327 * No `hash' method needed for
1328 * vectors. internal_hash
1329 * knows how to handle vectors.
1332 size_vector, struct Lisp_Vector);
1334 /* #### should allocate `small' vectors from a frob-block */
1335 static struct Lisp_Vector *
1336 make_vector_internal (size_t sizei)
1338 size_t sizem = (sizeof (struct Lisp_Vector)
1339 /* -1 because struct Lisp_Vector includes 1 slot */
1340 + (sizei - 1) * sizeof (Lisp_Object));
1341 struct Lisp_Vector *p =
1342 (struct Lisp_Vector *) alloc_lcrecord (sizem, lrecord_vector);
1348 #else /* ! LRECORD_VECTOR */
1350 static Lisp_Object all_vectors;
1352 /* #### should allocate `small' vectors from a frob-block */
1353 static struct Lisp_Vector *
1354 make_vector_internal (size_t sizei)
1356 size_t sizem = (sizeof (struct Lisp_Vector)
1357 /* -1 because struct Lisp_Vector includes 1 slot,
1358 * +1 to account for vector_next */
1359 + (sizei - 1 + 1) * sizeof (Lisp_Object));
1360 struct Lisp_Vector *p = (struct Lisp_Vector *) allocate_lisp_storage (sizem);
1362 INCREMENT_CONS_COUNTER (sizem, "vector");
1365 vector_next (p) = all_vectors;
1366 XSETVECTOR (all_vectors, p);
1370 #endif /* ! LRECORD_VECTOR */
1373 make_vector (EMACS_INT length, Lisp_Object init)
1377 struct Lisp_Vector *p;
1380 length = XINT (wrong_type_argument (Qnatnump, make_int (length)));
1382 p = make_vector_internal (length);
1383 XSETVECTOR (vector, p);
1386 /* Initialize big arrays full of 0's quickly, for what that's worth */
1388 char *travesty = (char *) &init;
1389 for (i = 1; i < sizeof (Lisp_Object); i++)
1391 if (travesty[i] != travesty[0])
1394 memset (vector_data (p), travesty[0], length * sizeof (Lisp_Object));
1399 for (elt = 0; elt < length; elt++)
1400 vector_data(p)[elt] = init;
1405 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1406 Return a new vector of length LENGTH, with each element being INIT.
1407 See also the function `vector'.
1411 CHECK_NATNUM (length);
1412 return make_vector (XINT (length), init);
1415 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1416 Return a newly created vector with specified arguments as elements.
1417 Any number of arguments, even zero arguments, are allowed.
1419 (int nargs, Lisp_Object *args))
1423 struct Lisp_Vector *p = make_vector_internal (nargs);
1425 for (elt = 0; elt < nargs; elt++)
1426 vector_data(p)[elt] = args[elt];
1428 XSETVECTOR (vector, p);
1433 vector1 (Lisp_Object obj0)
1435 return Fvector (1, &obj0);
1439 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1441 Lisp_Object args[2];
1444 return Fvector (2, args);
1448 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1450 Lisp_Object args[3];
1454 return Fvector (3, args);
1457 #if 0 /* currently unused */
1460 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1463 Lisp_Object args[4];
1468 return Fvector (4, args);
1472 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1473 Lisp_Object obj3, Lisp_Object obj4)
1475 Lisp_Object args[5];
1481 return Fvector (5, args);
1485 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1486 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1488 Lisp_Object args[6];
1495 return Fvector (6, args);
1499 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1500 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1503 Lisp_Object args[7];
1511 return Fvector (7, args);
1515 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1516 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1517 Lisp_Object obj6, Lisp_Object obj7)
1519 Lisp_Object args[8];
1528 return Fvector (8, args);
1532 /**********************************************************************/
1533 /* Bit Vector allocation */
1534 /**********************************************************************/
1536 static Lisp_Object all_bit_vectors;
1538 /* #### should allocate `small' bit vectors from a frob-block */
1539 static struct Lisp_Bit_Vector *
1540 make_bit_vector_internal (size_t sizei)
1542 size_t sizem = sizeof (struct Lisp_Bit_Vector) +
1543 /* -1 because struct Lisp_Bit_Vector includes 1 slot */
1544 sizeof (long) * (BIT_VECTOR_LONG_STORAGE (sizei) - 1);
1545 struct Lisp_Bit_Vector *p =
1546 (struct Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1547 set_lheader_implementation (&(p->lheader), lrecord_bit_vector);
1549 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1551 bit_vector_length (p) = sizei;
1552 bit_vector_next (p) = all_bit_vectors;
1553 /* make sure the extra bits in the last long are 0; the calling
1554 functions might not set them. */
1555 p->bits[BIT_VECTOR_LONG_STORAGE (sizei) - 1] = 0;
1556 XSETBIT_VECTOR (all_bit_vectors, p);
1561 make_bit_vector (EMACS_INT length, Lisp_Object init)
1563 Lisp_Object bit_vector;
1564 struct Lisp_Bit_Vector *p;
1565 EMACS_INT num_longs;
1569 num_longs = BIT_VECTOR_LONG_STORAGE (length);
1570 p = make_bit_vector_internal (length);
1571 XSETBIT_VECTOR (bit_vector, p);
1574 memset (p->bits, 0, num_longs * sizeof (long));
1577 EMACS_INT bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1578 memset (p->bits, ~0, num_longs * sizeof (long));
1579 /* But we have to make sure that the unused bits in the
1580 last integer are 0, so that equal/hash is easy. */
1582 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1589 make_bit_vector_from_byte_vector (unsigned char *bytevec, EMACS_INT length)
1591 Lisp_Object bit_vector;
1592 struct Lisp_Bit_Vector *p;
1596 length = XINT (wrong_type_argument (Qnatnump, make_int (length)));
1598 p = make_bit_vector_internal (length);
1599 XSETBIT_VECTOR (bit_vector, p);
1601 for (i = 0; i < length; i++)
1602 set_bit_vector_bit (p, i, bytevec[i]);
1607 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1608 Return a new bit vector of length LENGTH. with each bit being INIT.
1609 Each element is set to INIT. See also the function `bit-vector'.
1613 CONCHECK_NATNUM (length);
1615 return make_bit_vector (XINT (length), init);
1618 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1619 Return a newly created bit vector with specified arguments as elements.
1620 Any number of arguments, even zero arguments, are allowed.
1622 (int nargs, Lisp_Object *args))
1624 Lisp_Object bit_vector;
1626 struct Lisp_Bit_Vector *p;
1628 for (elt = 0; elt < nargs; elt++)
1629 CHECK_BIT (args[elt]);
1631 p = make_bit_vector_internal (nargs);
1633 for (elt = 0; elt < nargs; elt++)
1634 set_bit_vector_bit (p, elt, !ZEROP (args[elt]));
1636 XSETBIT_VECTOR (bit_vector, p);
1641 /**********************************************************************/
1642 /* Compiled-function allocation */
1643 /**********************************************************************/
1645 DECLARE_FIXED_TYPE_ALLOC (compiled_function, struct Lisp_Compiled_Function);
1646 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1649 make_compiled_function (int make_pure)
1651 struct Lisp_Compiled_Function *b;
1653 size_t size = sizeof (struct Lisp_Compiled_Function);
1655 if (make_pure && check_purespace (size))
1657 b = (struct Lisp_Compiled_Function *) (PUREBEG + pure_bytes_used);
1658 set_lheader_implementation (&(b->lheader), lrecord_compiled_function);
1659 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
1660 b->lheader.pure = 1;
1662 pure_bytes_used += size;
1663 bump_purestat (&purestat_bytecode, size);
1667 ALLOCATE_FIXED_TYPE (compiled_function, struct Lisp_Compiled_Function,
1669 set_lheader_implementation (&(b->lheader), lrecord_compiled_function);
1672 b->flags.documentationp = 0;
1673 b->flags.interactivep = 0;
1674 b->flags.domainp = 0; /* I18N3 */
1675 b->bytecodes = Qzero;
1676 b->constants = Qzero;
1678 b->doc_and_interactive = Qnil;
1679 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1680 b->annotated = Qnil;
1682 XSETCOMPILED_FUNCTION (new, b);
1686 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1687 Return a new compiled-function object.
1688 Usage: (arglist instructions constants stack-size
1689 &optional doc-string interactive-spec)
1690 Note that, unlike all other emacs-lisp functions, calling this with five
1691 arguments is NOT the same as calling it with six arguments, the last of
1692 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1693 that this function was defined with `(interactive)'. If the arg is not
1694 specified, then that means the function is not interactive.
1695 This is terrible behavior which is retained for compatibility with old
1696 `.elc' files which expected these semantics.
1698 (int nargs, Lisp_Object *args))
1700 /* In a non-insane world this function would have this arglist...
1701 (arglist, instructions, constants, stack_size, doc_string, interactive)
1702 Lisp_Object arglist, instructions, constants, stack_size, doc_string,
1705 Lisp_Object arglist = args[0];
1706 Lisp_Object instructions = args[1];
1707 Lisp_Object constants = args[2];
1708 Lisp_Object stack_size = args[3];
1709 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1710 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1711 /* Don't purecopy the doc references in instructions because it's
1712 wasteful; they will get fixed up later.
1714 #### If something goes wrong and they don't get fixed up,
1715 we're screwed, because pure stuff isn't marked and thus the
1716 cons references won't be marked and will get reused.
1718 Note: there will be a window after the byte code is created and
1719 before the doc references are fixed up in which there will be
1720 impure objects inside a pure object, which apparently won't
1721 get marked, leading the trouble. But during that entire window,
1722 the objects are sitting on Vload_force_doc_string_list, which
1723 is staticpro'd, so we're OK. */
1724 int purecopy_instructions = 1;
1727 return Fsignal (Qwrong_number_of_arguments,
1728 list2 (intern ("make-byte-code"), make_int (nargs)));
1730 CHECK_LIST (arglist);
1731 /* instructions is a string or a cons (string . int) for a
1732 lazy-loaded function. */
1733 if (CONSP (instructions))
1735 CHECK_STRING (XCAR (instructions));
1736 CHECK_INT (XCDR (instructions));
1737 if (!NILP (constants))
1738 CHECK_VECTOR (constants);
1739 purecopy_instructions = 0;
1743 CHECK_STRING (instructions);
1744 CHECK_VECTOR (constants);
1746 CHECK_NATNUM (stack_size);
1747 /* doc_string may be nil, string, int, or a cons (string . int). */
1749 /* interactive may be list or string (or unbound). */
1753 if (!purified (arglist))
1754 arglist = Fpurecopy (arglist);
1755 if (purecopy_instructions && !purified (instructions))
1756 instructions = Fpurecopy (instructions);
1757 if (!purified (doc_string))
1758 doc_string = Fpurecopy (doc_string);
1759 if (!purified (interactive) && !UNBOUNDP (interactive))
1760 interactive = Fpurecopy (interactive);
1762 /* Statistics are kept differently for the constants */
1763 if (!purified (constants))
1766 int old = purecopying_for_bytecode;
1767 purecopying_for_bytecode = 1;
1768 constants = Fpurecopy (constants);
1769 purecopying_for_bytecode = old;
1772 constants = Fpurecopy (constants);
1773 #endif /* PURESTAT */
1776 if (STRINGP (instructions))
1777 bump_purestat (&purestat_string_bytecodes, pure_sizeof (instructions));
1778 if (VECTORP (constants))
1779 bump_purestat (&purestat_vector_bytecode_constants,
1780 pure_sizeof (constants));
1781 if (STRINGP (doc_string))
1782 /* These should be have been snagged by make-docfile... */
1783 bump_purestat (&purestat_string_documentation,
1784 pure_sizeof (doc_string));
1785 if (STRINGP (interactive))
1786 bump_purestat (&purestat_string_interactive,
1787 pure_sizeof (interactive));
1788 #endif /* PURESTAT */
1792 int docp = !NILP (doc_string);
1793 int intp = !UNBOUNDP (interactive);
1795 int domp = !NILP (Vfile_domain);
1797 Lisp_Object val = make_compiled_function (purify_flag);
1798 struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (val);
1799 b->flags.documentationp = docp;
1800 b->flags.interactivep = intp;
1802 b->flags.domainp = domp;
1804 b->maxdepth = XINT (stack_size);
1805 b->bytecodes = instructions;
1806 b->constants = constants;
1807 b->arglist = arglist;
1808 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1809 if (!NILP (Vcurrent_compiled_function_annotation))
1810 b->annotated = Fpurecopy (Vcurrent_compiled_function_annotation);
1811 else if (!NILP (Vload_file_name_internal_the_purecopy))
1812 b->annotated = Vload_file_name_internal_the_purecopy;
1813 else if (!NILP (Vload_file_name_internal))
1815 struct gcpro gcpro1;
1816 GCPRO1(val); /* don't let val or b get reaped */
1817 Vload_file_name_internal_the_purecopy =
1818 Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
1819 b->annotated = Vload_file_name_internal_the_purecopy;
1822 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1825 if (docp && intp && domp)
1826 b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
1828 (((purify_flag) ? pure_cons : Fcons)
1829 (interactive, Vfile_domain))));
1830 else if (docp && domp)
1831 b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
1832 (doc_string, Vfile_domain));
1833 else if (intp && domp)
1834 b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
1835 (interactive, Vfile_domain));
1839 b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
1840 (doc_string, interactive));
1842 b->doc_and_interactive = interactive;
1845 b->doc_and_interactive = Vfile_domain;
1848 b->doc_and_interactive = doc_string;
1855 /**********************************************************************/
1856 /* Symbol allocation */
1857 /**********************************************************************/
1859 DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol);
1860 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1862 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1863 Return a newly allocated uninterned symbol whose name is NAME.
1864 Its value and function definition are void, and its property list is nil.
1869 struct Lisp_Symbol *p;
1873 ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p);
1874 #ifdef LRECORD_SYMBOL
1875 set_lheader_implementation (&(p->lheader), lrecord_symbol);
1877 p->name = XSTRING (str);
1879 p->value = Qunbound;
1880 p->function = Qunbound;
1882 symbol_next (p) = 0;
1883 XSETSYMBOL (val, p);
1888 /**********************************************************************/
1889 /* Extent allocation */
1890 /**********************************************************************/
1892 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1893 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1896 allocate_extent (void)
1900 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1902 set_lheader_implementation (&(e->lheader), lrecord_extent);
1903 extent_object (e) = Qnil;
1904 set_extent_start (e, -1);
1905 set_extent_end (e, -1);
1910 extent_face (e) = Qnil;
1911 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1912 e->flags.detachable = 1;
1918 /**********************************************************************/
1919 /* Event allocation */
1920 /**********************************************************************/
1922 DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event);
1923 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1926 allocate_event (void)
1929 struct Lisp_Event *e;
1931 ALLOCATE_FIXED_TYPE (event, struct Lisp_Event, e);
1932 set_lheader_implementation (&(e->lheader), lrecord_event);
1939 /**********************************************************************/
1940 /* Marker allocation */
1941 /**********************************************************************/
1943 DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker);
1944 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1946 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1947 Return a new marker which does not point at any place.
1952 struct Lisp_Marker *p;
1954 ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1955 set_lheader_implementation (&(p->lheader), lrecord_marker);
1958 marker_next (p) = 0;
1959 marker_prev (p) = 0;
1960 p->insertion_type = 0;
1961 XSETMARKER (val, p);
1966 noseeum_make_marker (void)
1969 struct Lisp_Marker *p;
1971 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1972 set_lheader_implementation (&(p->lheader), lrecord_marker);
1975 marker_next (p) = 0;
1976 marker_prev (p) = 0;
1977 p->insertion_type = 0;
1978 XSETMARKER (val, p);
1983 /**********************************************************************/
1984 /* String allocation */
1985 /**********************************************************************/
1987 /* The data for "short" strings generally resides inside of structs of type
1988 string_chars_block. The Lisp_String structure is allocated just like any
1989 other Lisp object (except for vectors), and these are freelisted when
1990 they get garbage collected. The data for short strings get compacted,
1991 but the data for large strings do not.
1993 Previously Lisp_String structures were relocated, but this caused a lot
1994 of bus-errors because the C code didn't include enough GCPRO's for
1995 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1996 that the reference would get relocated).
1998 This new method makes things somewhat bigger, but it is MUCH safer. */
2000 DECLARE_FIXED_TYPE_ALLOC (string, struct Lisp_String);
2001 /* strings are used and freed quite often */
2002 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
2003 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
2005 #ifdef LRECORD_STRING
2007 mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object))
2009 struct Lisp_String *ptr = XSTRING (obj);
2011 if (GC_CONSP (ptr->plist) && GC_EXTENT_INFOP (XCAR (ptr->plist)))
2012 flush_cached_extent_info (XCAR (ptr->plist));
2017 string_equal (Lisp_Object o1, Lisp_Object o2, int depth)
2020 return (((len = XSTRING_LENGTH (o1)) == XSTRING_LENGTH (o2)) &&
2021 !memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len));
2024 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
2025 mark_string, print_string,
2027 * No `finalize', or `hash' methods.
2028 * internal_hash already knows how
2029 * to hash strings and finalization
2031 * ADDITIONAL_FREE_string macro,
2032 * which is the standard way to do
2033 * finalization when using
2034 * SWEEP_FIXED_TYPE_BLOCK().
2037 struct Lisp_String);
2038 #endif /* LRECORD_STRING */
2040 /* String blocks contain this many useful bytes. */
2041 #define STRING_CHARS_BLOCK_SIZE \
2042 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
2043 ((2 * sizeof (struct string_chars_block *)) \
2044 + sizeof (EMACS_INT))))
2045 /* Block header for small strings. */
2046 struct string_chars_block
2049 struct string_chars_block *next;
2050 struct string_chars_block *prev;
2051 /* Contents of string_chars_block->string_chars are interleaved
2052 string_chars structures (see below) and the actual string data */
2053 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
2056 struct string_chars_block *first_string_chars_block;
2057 struct string_chars_block *current_string_chars_block;
2059 /* If SIZE is the length of a string, this returns how many bytes
2060 * the string occupies in string_chars_block->string_chars
2061 * (including alignment padding).
2063 #define STRING_FULLSIZE(s) \
2064 ALIGN_SIZE (((s) + 1 + sizeof (struct Lisp_String *)),\
2065 ALIGNOF (struct Lisp_String *))
2067 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
2068 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
2070 #define CHARS_TO_STRING_CHAR(x) \
2071 ((struct string_chars *) \
2072 (((char *) (x)) - (slot_offset (struct string_chars, chars[0]))))
2077 struct Lisp_String *string;
2078 unsigned char chars[1];
2081 struct unused_string_chars
2083 struct Lisp_String *string;
2088 init_string_chars_alloc (void)
2090 first_string_chars_block = xnew (struct string_chars_block);
2091 first_string_chars_block->prev = 0;
2092 first_string_chars_block->next = 0;
2093 first_string_chars_block->pos = 0;
2094 current_string_chars_block = first_string_chars_block;
2097 static struct string_chars *
2098 allocate_string_chars_struct (struct Lisp_String *string_it_goes_with,
2101 struct string_chars *s_chars;
2103 /* Allocate the string's actual data */
2104 if (BIG_STRING_FULLSIZE_P (fullsize))
2106 s_chars = (struct string_chars *) xmalloc (fullsize);
2108 else if (fullsize <=
2109 (countof (current_string_chars_block->string_chars)
2110 - current_string_chars_block->pos))
2112 /* This string can fit in the current string chars block */
2113 s_chars = (struct string_chars *)
2114 (current_string_chars_block->string_chars
2115 + current_string_chars_block->pos);
2116 current_string_chars_block->pos += fullsize;
2120 /* Make a new current string chars block */
2121 struct string_chars_block *new = xnew (struct string_chars_block);
2123 current_string_chars_block->next = new;
2124 new->prev = current_string_chars_block;
2126 current_string_chars_block = new;
2127 new->pos = fullsize;
2128 s_chars = (struct string_chars *)
2129 current_string_chars_block->string_chars;
2132 s_chars->string = string_it_goes_with;
2134 INCREMENT_CONS_COUNTER (fullsize, "string chars");
2140 make_uninit_string (Bytecount length)
2142 struct Lisp_String *s;
2143 struct string_chars *s_chars;
2144 EMACS_INT fullsize = STRING_FULLSIZE (length);
2147 if ((length < 0) || (fullsize <= 0))
2150 /* Allocate the string header */
2151 ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
2152 #ifdef LRECORD_STRING
2153 set_lheader_implementation (&(s->lheader), lrecord_string);
2156 s_chars = allocate_string_chars_struct (s, fullsize);
2158 set_string_data (s, &(s_chars->chars[0]));
2159 set_string_length (s, length);
2162 set_string_byte (s, length, 0);
2164 XSETSTRING (val, s);
2168 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2169 static void verify_string_chars_integrity (void);
2172 /* Resize the string S so that DELTA bytes can be inserted starting
2173 at POS. If DELTA < 0, it means deletion starting at POS. If
2174 POS < 0, resize the string but don't copy any characters. Use
2175 this if you're planning on completely overwriting the string.
2179 resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta)
2181 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2182 verify_string_chars_integrity ();
2185 #ifdef ERROR_CHECK_BUFPOS
2188 assert (pos <= string_length (s));
2190 assert (pos + (-delta) <= string_length (s));
2195 assert ((-delta) <= string_length (s));
2197 #endif /* ERROR_CHECK_BUFPOS */
2199 if (pos >= 0 && delta < 0)
2200 /* If DELTA < 0, the functions below will delete the characters
2201 before POS. We want to delete characters *after* POS, however,
2202 so convert this to the appropriate form. */
2206 /* simplest case: no size change. */
2210 Bytecount oldfullsize = STRING_FULLSIZE (string_length (s));
2211 Bytecount newfullsize = STRING_FULLSIZE (string_length (s) + delta);
2213 if (oldfullsize == newfullsize)
2215 /* next simplest case; size change but the necessary
2216 allocation size won't change (up or down; code somewhere
2217 depends on there not being any unused allocation space,
2218 modulo any alignment constraints). */
2221 Bufbyte *addroff = pos + string_data (s);
2223 memmove (addroff + delta, addroff,
2224 /* +1 due to zero-termination. */
2225 string_length (s) + 1 - pos);
2228 else if (BIG_STRING_FULLSIZE_P (oldfullsize) &&
2229 BIG_STRING_FULLSIZE_P (newfullsize))
2231 /* next simplest case; the string is big enough to be malloc()ed
2232 itself, so we just realloc.
2234 It's important not to let the string get below the threshold
2235 for making big strings and still remain malloc()ed; if that
2236 were the case, repeated calls to this function on the same
2237 string could result in memory leakage. */
2238 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
2242 Bufbyte *addroff = pos + string_data (s);
2244 memmove (addroff + delta, addroff,
2245 /* +1 due to zero-termination. */
2246 string_length (s) + 1 - pos);
2251 /* worst case. We make a new string_chars struct and copy
2252 the string's data into it, inserting/deleting the delta
2253 in the process. The old string data will either get
2254 freed by us (if it was malloc()ed) or will be reclaimed
2255 in the normal course of garbage collection. */
2256 struct string_chars *s_chars =
2257 allocate_string_chars_struct (s, newfullsize);
2258 Bufbyte *new_addr = &(s_chars->chars[0]);
2259 Bufbyte *old_addr = string_data (s);
2262 memcpy (new_addr, old_addr, pos);
2263 memcpy (new_addr + pos + delta, old_addr + pos,
2264 string_length (s) + 1 - pos);
2266 set_string_data (s, new_addr);
2267 if (BIG_STRING_FULLSIZE_P (oldfullsize))
2271 /* We need to mark this chunk of the string_chars_block
2272 as unused so that compact_string_chars() doesn't
2274 struct string_chars *old_s_chars =
2275 (struct string_chars *) ((char *) old_addr -
2276 sizeof (struct Lisp_String *));
2277 /* Sanity check to make sure we aren't hosed by strange
2278 alignment/padding. */
2279 assert (old_s_chars->string == s);
2280 MARK_STRUCT_AS_FREE (old_s_chars);
2281 ((struct unused_string_chars *) old_s_chars)->fullsize =
2286 set_string_length (s, string_length (s) + delta);
2287 /* If pos < 0, the string won't be zero-terminated.
2288 Terminate now just to make sure. */
2289 string_data (s)[string_length (s)] = '\0';
2295 XSETSTRING (string, s);
2296 /* We also have to adjust all of the extent indices after the
2297 place we did the change. We say "pos - 1" because
2298 adjust_extents() is exclusive of the starting position
2300 adjust_extents (string, pos - 1, string_length (s),
2305 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2306 verify_string_chars_integrity ();
2313 set_string_char (struct Lisp_String *s, Charcount i, Emchar c)
2315 Bytecount oldlen, newlen;
2316 Bufbyte newstr[MAX_EMCHAR_LEN];
2317 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2319 oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2320 newlen = set_charptr_emchar (newstr, c);
2322 if (oldlen != newlen)
2323 resize_string (s, bytoff, newlen - oldlen);
2324 /* Remember, string_data (s) might have changed so we can't cache it. */
2325 memcpy (string_data (s) + bytoff, newstr, newlen);
2330 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2331 Return a new string of length LENGTH, with each character being INIT.
2332 LENGTH must be an integer and INIT must be a character.
2338 CHECK_NATNUM (length);
2339 CHECK_CHAR_COERCE_INT (init);
2341 Bufbyte str[MAX_EMCHAR_LEN];
2342 int len = set_charptr_emchar (str, XCHAR (init));
2344 val = make_uninit_string (len * XINT (length));
2346 /* Optimize the single-byte case */
2347 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2351 Bufbyte *ptr = XSTRING_DATA (val);
2354 for (i = 0; i < XINT (length); i++)
2355 for (j = 0; j < len; j++)
2362 DEFUN ("string", Fstring, 0, MANY, 0, /*
2363 Concatenate all the argument characters and make the result a string.
2365 (int nargs, Lisp_Object *args))
2367 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2368 Bufbyte *p = storage;
2370 for (; nargs; nargs--, args++)
2372 Lisp_Object lisp_char = *args;
2373 CHECK_CHAR_COERCE_INT (lisp_char);
2374 p += set_charptr_emchar (p, XCHAR (lisp_char));
2376 return make_string (storage, p - storage);
2379 /* Take some raw memory, which MUST already be in internal format,
2380 and package it up into a Lisp string. */
2382 make_string (CONST Bufbyte *contents, Bytecount length)
2386 /* Make sure we find out about bad make_string's when they happen */
2387 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2388 bytecount_to_charcount (contents, length); /* Just for the assertions */
2391 val = make_uninit_string (length);
2392 memcpy (XSTRING_DATA (val), contents, length);
2396 /* Take some raw memory, encoded in some external data format,
2397 and convert it into a Lisp string. */
2399 make_ext_string (CONST Extbyte *contents, EMACS_INT length,
2400 enum external_data_format fmt)
2405 GET_CHARPTR_INT_DATA_ALLOCA (contents, length, fmt, intstr, intlen);
2406 return make_string (intstr, intlen);
2410 build_string (CONST char *str)
2412 /* Some strlen's crash and burn if passed null. */
2413 return make_string ((CONST Bufbyte *) str, (str ? strlen(str) : 0));
2417 build_ext_string (CONST char *str, enum external_data_format fmt)
2419 /* Some strlen's crash and burn if passed null. */
2420 return make_ext_string ((CONST Extbyte *) str, (str ? strlen(str) : 0), fmt);
2424 build_translated_string (CONST char *str)
2426 return build_string (GETTEXT (str));
2430 /************************************************************************/
2431 /* lcrecord lists */
2432 /************************************************************************/
2434 /* Lcrecord lists are used to manage the allocation of particular
2435 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2436 malloc() and garbage-collection junk) as much as possible.
2437 It is similar to the Blocktype class.
2441 1) Create an lcrecord-list object using make_lcrecord_list().
2442 This is often done at initialization. Remember to staticpro
2443 this object! The arguments to make_lcrecord_list() are the
2444 same as would be passed to alloc_lcrecord().
2445 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2446 and pass the lcrecord-list earlier created.
2447 3) When done with the lcrecord, call free_managed_lcrecord().
2448 The standard freeing caveats apply: ** make sure there are no
2449 pointers to the object anywhere! **
2450 4) Calling free_managed_lcrecord() is just like kissing the
2451 lcrecord goodbye as if it were garbage-collected. This means:
2452 -- the contents of the freed lcrecord are undefined, and the
2453 contents of something produced by allocate_managed_lcrecord()
2454 are undefined, just like for alloc_lcrecord().
2455 -- the mark method for the lcrecord's type will *NEVER* be called
2457 -- the finalize method for the lcrecord's type will be called
2458 at the time that free_managed_lcrecord() is called.
2463 mark_lcrecord_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
2465 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2466 Lisp_Object chain = list->free;
2468 while (!NILP (chain))
2470 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2471 struct free_lcrecord_header *free_header =
2472 (struct free_lcrecord_header *) lheader;
2474 #ifdef ERROR_CHECK_GC
2475 CONST struct lrecord_implementation *implementation
2476 = LHEADER_IMPLEMENTATION(lheader);
2478 /* There should be no other pointers to the free list. */
2479 assert (!MARKED_RECORD_HEADER_P (lheader));
2480 /* Only lcrecords should be here. */
2481 assert (!implementation->basic_p);
2482 /* Only free lcrecords should be here. */
2483 assert (free_header->lcheader.free);
2484 /* The type of the lcrecord must be right. */
2485 assert (implementation == list->implementation);
2486 /* So must the size. */
2487 assert (implementation->static_size == 0
2488 || implementation->static_size == list->size);
2489 #endif /* ERROR_CHECK_GC */
2491 MARK_RECORD_HEADER (lheader);
2492 chain = free_header->chain;
2498 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2499 mark_lcrecord_list, internal_object_printer,
2500 0, 0, 0, struct lcrecord_list);
2502 make_lcrecord_list (size_t size,
2503 CONST struct lrecord_implementation *implementation)
2505 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2506 lrecord_lcrecord_list);
2509 p->implementation = implementation;
2512 XSETLCRECORD_LIST (val, p);
2517 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2519 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2520 if (!NILP (list->free))
2522 Lisp_Object val = list->free;
2523 struct free_lcrecord_header *free_header =
2524 (struct free_lcrecord_header *) XPNTR (val);
2526 #ifdef ERROR_CHECK_GC
2527 struct lrecord_header *lheader =
2528 (struct lrecord_header *) free_header;
2529 CONST struct lrecord_implementation *implementation
2530 = LHEADER_IMPLEMENTATION (lheader);
2532 /* There should be no other pointers to the free list. */
2533 assert (!MARKED_RECORD_HEADER_P (lheader));
2534 /* Only lcrecords should be here. */
2535 assert (!implementation->basic_p);
2536 /* Only free lcrecords should be here. */
2537 assert (free_header->lcheader.free);
2538 /* The type of the lcrecord must be right. */
2539 assert (implementation == list->implementation);
2540 /* So must the size. */
2541 assert (implementation->static_size == 0
2542 || implementation->static_size == list->size);
2543 #endif /* ERROR_CHECK_GC */
2544 list->free = free_header->chain;
2545 free_header->lcheader.free = 0;
2552 XSETOBJ (val, Lisp_Type_Record,
2553 alloc_lcrecord (list->size, list->implementation));
2559 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2561 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2562 struct free_lcrecord_header *free_header =
2563 (struct free_lcrecord_header *) XPNTR (lcrecord);
2564 struct lrecord_header *lheader =
2565 (struct lrecord_header *) free_header;
2566 CONST struct lrecord_implementation *implementation
2567 = LHEADER_IMPLEMENTATION (lheader);
2569 #ifdef ERROR_CHECK_GC
2570 /* Make sure the size is correct. This will catch, for example,
2571 putting a window configuration on the wrong free list. */
2572 if (implementation->size_in_bytes_method)
2573 assert (((implementation->size_in_bytes_method) (lheader))
2576 assert (implementation->static_size == list->size);
2577 #endif /* ERROR_CHECK_GC */
2579 if (implementation->finalizer)
2580 ((implementation->finalizer) (lheader, 0));
2581 free_header->chain = list->free;
2582 free_header->lcheader.free = 1;
2583 list->free = lcrecord;
2587 /**********************************************************************/
2588 /* Purity of essence, peace on earth */
2589 /**********************************************************************/
2591 static int symbols_initialized;
2594 make_pure_string (CONST Bufbyte *data, Bytecount length,
2595 Lisp_Object plist, int no_need_to_copy_data)
2598 struct Lisp_String *s;
2599 size_t size = sizeof (struct Lisp_String) +
2600 (no_need_to_copy_data ? 0 : (length + 1)); /* + 1 for terminating 0 */
2601 size = ALIGN_SIZE (size, ALIGNOF (Lisp_Object));
2603 if (symbols_initialized && !pure_lossage)
2605 /* Try to share some names. Saves a few kbytes. */
2606 Lisp_Object tem = oblookup (Vobarray, data, length);
2609 s = XSYMBOL (tem)->name;
2610 if (!PURIFIED (s)) abort ();
2611 XSETSTRING (new, s);
2616 if (!check_purespace (size))
2617 return make_string (data, length);
2619 s = (struct Lisp_String *) (PUREBEG + pure_bytes_used);
2620 #ifdef LRECORD_STRING
2621 set_lheader_implementation (&(s->lheader), lrecord_string);
2622 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2623 s->lheader.pure = 1;
2626 set_string_length (s, length);
2627 if (no_need_to_copy_data)
2629 set_string_data (s, (Bufbyte *) data);
2633 set_string_data (s, (Bufbyte *) s + sizeof (struct Lisp_String));
2634 memcpy (string_data (s), data, length);
2635 set_string_byte (s, length, 0);
2638 pure_bytes_used += size;
2641 bump_purestat (&purestat_string_all, size);
2642 if (purecopying_for_bytecode)
2643 bump_purestat (&purestat_string_other_function, size);
2644 #endif /* PURESTAT */
2646 /* Do this after the official "completion" of the purecopying. */
2647 s->plist = Fpurecopy (plist);
2649 XSETSTRING (new, s);
2655 make_pure_pname (CONST Bufbyte *data, Bytecount length,
2656 int no_need_to_copy_data)
2658 Lisp_Object name = make_pure_string (data, length, Qnil,
2659 no_need_to_copy_data);
2660 bump_purestat (&purestat_string_pname, pure_sizeof (name));
2662 /* We've made (at least) Qnil now, and Vobarray will soon be set up. */
2663 symbols_initialized = 1;
2670 pure_cons (Lisp_Object car, Lisp_Object cdr)
2673 struct Lisp_Cons *c;
2675 if (!check_purespace (sizeof (struct Lisp_Cons)))
2676 return Fcons (Fpurecopy (car), Fpurecopy (cdr));
2678 c = (struct Lisp_Cons *) (PUREBEG + pure_bytes_used);
2680 set_lheader_implementation (&(c->lheader), lrecord_cons);
2681 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2682 c->lheader.pure = 1;
2685 pure_bytes_used += sizeof (struct Lisp_Cons);
2686 bump_purestat (&purestat_cons, sizeof (struct Lisp_Cons));
2688 c->car = Fpurecopy (car);
2689 c->cdr = Fpurecopy (cdr);
2695 pure_list (int nargs, Lisp_Object *args)
2697 Lisp_Object val = Qnil;
2699 for (--nargs; nargs >= 0; nargs--)
2700 val = pure_cons (args[nargs], val);
2705 #ifdef LISP_FLOAT_TYPE
2708 make_pure_float (double num)
2710 struct Lisp_Float *f;
2713 /* Make sure that PUREBEG + pure_bytes_used is aligned on at least a sizeof
2714 (double) boundary. Some architectures (like the sparc) require
2715 this, and I suspect that floats are rare enough that it's no
2716 tragedy for those that don't. */
2718 #if defined (__GNUC__) && (__GNUC__ >= 2)
2719 /* In gcc, we can directly ask what the alignment constraints of a
2720 structure are, but in general, that's not possible... Arrgh!!
2722 int alignment = __alignof (struct Lisp_Float);
2724 /* Best guess is to make the `double' slot be aligned to the size
2725 of double (which is probably 8 bytes). This assumes that it's
2726 ok to align the beginning of the structure to the same boundary
2727 that the `double' slot in it is supposed to be aligned to; this
2728 should be ok because presumably there is padding in the layout
2729 of the struct to account for this.
2731 int alignment = sizeof (float_data (f));
2733 char *p = ((char *) PUREBEG + pure_bytes_used);
2735 p = (char *) (((EMACS_UINT) p + alignment - 1) & - alignment);
2736 pure_bytes_used = p - (char *) PUREBEG;
2739 if (!check_purespace (sizeof (struct Lisp_Float)))
2740 return make_float (num);
2742 f = (struct Lisp_Float *) (PUREBEG + pure_bytes_used);
2743 set_lheader_implementation (&(f->lheader), lrecord_float);
2744 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2745 f->lheader.pure = 1;
2747 pure_bytes_used += sizeof (struct Lisp_Float);
2748 bump_purestat (&purestat_float, sizeof (struct Lisp_Float));
2750 float_data (f) = num;
2755 #endif /* LISP_FLOAT_TYPE */
2758 make_pure_vector (size_t len, Lisp_Object init)
2761 struct Lisp_Vector *v;
2762 size_t size = (sizeof (struct Lisp_Vector)
2763 + (len - 1) * sizeof (Lisp_Object));
2765 init = Fpurecopy (init);
2767 if (!check_purespace (size))
2768 return make_vector (len, init);
2770 v = (struct Lisp_Vector *) (PUREBEG + pure_bytes_used);
2771 #ifdef LRECORD_VECTOR
2772 set_lheader_implementation (&(v->header.lheader), lrecord_vector);
2773 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2774 v->header.lheader.pure = 1;
2777 pure_bytes_used += size;
2778 bump_purestat (&purestat_vector_all, size);
2782 for (size = 0; size < len; size++)
2783 v->contents[size] = init;
2785 XSETVECTOR (new, v);
2790 /* Presently unused */
2792 alloc_pure_lrecord (int size, struct lrecord_implementation *implementation)
2794 struct lrecord_header *header = (void *) (PUREBEG + pure_bytes_used);
2796 if (pure_bytes_used + size > get_PURESIZE())
2797 pure_storage_exhausted ();
2799 set_lheader_implementation (header, implementation);
2807 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2808 Make a copy of OBJECT in pure storage.
2809 Recursively copies contents of vectors and cons cells.
2810 Does not copy symbols.
2818 if (!POINTER_TYPE_P (XTYPE (obj))
2819 || PURIFIED (XPNTR (obj))
2820 /* happens when bootstrapping Qnil */
2821 || EQ (obj, Qnull_pointer))
2824 switch (XTYPE (obj))
2826 #ifndef LRECORD_CONS
2827 case Lisp_Type_Cons:
2828 return pure_cons (XCAR (obj), XCDR (obj));
2831 #ifndef LRECORD_STRING
2832 case Lisp_Type_String:
2833 return make_pure_string (XSTRING_DATA (obj),
2834 XSTRING_LENGTH (obj),
2835 XSTRING (obj)->plist,
2837 #endif /* ! LRECORD_STRING */
2839 #ifndef LRECORD_VECTOR
2840 case Lisp_Type_Vector:
2842 struct Lisp_Vector *o = XVECTOR (obj);
2843 Lisp_Object new = make_pure_vector (vector_length (o), Qnil);
2844 for (i = 0; i < vector_length (o); i++)
2845 XVECTOR_DATA (new)[i] = Fpurecopy (o->contents[i]);
2848 #endif /* !LRECORD_VECTOR */
2852 if (COMPILED_FUNCTIONP (obj))
2854 struct Lisp_Compiled_Function *o = XCOMPILED_FUNCTION (obj);
2855 Lisp_Object new = make_compiled_function (1);
2856 /* How on earth could this code have worked before? -sb */
2857 struct Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (new);
2858 n->flags = o->flags;
2859 n->bytecodes = Fpurecopy (o->bytecodes);
2860 n->constants = Fpurecopy (o->constants);
2861 n->arglist = Fpurecopy (o->arglist);
2862 n->doc_and_interactive = Fpurecopy (o->doc_and_interactive);
2863 n->maxdepth = o->maxdepth;
2867 else if (CONSP (obj))
2868 return pure_cons (XCAR (obj), XCDR (obj));
2869 #endif /* LRECORD_CONS */
2870 #ifdef LRECORD_VECTOR
2871 else if (VECTORP (obj))
2873 struct Lisp_Vector *o = XVECTOR (obj);
2874 Lisp_Object new = make_pure_vector (vector_length (o), Qnil);
2875 for (i = 0; i < vector_length (o); i++)
2876 XVECTOR_DATA (new)[i] = Fpurecopy (o->contents[i]);
2879 #endif /* LRECORD_VECTOR */
2880 #ifdef LRECORD_STRING
2881 else if (STRINGP (obj))
2883 return make_pure_string (XSTRING_DATA (obj),
2884 XSTRING_LENGTH (obj),
2885 XSTRING (obj)->plist,
2888 #endif /* LRECORD_STRING */
2889 #ifdef LISP_FLOAT_TYPE
2890 else if (FLOATP (obj))
2891 return make_pure_float (float_data (XFLOAT (obj)));
2892 #endif /* LISP_FLOAT_TYPE */
2893 else if (SYMBOLP (obj))
2896 * Symbols can't be made pure (and thus read-only),
2897 * because assigning to their function, value or plist
2898 * slots would produced a SEGV in the dumped XEmacs. So
2899 * we previously would just return the symbol unchanged.
2901 * But purified aggregate objects like lists and vectors
2902 * can contain uninterned symbols. If there are no
2903 * other non-pure references to the symbol, then the
2904 * symbol is not protected from garbage collection
2905 * because the collector does not mark the contents of
2906 * purified objects. So to protect the symbols, an impure
2907 * reference has to be kept for each uninterned symbol
2908 * that is referenced by a pure object. All such
2909 * symbols are stored in the hashtable pointed to by
2910 * Vpure_uninterned_symbol_table, which is itself
2913 if (!NILP (XSYMBOL (obj)->obarray))
2915 Fputhash (obj, Qnil, Vpure_uninterned_symbol_table);
2919 signal_simple_error ("Can't purecopy %S", obj);
2928 puresize_adjust_h (size_t puresize)
2930 FILE *stream = fopen ("puresize-adjust.h", "w");
2933 report_file_error ("Opening puresize adjustment file",
2934 Fcons (build_string ("puresize-adjust.h"), Qnil));
2937 "/*\tDo not edit this file!\n"
2938 "\tAutomatically generated by XEmacs */\n"
2939 "# define PURESIZE_ADJUSTMENT (%ld)\n",
2940 (long) (puresize - RAW_PURESIZE));
2945 report_pure_usage (int report_impurities,
2946 int die_if_pure_storage_exceeded)
2952 message ("\n****\tPure Lisp storage exhausted!\n"
2953 "\tPurespace usage: %ld of %ld\n"
2955 (long) get_PURESIZE() + pure_lossage,
2956 (long) get_PURESIZE());
2957 if (die_if_pure_storage_exceeded)
2959 puresize_adjust_h (get_PURESIZE() + pure_lossage);
2968 size_t lost = (get_PURESIZE() - pure_bytes_used) / 1024;
2970 /* extern Lisp_Object Vemacs_beta_version; */
2971 /* This used to be NILP(Vemacs_beta_version) ? 512 : 4; */
2972 #ifndef PURESIZE_SLOP
2973 #define PURESIZE_SLOP 0
2975 size_t slop = PURESIZE_SLOP;
2977 sprintf (buf, "Purespace usage: %ld of %ld (%d%%",
2978 (long) pure_bytes_used,
2979 (long) get_PURESIZE(),
2980 (int) (pure_bytes_used / (get_PURESIZE() / 100.0) + 0.5));
2981 if (lost > ((slop ? slop : 1) / 1024)) {
2982 sprintf (buf + strlen (buf), " -- %ldk wasted", (long)lost);
2983 if (die_if_pure_storage_exceeded) {
2984 puresize_adjust_h (pure_bytes_used + slop);
2993 message ("%s", buf);
2998 purestat_vector_other.nbytes =
2999 purestat_vector_all.nbytes -
3000 purestat_vector_bytecode_constants.nbytes;
3001 purestat_vector_other.nobjects =
3002 purestat_vector_all.nobjects -
3003 purestat_vector_bytecode_constants.nobjects;
3005 purestat_string_other.nbytes =
3006 purestat_string_all.nbytes -
3007 (purestat_string_pname.nbytes +
3008 purestat_string_bytecodes.nbytes +
3009 purestat_string_interactive.nbytes +
3010 purestat_string_documentation.nbytes +
3012 purestat_string_domain.nbytes +
3014 purestat_string_other_function.nbytes);
3016 purestat_string_other.nobjects =
3017 purestat_string_all.nobjects -
3018 (purestat_string_pname.nobjects +
3019 purestat_string_bytecodes.nobjects +
3020 purestat_string_interactive.nobjects +
3021 purestat_string_documentation.nobjects +
3023 purestat_string_domain.nobjects +
3025 purestat_string_other_function.nobjects);
3027 message (" %-26s Total Bytes", "");
3032 for (j = 0; j < countof (purestats); j++)
3038 sprintf(buf, "%s:", purestats[j]->name);
3039 message (" %-26s %5d %7d %2d%%",
3041 purestats[j]->nobjects,
3042 purestats[j]->nbytes,
3043 (int) (purestats[j]->nbytes / (pure_bytes_used / 100.0) + 0.5));
3046 #endif /* PURESTAT */
3049 if (report_impurities)
3051 Lisp_Object tem = Felt (Fgarbage_collect (), make_int (5));
3052 struct gcpro gcpro1;
3054 message ("\nImpurities:");
3057 if (CONSP (tem) && SYMBOLP (Fcar (tem)) && CONSP (Fcdr (tem)))
3059 int total = XINT (Fcar (Fcdr (tem)));
3064 memcpy (buf, string_data (XSYMBOL (Fcar (tem))->name),
3065 string_length (XSYMBOL (Fcar (tem))->name) + 1);
3066 while (*s++) if (*s == '-') *s = ' ';
3067 s--; *s++ = ':'; *s = 0;
3068 message (" %-33s %6d", buf, total);
3070 tem = Fcdr (Fcdr (tem));
3074 Fprin1 (tem, Qexternal_debugging_output);
3079 garbage_collect_1 (); /* GC garbage_collect's garbage */
3084 unlink("SATISFIED");
3085 fatal ("Pure size adjusted, Don't Panic! I will restart the `make'");
3086 } else if (pure_lossage && die_if_pure_storage_exceeded) {
3087 fatal ("Pure storage exhausted");
3092 /**********************************************************************/
3094 /**********************************************************************/
3096 struct gcpro *gcprolist;
3098 /* 415 used Mly 29-Jun-93 */
3099 /* 1327 used slb 28-Feb-98 */
3101 #define NSTATICS 4000
3103 #define NSTATICS 2000
3105 /* Not "static" because of linker lossage on some systems */
3106 Lisp_Object *staticvec[NSTATICS]
3107 /* Force it into data space! */
3109 static int staticidx;
3111 /* Put an entry in staticvec, pointing at the variable whose address is given
3114 staticpro (Lisp_Object *varaddress)
3116 if (staticidx >= countof (staticvec))
3117 /* #### This is now a dubious abort() since this routine may be called */
3118 /* by Lisp attempting to load a DLL. */
3120 staticvec[staticidx++] = varaddress;
3124 /* Mark reference to a Lisp_Object. If the object referred to has not been
3125 seen yet, recursively mark all the references contained in it. */
3128 mark_object (Lisp_Object obj)
3132 if (EQ (obj, Qnull_pointer))
3134 if (!POINTER_TYPE_P (XGCTYPE (obj)))
3136 if (PURIFIED (XPNTR (obj)))
3138 switch (XGCTYPE (obj))
3140 #ifndef LRECORD_CONS
3141 case Lisp_Type_Cons:
3143 struct Lisp_Cons *ptr = XCONS (obj);
3144 if (CONS_MARKED_P (ptr))
3147 /* If the cdr is nil, tail-recurse on the car. */
3148 if (NILP (ptr->cdr))
3154 mark_object (ptr->car);
3161 case Lisp_Type_Record:
3162 /* case Lisp_Symbol_Value_Magic: */
3164 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3165 CONST struct lrecord_implementation *implementation
3166 = LHEADER_IMPLEMENTATION (lheader);
3168 if (! MARKED_RECORD_HEADER_P (lheader) &&
3169 ! UNMARKABLE_RECORD_HEADER_P (lheader))
3171 MARK_RECORD_HEADER (lheader);
3172 #ifdef ERROR_CHECK_GC
3173 if (!implementation->basic_p)
3174 assert (! ((struct lcrecord_header *) lheader)->free);
3176 if (implementation->marker != 0)
3178 obj = ((implementation->marker) (obj, mark_object));
3179 if (!NILP (obj)) goto tail_recurse;
3185 #ifndef LRECORD_STRING
3186 case Lisp_Type_String:
3188 struct Lisp_String *ptr = XSTRING (obj);
3190 if (!XMARKBIT (ptr->plist))
3192 if (CONSP (ptr->plist) &&
3193 EXTENT_INFOP (XCAR (ptr->plist)))
3194 flush_cached_extent_info (XCAR (ptr->plist));
3201 #endif /* ! LRECORD_STRING */
3203 #ifndef LRECORD_VECTOR
3204 case Lisp_Type_Vector:
3206 struct Lisp_Vector *ptr = XVECTOR (obj);
3207 int len = vector_length (ptr);
3211 break; /* Already marked */
3212 ptr->size = -1 - len; /* Else mark it */
3213 for (i = 0; i < len - 1; i++) /* and then mark its elements */
3214 mark_object (ptr->contents[i]);
3217 obj = ptr->contents[len - 1];
3222 #endif /* !LRECORD_VECTOR */
3224 #ifndef LRECORD_SYMBOL
3225 case Lisp_Type_Symbol:
3227 struct Lisp_Symbol *sym = XSYMBOL (obj);
3229 while (!XMARKBIT (sym->plist))
3232 mark_object (sym->value);
3233 mark_object (sym->function);
3236 * symbol->name is a struct Lisp_String *, not a
3237 * Lisp_Object. Fix it up and pass to mark_object.
3239 Lisp_Object symname;
3240 XSETSTRING(symname, sym->name);
3241 mark_object(symname);
3243 if (!symbol_next (sym))
3248 mark_object (sym->plist);
3249 /* Mark the rest of the symbols in the hash-chain */
3250 sym = symbol_next (sym);
3254 #endif /* !LRECORD_SYMBOL */
3261 /* mark all of the conses in a list and mark the final cdr; but
3262 DO NOT mark the cars.
3264 Use only for internal lists! There should never be other pointers
3265 to the cons cells, because if so, the cars will remain unmarked
3266 even when they maybe should be marked. */
3268 mark_conses_in_list (Lisp_Object obj)
3272 for (rest = obj; CONSP (rest); rest = XCDR (rest))
3274 if (CONS_MARKED_P (XCONS (rest)))
3276 MARK_CONS (XCONS (rest));
3284 /* Simpler than mark-object, because pure structure can't
3285 have any circularities */
3288 static int idiot_c_doesnt_have_closures;
3290 idiot_c (Lisp_Object obj)
3292 idiot_c_doesnt_have_closures += pure_sizeof (obj, 1);
3297 pure_string_sizeof (Lisp_Object obj)
3299 struct Lisp_String *ptr = XSTRING (obj);
3301 if (string_data (ptr) != (Bufbyte *) ptr + sizeof (*ptr))
3303 /* string-data not allocated contiguously.
3304 Probably (better be!!) a pointer constant "C" data. */
3305 return sizeof (*ptr);
3309 size_t size = sizeof (*ptr) + string_length (ptr) + 1;
3310 size = ALIGN_SIZE (size, sizeof (Lisp_Object));
3315 /* recurse arg isn't actually used */
3317 pure_sizeof (Lisp_Object obj /*, int recurse */)
3322 if (!POINTER_TYPE_P (XTYPE (obj))
3323 || !PURIFIED (XPNTR (obj)))
3326 /* symbol's sizes are accounted for separately */
3330 switch (XTYPE (obj))
3333 #ifndef LRECORD_STRING
3334 case Lisp_Type_String:
3335 total += pure_string_sizeof (obj);
3337 #endif /* ! LRECORD_STRING */
3339 #ifndef LRECORD_VECTOR
3340 case Lisp_Type_Vector:
3342 struct Lisp_Vector *ptr = XVECTOR (obj);
3343 int len = vector_length (ptr);
3345 total += (sizeof (struct Lisp_Vector)
3346 + (len - 1) * sizeof (Lisp_Object));
3352 for (i = 0; i < len - 1; i++)
3353 total += pure_sizeof (ptr->contents[i], 1);
3357 obj = ptr->contents[len - 1];
3363 #endif /* !LRECORD_VECTOR */
3365 case Lisp_Type_Record:
3367 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3368 CONST struct lrecord_implementation *implementation
3369 = LHEADER_IMPLEMENTATION (lheader);
3371 #ifdef LRECORD_STRING
3373 total += pure_string_sizeof (obj);
3376 if (implementation->size_in_bytes_method)
3377 total += ((implementation->size_in_bytes_method) (lheader));
3379 total += implementation->static_size;
3385 if (implementation->marker != 0)
3387 int old = idiot_c_doesnt_have_closures;
3389 idiot_c_doesnt_have_closures = 0;
3390 obj = ((implementation->marker) (obj, idiot_c));
3391 total += idiot_c_doesnt_have_closures;
3392 idiot_c_doesnt_have_closures = old;
3394 if (!NILP (obj)) goto tail_recurse;
3400 #ifndef LRECORD_CONS
3401 case Lisp_Type_Cons:
3403 struct Lisp_Cons *ptr = XCONS (obj);
3404 total += sizeof (*ptr);
3408 /* If the cdr is nil, tail-recurse on the car. */
3409 if (NILP (ptr->cdr))
3415 total += pure_sizeof (ptr->car, 1);
3424 /* Others can't be purified */
3430 #endif /* PURESTAT */
3435 /* Find all structures not marked, and free them. */
3437 #ifndef LRECORD_VECTOR
3438 static int gc_count_num_vector_used, gc_count_vector_total_size;
3439 static int gc_count_vector_storage;
3441 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
3442 static int gc_count_bit_vector_storage;
3443 static int gc_count_num_short_string_in_use;
3444 static int gc_count_string_total_size;
3445 static int gc_count_short_string_total_size;
3447 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3450 /* This will be used more extensively In The Future */
3451 static int last_lrecord_type_index_assigned;
3453 CONST struct lrecord_implementation *lrecord_implementations_table[128];
3454 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
3457 lrecord_type_index (CONST struct lrecord_implementation *implementation)
3459 int type_index = *(implementation->lrecord_type_index);
3460 /* Have to do this circuitous validation test because of problems
3461 dumping out initialized variables (ie can't set xxx_type_index to -1
3462 because that would make xxx_type_index read-only in a dumped emacs. */
3463 if (type_index < 0 || type_index > max_lrecord_type
3464 || lrecord_implementations_table[type_index] != implementation)
3466 if (last_lrecord_type_index_assigned == max_lrecord_type)
3468 type_index = ++last_lrecord_type_index_assigned;
3469 lrecord_implementations_table[type_index] = implementation;
3470 *(implementation->lrecord_type_index) = type_index;
3475 /* stats on lcrecords in use - kinda kludgy */
3479 int instances_in_use;
3481 int instances_freed;
3483 int instances_on_free_list;
3484 } lcrecord_stats [countof (lrecord_implementations_table)];
3488 reset_lcrecord_stats (void)
3491 for (i = 0; i < countof (lcrecord_stats); i++)
3493 lcrecord_stats[i].instances_in_use = 0;
3494 lcrecord_stats[i].bytes_in_use = 0;
3495 lcrecord_stats[i].instances_freed = 0;
3496 lcrecord_stats[i].bytes_freed = 0;
3497 lcrecord_stats[i].instances_on_free_list = 0;
3502 tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p)
3504 CONST struct lrecord_implementation *implementation =
3505 LHEADER_IMPLEMENTATION (h);
3506 int type_index = lrecord_type_index (implementation);
3508 if (((struct lcrecord_header *) h)->free)
3511 lcrecord_stats[type_index].instances_on_free_list++;
3515 size_t sz = (implementation->size_in_bytes_method
3516 ? ((implementation->size_in_bytes_method) (h))
3517 : implementation->static_size);
3521 lcrecord_stats[type_index].instances_freed++;
3522 lcrecord_stats[type_index].bytes_freed += sz;
3526 lcrecord_stats[type_index].instances_in_use++;
3527 lcrecord_stats[type_index].bytes_in_use += sz;
3533 /* Free all unmarked records */
3535 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
3537 struct lcrecord_header *header;
3539 /* int total_size = 0; */
3540 reset_lcrecord_stats ();
3542 /* First go through and call all the finalize methods.
3543 Then go through and free the objects. There used to
3544 be only one loop here, with the call to the finalizer
3545 occurring directly before the xfree() below. That
3546 is marginally faster but much less safe -- if the
3547 finalize method for an object needs to reference any
3548 other objects contained within it (and many do),
3549 we could easily be screwed by having already freed that
3552 for (header = *prev; header; header = header->next)
3554 struct lrecord_header *h = &(header->lheader);
3555 if (!MARKED_RECORD_HEADER_P (h) && ! (header->free))
3557 if (LHEADER_IMPLEMENTATION (h)->finalizer)
3558 ((LHEADER_IMPLEMENTATION (h)->finalizer) (h, 0));
3562 for (header = *prev; header; )
3564 struct lrecord_header *h = &(header->lheader);
3565 if (MARKED_RECORD_HEADER_P (h))
3567 UNMARK_RECORD_HEADER (h);
3569 /* total_size += ((n->implementation->size_in_bytes) (h));*/
3570 prev = &(header->next);
3572 tick_lcrecord_stats (h, 0);
3576 struct lcrecord_header *next = header->next;
3578 tick_lcrecord_stats (h, 1);
3579 /* used to call finalizer right here. */
3585 /* *total = total_size; */
3588 #ifndef LRECORD_VECTOR
3591 sweep_vectors_1 (Lisp_Object *prev,
3592 int *used, int *total, int *storage)
3597 int total_storage = 0;
3599 for (vector = *prev; VECTORP (vector); )
3601 struct Lisp_Vector *v = XVECTOR (vector);
3603 if (len < 0) /* marked */
3608 total_storage += (MALLOC_OVERHEAD
3609 + sizeof (struct Lisp_Vector)
3610 + (len - 1 + 1) * sizeof (Lisp_Object));
3612 prev = &(vector_next (v));
3617 Lisp_Object next = vector_next (v);
3624 *total = total_size;
3625 *storage = total_storage;
3628 #endif /* ! LRECORD_VECTOR */
3631 sweep_bit_vectors_1 (Lisp_Object *prev,
3632 int *used, int *total, int *storage)
3634 Lisp_Object bit_vector;
3637 int total_storage = 0;
3639 /* BIT_VECTORP fails because the objects are marked, which changes
3640 their implementation */
3641 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
3643 struct Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
3645 if (MARKED_RECORD_P (bit_vector))
3647 UNMARK_RECORD_HEADER (&(v->lheader));
3649 total_storage += (MALLOC_OVERHEAD
3650 + sizeof (struct Lisp_Bit_Vector)
3651 + (BIT_VECTOR_LONG_STORAGE (len) - 1)
3654 prev = &(bit_vector_next (v));
3659 Lisp_Object next = bit_vector_next (v);
3666 *total = total_size;
3667 *storage = total_storage;
3670 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3671 to make macros prettier. */
3673 #ifdef ERROR_CHECK_GC
3675 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3677 struct typename##_block *_frob_current; \
3678 struct typename##_block **_frob_prev; \
3680 int num_free = 0, num_used = 0; \
3682 for (_frob_prev = ¤t_##typename##_block, \
3683 _frob_current = current_##typename##_block, \
3684 _frob_limit = current_##typename##_block_index; \
3690 for (_frob_iii = 0; _frob_iii < _frob_limit; _frob_iii++) \
3692 obj_type *_frob_victim = &(_frob_current->block[_frob_iii]); \
3694 if (FREE_STRUCT_P (_frob_victim)) \
3698 else if (!MARKED_##typename##_P (_frob_victim)) \
3701 FREE_FIXED_TYPE (typename, obj_type, _frob_victim); \
3706 UNMARK_##typename (_frob_victim); \
3709 _frob_prev = &(_frob_current->prev); \
3710 _frob_current = _frob_current->prev; \
3711 _frob_limit = countof (current_##typename##_block->block); \
3714 gc_count_num_##typename##_in_use = num_used; \
3715 gc_count_num_##typename##_freelist = num_free; \
3718 #else /* !ERROR_CHECK_GC */
3720 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
3722 struct typename##_block *_frob_current; \
3723 struct typename##_block **_frob_prev; \
3725 int num_free = 0, num_used = 0; \
3727 typename##_free_list = 0; \
3729 for (_frob_prev = ¤t_##typename##_block, \
3730 _frob_current = current_##typename##_block, \
3731 _frob_limit = current_##typename##_block_index; \
3736 int _frob_empty = 1; \
3737 obj_type *_frob_old_free_list = typename##_free_list; \
3739 for (_frob_iii = 0; _frob_iii < _frob_limit; _frob_iii++) \
3741 obj_type *_frob_victim = &(_frob_current->block[_frob_iii]); \
3743 if (FREE_STRUCT_P (_frob_victim)) \
3746 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, _frob_victim); \
3748 else if (!MARKED_##typename##_P (_frob_victim)) \
3751 FREE_FIXED_TYPE (typename, obj_type, _frob_victim); \
3757 UNMARK_##typename (_frob_victim); \
3762 _frob_prev = &(_frob_current->prev); \
3763 _frob_current = _frob_current->prev; \
3765 else if (_frob_current == current_##typename##_block \
3766 && !_frob_current->prev) \
3768 /* No real point in freeing sole allocation block */ \
3773 struct typename##_block *_frob_victim_block = _frob_current; \
3774 if (_frob_victim_block == current_##typename##_block) \
3775 current_##typename##_block_index \
3776 = countof (current_##typename##_block->block); \
3777 _frob_current = _frob_current->prev; \
3779 *_frob_prev = _frob_current; \
3780 xfree (_frob_victim_block); \
3781 /* Restore free list to what it was before victim was swept */ \
3782 typename##_free_list = _frob_old_free_list; \
3783 num_free -= _frob_limit; \
3786 _frob_limit = countof (current_##typename##_block->block); \
3789 gc_count_num_##typename##_in_use = num_used; \
3790 gc_count_num_##typename##_freelist = num_free; \
3793 #endif /* !ERROR_CHECK_GC */
3801 #ifndef LRECORD_CONS
3802 # define MARKED_cons_P(ptr) XMARKBIT ((ptr)->car)
3803 # define UNMARK_cons(ptr) do { XUNMARK ((ptr)->car); } while (0)
3804 #else /* LRECORD_CONS */
3805 # define MARKED_cons_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3806 # define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3807 #endif /* LRECORD_CONS */
3808 #define ADDITIONAL_FREE_cons(ptr)
3810 SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons);
3813 /* Explicitly free a cons cell. */
3815 free_cons (struct Lisp_Cons *ptr)
3817 #ifdef ERROR_CHECK_GC
3818 /* If the CAR is not an int, then it will be a pointer, which will
3819 always be four-byte aligned. If this cons cell has already been
3820 placed on the free list, however, its car will probably contain
3821 a chain pointer to the next cons on the list, which has cleverly
3822 had all its 0's and 1's inverted. This allows for a quick
3823 check to make sure we're not freeing something already freed. */
3824 if (POINTER_TYPE_P (XTYPE (ptr->car)))
3825 ASSERT_VALID_POINTER (XPNTR (ptr->car));
3826 #endif /* ERROR_CHECK_GC */
3828 #ifndef ALLOC_NO_POOLS
3829 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, struct Lisp_Cons, ptr);
3830 #endif /* ALLOC_NO_POOLS */
3833 /* explicitly free a list. You **must make sure** that you have
3834 created all the cons cells that make up this list and that there
3835 are no pointers to any of these cons cells anywhere else. If there
3836 are, you will lose. */
3839 free_list (Lisp_Object list)
3841 Lisp_Object rest, next;
3843 for (rest = list; !NILP (rest); rest = next)
3846 free_cons (XCONS (rest));
3850 /* explicitly free an alist. You **must make sure** that you have
3851 created all the cons cells that make up this alist and that there
3852 are no pointers to any of these cons cells anywhere else. If there
3853 are, you will lose. */
3856 free_alist (Lisp_Object alist)
3858 Lisp_Object rest, next;
3860 for (rest = alist; !NILP (rest); rest = next)
3863 free_cons (XCONS (XCAR (rest)));
3864 free_cons (XCONS (rest));
3869 sweep_compiled_functions (void)
3871 #define MARKED_compiled_function_P(ptr) \
3872 MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3873 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3874 #define ADDITIONAL_FREE_compiled_function(ptr)
3876 SWEEP_FIXED_TYPE_BLOCK (compiled_function, struct Lisp_Compiled_Function);
3880 #ifdef LISP_FLOAT_TYPE
3884 #define MARKED_float_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3885 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3886 #define ADDITIONAL_FREE_float(ptr)
3888 SWEEP_FIXED_TYPE_BLOCK (float, struct Lisp_Float);
3890 #endif /* LISP_FLOAT_TYPE */
3893 sweep_symbols (void)
3895 #ifndef LRECORD_SYMBOL
3896 # define MARKED_symbol_P(ptr) XMARKBIT ((ptr)->plist)
3897 # define UNMARK_symbol(ptr) do { XUNMARK ((ptr)->plist); } while (0)
3899 # define MARKED_symbol_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3900 # define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3901 #endif /* !LRECORD_SYMBOL */
3902 #define ADDITIONAL_FREE_symbol(ptr)
3904 SWEEP_FIXED_TYPE_BLOCK (symbol, struct Lisp_Symbol);
3908 sweep_extents (void)
3910 #define MARKED_extent_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3911 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3912 #define ADDITIONAL_FREE_extent(ptr)
3914 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
3920 #define MARKED_event_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3921 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3922 #define ADDITIONAL_FREE_event(ptr)
3924 SWEEP_FIXED_TYPE_BLOCK (event, struct Lisp_Event);
3928 sweep_markers (void)
3930 #define MARKED_marker_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3931 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3932 #define ADDITIONAL_FREE_marker(ptr) \
3933 do { Lisp_Object tem; \
3934 XSETMARKER (tem, ptr); \
3935 unchain_marker (tem); \
3938 SWEEP_FIXED_TYPE_BLOCK (marker, struct Lisp_Marker);
3941 /* Explicitly free a marker. */
3943 free_marker (struct Lisp_Marker *ptr)
3945 #ifdef ERROR_CHECK_GC
3946 /* Perhaps this will catch freeing an already-freed marker. */
3948 XSETMARKER (temmy, ptr);
3949 assert (GC_MARKERP (temmy));
3950 #endif /* ERROR_CHECK_GC */
3952 #ifndef ALLOC_NO_POOLS
3953 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr);
3954 #endif /* ALLOC_NO_POOLS */
3958 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
3961 verify_string_chars_integrity (void)
3963 struct string_chars_block *sb;
3965 /* Scan each existing string block sequentially, string by string. */
3966 for (sb = first_string_chars_block; sb; sb = sb->next)
3969 /* POS is the index of the next string in the block. */
3970 while (pos < sb->pos)
3972 struct string_chars *s_chars =
3973 (struct string_chars *) &(sb->string_chars[pos]);
3974 struct Lisp_String *string;
3978 /* If the string_chars struct is marked as free (i.e. the STRING
3979 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3980 storage. (See below.) */
3982 if (FREE_STRUCT_P (s_chars))
3984 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3989 string = s_chars->string;
3990 /* Must be 32-bit aligned. */
3991 assert ((((int) string) & 3) == 0);
3993 size = string_length (string);
3994 fullsize = STRING_FULLSIZE (size);
3996 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3997 assert (string_data (string) == s_chars->chars);
4000 assert (pos == sb->pos);
4004 #endif /* MULE && ERROR_CHECK_GC */
4006 /* Compactify string chars, relocating the reference to each --
4007 free any empty string_chars_block we see. */
4009 compact_string_chars (void)
4011 struct string_chars_block *to_sb = first_string_chars_block;
4013 struct string_chars_block *from_sb;
4015 /* Scan each existing string block sequentially, string by string. */
4016 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
4019 /* FROM_POS is the index of the next string in the block. */
4020 while (from_pos < from_sb->pos)
4022 struct string_chars *from_s_chars =
4023 (struct string_chars *) &(from_sb->string_chars[from_pos]);
4024 struct string_chars *to_s_chars;
4025 struct Lisp_String *string;
4029 /* If the string_chars struct is marked as free (i.e. the STRING
4030 pointer is 0xFFFFFFFF) then this is an unused chunk of string
4031 storage. This happens under Mule when a string's size changes
4032 in such a way that its fullsize changes. (Strings can change
4033 size because a different-length character can be substituted
4034 for another character.) In this case, after the bogus string
4035 pointer is the "fullsize" of this entry, i.e. how many bytes
4038 if (FREE_STRUCT_P (from_s_chars))
4040 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
4041 from_pos += fullsize;
4045 string = from_s_chars->string;
4046 assert (!(FREE_STRUCT_P (string)));
4048 size = string_length (string);
4049 fullsize = STRING_FULLSIZE (size);
4051 if (BIG_STRING_FULLSIZE_P (fullsize))
4054 /* Just skip it if it isn't marked. */
4055 #ifdef LRECORD_STRING
4056 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
4058 if (!XMARKBIT (string->plist))
4061 from_pos += fullsize;
4065 /* If it won't fit in what's left of TO_SB, close TO_SB out
4066 and go on to the next string_chars_block. We know that TO_SB
4067 cannot advance past FROM_SB here since FROM_SB is large enough
4068 to currently contain this string. */
4069 if ((to_pos + fullsize) > countof (to_sb->string_chars))
4071 to_sb->pos = to_pos;
4072 to_sb = to_sb->next;
4076 /* Compute new address of this string
4077 and update TO_POS for the space being used. */
4078 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
4080 /* Copy the string_chars to the new place. */
4081 if (from_s_chars != to_s_chars)
4082 memmove (to_s_chars, from_s_chars, fullsize);
4084 /* Relocate FROM_S_CHARS's reference */
4085 set_string_data (string, &(to_s_chars->chars[0]));
4087 from_pos += fullsize;
4092 /* Set current to the last string chars block still used and
4093 free any that follow. */
4095 struct string_chars_block *victim;
4097 for (victim = to_sb->next; victim; )
4099 struct string_chars_block *next = victim->next;
4104 current_string_chars_block = to_sb;
4105 current_string_chars_block->pos = to_pos;
4106 current_string_chars_block->next = 0;
4110 #if 1 /* Hack to debug missing purecopy's */
4111 static int debug_string_purity;
4114 debug_string_purity_print (struct Lisp_String *p)
4117 Charcount s = string_char_length (p);
4118 putc ('\"', stderr);
4119 for (i = 0; i < s; i++)
4121 Emchar ch = string_char (p, i);
4122 if (ch < 32 || ch >= 126)
4123 stderr_out ("\\%03o", ch);
4124 else if (ch == '\\' || ch == '\"')
4125 stderr_out ("\\%c", ch);
4127 stderr_out ("%c", ch);
4129 stderr_out ("\"\n");
4135 sweep_strings (void)
4137 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
4138 int debug = debug_string_purity;
4140 #ifdef LRECORD_STRING
4142 # define MARKED_string_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
4143 # define UNMARK_string(ptr) \
4144 do { struct Lisp_String *p = (ptr); \
4145 int size = string_length (p); \
4146 UNMARK_RECORD_HEADER (&(p->lheader)); \
4147 num_bytes += size; \
4148 if (!BIG_STRING_SIZE_P (size)) \
4149 { num_small_bytes += size; \
4152 if (debug) debug_string_purity_print (p); \
4154 # define ADDITIONAL_FREE_string(p) \
4155 do { int size = string_length (p); \
4156 if (BIG_STRING_SIZE_P (size)) \
4157 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
4162 # define MARKED_string_P(ptr) XMARKBIT ((ptr)->plist)
4163 # define UNMARK_string(ptr) \
4164 do { struct Lisp_String *p = (ptr); \
4165 int size = string_length (p); \
4166 XUNMARK (p->plist); \
4167 num_bytes += size; \
4168 if (!BIG_STRING_SIZE_P (size)) \
4169 { num_small_bytes += size; \
4172 if (debug) debug_string_purity_print (p); \
4174 # define ADDITIONAL_FREE_string(p) \
4175 do { int size = string_length (p); \
4176 if (BIG_STRING_SIZE_P (size)) \
4177 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
4180 #endif /* ! LRECORD_STRING */
4182 SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String);
4184 gc_count_num_short_string_in_use = num_small_used;
4185 gc_count_string_total_size = num_bytes;
4186 gc_count_short_string_total_size = num_small_bytes;
4190 /* I hate duplicating all this crap! */
4192 marked_p (Lisp_Object obj)
4194 if (EQ (obj, Qnull_pointer)) return 1;
4195 if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1;
4196 if (PURIFIED (XPNTR (obj))) return 1;
4197 switch (XGCTYPE (obj))
4199 #ifndef LRECORD_CONS
4200 case Lisp_Type_Cons:
4201 return XMARKBIT (XCAR (obj));
4203 case Lisp_Type_Record:
4204 return MARKED_RECORD_HEADER_P (XRECORD_LHEADER (obj));
4205 #ifndef LRECORD_STRING
4206 case Lisp_Type_String:
4207 return XMARKBIT (XSTRING (obj)->plist);
4208 #endif /* ! LRECORD_STRING */
4209 #ifndef LRECORD_VECTOR
4210 case Lisp_Type_Vector:
4211 return XVECTOR_LENGTH (obj) < 0;
4212 #endif /* !LRECORD_VECTOR */
4213 #ifndef LRECORD_SYMBOL
4214 case Lisp_Type_Symbol:
4215 return XMARKBIT (XSYMBOL (obj)->plist);
4220 return 0; /* suppress compiler warning */
4226 /* Free all unmarked records. Do this at the very beginning,
4227 before anything else, so that the finalize methods can safely
4228 examine items in the objects. sweep_lcrecords_1() makes
4229 sure to call all the finalize methods *before* freeing anything,
4230 to complete the safety. */
4233 sweep_lcrecords_1 (&all_lcrecords, &ignored);
4236 compact_string_chars ();
4238 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
4239 macros) must be *extremely* careful to make sure they're not
4240 referencing freed objects. The only two existing finalize
4241 methods (for strings and markers) pass muster -- the string
4242 finalizer doesn't look at anything but its own specially-
4243 created block, and the marker finalizer only looks at live
4244 buffers (which will never be freed) and at the markers before
4245 and after it in the chain (which, by induction, will never be
4246 freed because if so, they would have already removed themselves
4249 /* Put all unmarked strings on free list, free'ing the string chars
4250 of large unmarked strings */
4253 /* Put all unmarked conses on free list */
4256 #ifndef LRECORD_VECTOR
4257 /* Free all unmarked vectors */
4258 sweep_vectors_1 (&all_vectors,
4259 &gc_count_num_vector_used, &gc_count_vector_total_size,
4260 &gc_count_vector_storage);
4263 /* Free all unmarked bit vectors */
4264 sweep_bit_vectors_1 (&all_bit_vectors,
4265 &gc_count_num_bit_vector_used,
4266 &gc_count_bit_vector_total_size,
4267 &gc_count_bit_vector_storage);
4269 /* Free all unmarked compiled-function objects */
4270 sweep_compiled_functions ();
4272 #ifdef LISP_FLOAT_TYPE
4273 /* Put all unmarked floats on free list */
4277 /* Put all unmarked symbols on free list */
4280 /* Put all unmarked extents on free list */
4283 /* Put all unmarked markers on free list.
4284 Dechain each one first from the buffer into which it points. */
4291 /* Clearing for disksave. */
4294 disksave_object_finalization (void)
4296 /* It's important that certain information from the environment not get
4297 dumped with the executable (pathnames, environment variables, etc.).
4298 To make it easier to tell when this has happend with strings(1) we
4299 clear some known-to-be-garbage blocks of memory, so that leftover
4300 results of old evaluation don't look like potential problems.
4301 But first we set some notable variables to nil and do one more GC,
4302 to turn those strings into garbage.
4305 /* Yeah, this list is pretty ad-hoc... */
4306 Vprocess_environment = Qnil;
4307 Vexec_directory = Qnil;
4308 Vdata_directory = Qnil;
4309 Vsite_directory = Qnil;
4310 Vdoc_directory = Qnil;
4311 Vconfigure_info_directory = Qnil;
4314 /* Vdump_load_path = Qnil; */
4315 uncache_home_directory();
4317 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
4318 defined(LOADHIST_BUILTIN))
4319 Vload_history = Qnil;
4321 Vshell_file_name = Qnil;
4323 garbage_collect_1 ();
4325 /* Run the disksave finalization methods of all live objects. */
4326 disksave_object_finalization_1 ();
4328 #if 0 /* I don't see any point in this. The purespace starts out all 0's */
4329 /* Zero out the unused portion of purespace */
4331 memset ( (char *) (PUREBEG + pure_bytes_used), 0,
4332 (((char *) (PUREBEG + get_PURESIZE())) -
4333 ((char *) (PUREBEG + pure_bytes_used))));
4336 /* Zero out the uninitialized (really, unused) part of the containers
4337 for the live strings. */
4339 struct string_chars_block *scb;
4340 for (scb = first_string_chars_block; scb; scb = scb->next)
4342 int count = sizeof (scb->string_chars) - scb->pos;
4344 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
4346 /* from the block's fill ptr to the end */
4347 memset ((scb->string_chars + scb->pos), 0, count);
4352 /* There, that ought to be enough... */
4358 restore_gc_inhibit (Lisp_Object val)
4360 gc_currently_forbidden = XINT (val);
4364 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
4365 static int gc_hooks_inhibited;
4369 garbage_collect_1 (void)
4371 char stack_top_variable;
4372 extern char *stack_bottom;
4377 Lisp_Object pre_gc_cursor;
4378 struct gcpro gcpro1;
4381 || gc_currently_forbidden
4383 || preparing_for_armageddon)
4386 pre_gc_cursor = Qnil;
4389 /* This function cannot be called inside GC so we move to after the */
4391 f = selected_frame ();
4393 GCPRO1 (pre_gc_cursor);
4395 /* Very important to prevent GC during any of the following
4396 stuff that might run Lisp code; otherwise, we'll likely
4397 have infinite GC recursion. */
4398 speccount = specpdl_depth ();
4399 record_unwind_protect (restore_gc_inhibit,
4400 make_int (gc_currently_forbidden));
4401 gc_currently_forbidden = 1;
4403 if (!gc_hooks_inhibited)
4404 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
4406 /* Now show the GC cursor/message. */
4407 if (!noninteractive)
4409 if (FRAME_WIN_P (f))
4411 Lisp_Object frame = make_frame (f);
4412 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
4413 FRAME_SELECTED_WINDOW (f),
4415 pre_gc_cursor = f->pointer;
4416 if (POINTER_IMAGE_INSTANCEP (cursor)
4417 /* don't change if we don't know how to change back. */
4418 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
4421 Fset_frame_pointer (frame, cursor);
4425 /* Don't print messages to the stream device. */
4426 if (!cursor_changed && !FRAME_STREAM_P (f))
4428 char *msg = (STRINGP (Vgc_message)
4429 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
4431 Lisp_Object args[2], whole_msg;
4432 args[0] = build_string (msg ? msg :
4433 GETTEXT ((CONST char *) gc_default_message));
4434 args[1] = build_string ("...");
4435 whole_msg = Fconcat (2, args);
4436 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
4437 Qgarbage_collecting);
4441 /***** Now we actually start the garbage collection. */
4445 gc_generation_number[0]++;
4447 #if MAX_SAVE_STACK > 0
4449 /* Save a copy of the contents of the stack, for debugging. */
4452 /* Static buffer in which we save a copy of the C stack at each GC. */
4453 static char *stack_copy;
4454 static size_t stack_copy_size;
4456 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
4457 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
4458 if (stack_size < MAX_SAVE_STACK)
4460 if (stack_copy_size < stack_size)
4462 stack_copy = (char *) xrealloc (stack_copy, stack_size);
4463 stack_copy_size = stack_size;
4467 stack_diff > 0 ? stack_bottom : &stack_top_variable,
4471 #endif /* MAX_SAVE_STACK > 0 */
4473 /* Do some totally ad-hoc resource clearing. */
4474 /* #### generalize this? */
4475 clear_event_resource ();
4476 cleanup_specifiers ();
4478 /* Mark all the special slots that serve as the roots of accessibility. */
4481 struct catchtag *catch;
4482 struct backtrace *backlist;
4483 struct specbinding *bind;
4485 for (i = 0; i < staticidx; i++)
4489 debug_print (*staticvec[i]);
4491 mark_object (*(staticvec[i]));
4494 for (tail = gcprolist; tail; tail = tail->next)
4496 for (i = 0; i < tail->nvars; i++)
4497 mark_object (tail->var[i]);
4500 for (bind = specpdl; bind != specpdl_ptr; bind++)
4502 mark_object (bind->symbol);
4503 mark_object (bind->old_value);
4506 for (catch = catchlist; catch; catch = catch->next)
4508 mark_object (catch->tag);
4509 mark_object (catch->val);
4512 for (backlist = backtrace_list; backlist; backlist = backlist->next)
4514 int nargs = backlist->nargs;
4516 mark_object (*backlist->function);
4517 if (nargs == UNEVALLED || nargs == MANY)
4518 mark_object (backlist->args[0]);
4520 for (i = 0; i < nargs; i++)
4521 mark_object (backlist->args[i]);
4524 mark_redisplay (mark_object);
4525 mark_profiling_info (mark_object);
4528 /* OK, now do the after-mark stuff. This is for things that
4529 are only marked when something else is marked (e.g. weak hashtables).
4530 There may be complex dependencies between such objects -- e.g.
4531 a weak hashtable might be unmarked, but after processing a later
4532 weak hashtable, the former one might get marked. So we have to
4533 iterate until nothing more gets marked. */
4536 /* Need to iterate until there's nothing more to mark, in case
4537 of chains of mark dependencies. */
4541 did_mark += !!finish_marking_weak_hashtables (marked_p, mark_object);
4542 did_mark += !!finish_marking_weak_lists (marked_p, mark_object);
4547 /* And prune (this needs to be called after everything else has been
4548 marked and before we do any sweeping). */
4549 /* #### this is somewhat ad-hoc and should probably be an object
4551 prune_weak_hashtables (marked_p);
4552 prune_weak_lists (marked_p);
4553 prune_specifiers (marked_p);
4554 prune_syntax_tables (marked_p);
4558 consing_since_gc = 0;
4559 #ifndef DEBUG_XEMACS
4560 /* Allow you to set it really fucking low if you really want ... */
4561 if (gc_cons_threshold < 10000)
4562 gc_cons_threshold = 10000;
4567 /******* End of garbage collection ********/
4569 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
4571 /* Now remove the GC cursor/message */
4572 if (!noninteractive)
4575 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
4576 else if (!FRAME_STREAM_P (f))
4578 char *msg = (STRINGP (Vgc_message)
4579 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
4582 /* Show "...done" only if the echo area would otherwise be empty. */
4583 if (NILP (clear_echo_area (selected_frame (),
4584 Qgarbage_collecting, 0)))
4586 Lisp_Object args[2], whole_msg;
4587 args[0] = build_string (msg ? msg :
4588 GETTEXT ((CONST char *)
4589 gc_default_message));
4590 args[1] = build_string ("... done");
4591 whole_msg = Fconcat (2, args);
4592 echo_area_message (selected_frame (), (Bufbyte *) 0,
4594 Qgarbage_collecting);
4599 /* now stop inhibiting GC */
4600 unbind_to (speccount, Qnil);
4602 if (!breathing_space)
4604 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
4612 /* This isn't actually called. BTL recognizes the stack frame of the top
4613 of the garbage collector by noting that PC is between &garbage_collect_1
4614 and &BTL_after_garbage_collect_1_stub. So this fn must be right here.
4615 There's not any other way to know the address of the end of a function.
4617 void BTL_after_garbage_collect_1_stub () { abort (); }
4618 #endif /* EMACS_BTL */
4620 /* Debugging aids. */
4623 gc_plist_hack (CONST char *name, int value, Lisp_Object tail)
4625 /* C doesn't have local functions (or closures, or GC, or readable syntax,
4626 or portable numeric datatypes, or bit-vectors, or characters, or
4627 arrays, or exceptions, or ...) */
4628 return cons3 (intern (name), make_int (value), tail);
4631 #define HACK_O_MATIC(type, name, pl) \
4634 struct type##_block *x = current_##type##_block; \
4635 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
4636 (pl) = gc_plist_hack ((name), s, (pl)); \
4639 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
4640 Reclaim storage for Lisp objects no longer needed.
4641 Return info on amount of space in use:
4642 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4643 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4645 where `PLIST' is a list of alternating keyword/value pairs providing
4646 more detailed information.
4647 Garbage collection happens automatically if you cons more than
4648 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4652 Lisp_Object pl = Qnil;
4654 #ifdef LRECORD_VECTOR
4655 int gc_count_vector_total_size = 0;
4658 if (purify_flag && pure_lossage)
4661 garbage_collect_1 ();
4663 for (i = 0; i < last_lrecord_type_index_assigned; i++)
4665 if (lcrecord_stats[i].bytes_in_use != 0
4666 || lcrecord_stats[i].bytes_freed != 0
4667 || lcrecord_stats[i].instances_on_free_list != 0)
4670 CONST char *name = lrecord_implementations_table[i]->name;
4671 int len = strlen (name);
4672 #ifdef LRECORD_VECTOR
4673 /* save this for the FSFmacs-compatible part of the summary */
4674 if (i == *lrecord_vector[0].lrecord_type_index)
4675 gc_count_vector_total_size =
4676 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
4678 sprintf (buf, "%s-storage", name);
4679 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
4680 /* Okay, simple pluralization check for `symbol-value-varalias' */
4681 if (name[len-1] == 's')
4682 sprintf (buf, "%ses-freed", name);
4684 sprintf (buf, "%ss-freed", name);
4685 if (lcrecord_stats[i].instances_freed != 0)
4686 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
4687 if (name[len-1] == 's')
4688 sprintf (buf, "%ses-on-free-list", name);
4690 sprintf (buf, "%ss-on-free-list", name);
4691 if (lcrecord_stats[i].instances_on_free_list != 0)
4692 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
4694 if (name[len-1] == 's')
4695 sprintf (buf, "%ses-used", name);
4697 sprintf (buf, "%ss-used", name);
4698 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
4702 HACK_O_MATIC (extent, "extent-storage", pl);
4703 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
4704 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
4705 HACK_O_MATIC (event, "event-storage", pl);
4706 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
4707 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
4708 HACK_O_MATIC (marker, "marker-storage", pl);
4709 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
4710 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
4711 #ifdef LISP_FLOAT_TYPE
4712 HACK_O_MATIC (float, "float-storage", pl);
4713 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
4714 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
4715 #endif /* LISP_FLOAT_TYPE */
4716 HACK_O_MATIC (string, "string-header-storage", pl);
4717 pl = gc_plist_hack ("long-strings-total-length",
4718 gc_count_string_total_size
4719 - gc_count_short_string_total_size, pl);
4720 HACK_O_MATIC (string_chars, "short-string-storage", pl);
4721 pl = gc_plist_hack ("short-strings-total-length",
4722 gc_count_short_string_total_size, pl);
4723 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
4724 pl = gc_plist_hack ("long-strings-used",
4725 gc_count_num_string_in_use
4726 - gc_count_num_short_string_in_use, pl);
4727 pl = gc_plist_hack ("short-strings-used",
4728 gc_count_num_short_string_in_use, pl);
4730 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
4731 pl = gc_plist_hack ("compiled-functions-free",
4732 gc_count_num_compiled_function_freelist, pl);
4733 pl = gc_plist_hack ("compiled-functions-used",
4734 gc_count_num_compiled_function_in_use, pl);
4736 #ifndef LRECORD_VECTOR
4737 pl = gc_plist_hack ("vector-storage", gc_count_vector_storage, pl);
4738 pl = gc_plist_hack ("vectors-total-length",
4739 gc_count_vector_total_size, pl);
4740 pl = gc_plist_hack ("vectors-used", gc_count_num_vector_used, pl);
4743 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
4744 pl = gc_plist_hack ("bit-vectors-total-length",
4745 gc_count_bit_vector_total_size, pl);
4746 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
4748 HACK_O_MATIC (symbol, "symbol-storage", pl);
4749 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
4750 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
4752 HACK_O_MATIC (cons, "cons-storage", pl);
4753 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
4754 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
4756 /* The things we do for backwards-compatibility */
4758 list6 (Fcons (make_int (gc_count_num_cons_in_use),
4759 make_int (gc_count_num_cons_freelist)),
4760 Fcons (make_int (gc_count_num_symbol_in_use),
4761 make_int (gc_count_num_symbol_freelist)),
4762 Fcons (make_int (gc_count_num_marker_in_use),
4763 make_int (gc_count_num_marker_freelist)),
4764 make_int (gc_count_string_total_size),
4765 make_int (gc_count_vector_total_size),
4770 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
4771 Return the number of bytes consed since the last garbage collection.
4772 \"Consed\" is a misnomer in that this actually counts allocation
4773 of all different kinds of objects, not just conses.
4775 If this value exceeds `gc-cons-threshold', a garbage collection happens.
4779 return make_int (consing_since_gc);
4782 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
4783 Return the address of the last byte Emacs has allocated, divided by 1024.
4784 This may be helpful in debugging Emacs's memory usage.
4785 The value is divided by 1024 to make sure it will fit in a lisp integer.
4789 return make_int ((EMACS_INT) sbrk (0) / 1024);
4795 object_dead_p (Lisp_Object obj)
4797 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
4798 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
4799 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
4800 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
4801 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
4802 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
4803 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
4806 #ifdef MEMORY_USAGE_STATS
4808 /* Attempt to determine the actual amount of space that is used for
4809 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
4811 It seems that the following holds:
4813 1. When using the old allocator (malloc.c):
4815 -- blocks are always allocated in chunks of powers of two. For
4816 each block, there is an overhead of 8 bytes if rcheck is not
4817 defined, 20 bytes if it is defined. In other words, a
4818 one-byte allocation needs 8 bytes of overhead for a total of
4819 9 bytes, and needs to have 16 bytes of memory chunked out for
4822 2. When using the new allocator (gmalloc.c):
4824 -- blocks are always allocated in chunks of powers of two up
4825 to 4096 bytes. Larger blocks are allocated in chunks of
4826 an integral multiple of 4096 bytes. The minimum block
4827 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
4828 is defined. There is no per-block overhead, but there
4829 is an overhead of 3*sizeof (size_t) for each 4096 bytes
4832 3. When using the system malloc, anything goes, but they are
4833 generally slower and more space-efficient than the GNU
4834 allocators. One possibly reasonable assumption to make
4835 for want of better data is that sizeof (void *), or maybe
4836 2 * sizeof (void *), is required as overhead and that
4837 blocks are allocated in the minimum required size except
4838 that some minimum block size is imposed (e.g. 16 bytes). */
4841 malloced_storage_size (void *ptr, size_t claimed_size,
4842 struct overhead_stats *stats)
4844 size_t orig_claimed_size = claimed_size;
4848 if (claimed_size < 2 * sizeof (void *))
4849 claimed_size = 2 * sizeof (void *);
4850 # ifdef SUNOS_LOCALTIME_BUG
4851 if (claimed_size < 16)
4854 if (claimed_size < 4096)
4858 /* compute the log base two, more or less, then use it to compute
4859 the block size needed. */
4861 /* It's big, it's heavy, it's wood! */
4862 while ((claimed_size /= 2) != 0)
4865 /* It's better than bad, it's good! */
4871 /* We have to come up with some average about the amount of
4873 if ((size_t) (rand () & 4095) < claimed_size)
4874 claimed_size += 3 * sizeof (void *);
4878 claimed_size += 4095;
4879 claimed_size &= ~4095;
4880 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
4883 #elif defined (SYSTEM_MALLOC)
4885 if (claimed_size < 16)
4887 claimed_size += 2 * sizeof (void *);
4889 #else /* old GNU allocator */
4891 # ifdef rcheck /* #### may not be defined here */
4899 /* compute the log base two, more or less, then use it to compute
4900 the block size needed. */
4902 /* It's big, it's heavy, it's wood! */
4903 while ((claimed_size /= 2) != 0)
4906 /* It's better than bad, it's good! */
4914 #endif /* old GNU allocator */
4918 stats->was_requested += orig_claimed_size;
4919 stats->malloc_overhead += claimed_size - orig_claimed_size;
4921 return claimed_size;
4925 fixed_type_block_overhead (size_t size)
4927 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
4928 size_t overhead = 0;
4929 size_t storage_size = malloced_storage_size (0, per_block, 0);
4930 while (size >= per_block)
4933 overhead += sizeof (void *) + per_block - storage_size;
4935 if (rand () % per_block < size)
4936 overhead += sizeof (void *) + per_block - storage_size;
4940 #endif /* MEMORY_USAGE_STATS */
4943 /* Initialization */
4945 init_alloc_once_early (void)
4950 for (iii = 0; iii < countof (purestats); iii++)
4952 if (! purestats[iii]) continue;
4953 purestats[iii]->nobjects = 0;
4954 purestats[iii]->nbytes = 0;
4956 purecopying_for_bytecode = 0;
4957 #endif /* PURESTAT */
4959 last_lrecord_type_index_assigned = -1;
4960 for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
4962 lrecord_implementations_table[iii] = 0;
4965 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
4967 * If USE_INDEXED_LRECORD_IMPLEMENTATION is defined, all the staticly
4968 * defined subr lrecords were initialized with lheader->type == 0.
4969 * See subr_lheader_initializer in lisp.h. Force type index 0 to be
4970 * assigned to lrecord_subr so that those predefined indexes match
4973 lrecord_type_index (lrecord_subr);
4974 assert (*(lrecord_subr[0].lrecord_type_index) == 0);
4976 * The same is true for symbol_value_forward objects, except the
4979 lrecord_type_index (lrecord_symbol_value_forward);
4980 assert (*(lrecord_symbol_value_forward[0].lrecord_type_index) == 1);
4981 #endif /* USE_INDEXED_LRECORD_IMPLEMENTATION */
4983 symbols_initialized = 0;
4985 gc_generation_number[0] = 0;
4986 /* purify_flag 1 is correct even if CANNOT_DUMP.
4987 * loadup.el will set to nil at end. */
4989 pure_bytes_used = 0;
4991 breathing_space = 0;
4992 #ifndef LRECORD_VECTOR
4993 XSETINT (all_vectors, 0); /* Qzero may not be set yet. */
4995 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
4996 XSETINT (Vgc_message, 0);
4998 ignore_malloc_warnings = 1;
4999 #ifdef DOUG_LEA_MALLOC
5000 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
5001 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
5002 #if 0 /* Moved to emacs.c */
5003 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
5006 init_string_alloc ();
5007 init_string_chars_alloc ();
5009 init_symbol_alloc ();
5010 init_compiled_function_alloc ();
5011 #ifdef LISP_FLOAT_TYPE
5012 init_float_alloc ();
5013 #endif /* LISP_FLOAT_TYPE */
5014 init_marker_alloc ();
5015 init_extent_alloc ();
5016 init_event_alloc ();
5018 ignore_malloc_warnings = 0;
5020 consing_since_gc = 0;
5022 gc_cons_threshold = 500000; /* XEmacs change */
5024 gc_cons_threshold = 15000; /* debugging */
5026 #ifdef VIRT_ADDR_VARIES
5027 malloc_sbrk_unused = 1<<22; /* A large number */
5028 malloc_sbrk_used = 100000; /* as reasonable as any number */
5029 #endif /* VIRT_ADDR_VARIES */
5030 lrecord_uid_counter = 259;
5031 debug_string_purity = 0;
5034 gc_currently_forbidden = 0;
5035 gc_hooks_inhibited = 0;
5037 #ifdef ERROR_CHECK_TYPECHECK
5038 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5041 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
5043 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5045 #endif /* ERROR_CHECK_TYPECHECK */
5055 syms_of_alloc (void)
5057 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
5058 defsymbol (&Qpost_gc_hook, "post-gc-hook");
5059 defsymbol (&Qgarbage_collecting, "garbage-collecting");
5064 DEFSUBR (Fbit_vector);
5065 DEFSUBR (Fmake_byte_code);
5066 DEFSUBR (Fmake_list);
5067 DEFSUBR (Fmake_vector);
5068 DEFSUBR (Fmake_bit_vector);
5069 DEFSUBR (Fmake_string);
5071 DEFSUBR (Fmake_symbol);
5072 DEFSUBR (Fmake_marker);
5073 DEFSUBR (Fpurecopy);
5074 DEFSUBR (Fgarbage_collect);
5075 DEFSUBR (Fmemory_limit);
5076 DEFSUBR (Fconsing_since_gc);
5080 vars_of_alloc (void)
5082 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
5083 *Number of bytes of consing between garbage collections.
5084 \"Consing\" is a misnomer in that this actually counts allocation
5085 of all different kinds of objects, not just conses.
5086 Garbage collection can happen automatically once this many bytes have been
5087 allocated since the last garbage collection. All data types count.
5089 Garbage collection happens automatically when `eval' or `funcall' are
5090 called. (Note that `funcall' is called implicitly as part of evaluation.)
5091 By binding this temporarily to a large number, you can effectively
5092 prevent garbage collection during a part of the program.
5094 See also `consing-since-gc'.
5097 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
5098 Number of bytes of sharable Lisp data allocated so far.
5102 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
5103 Number of bytes of unshared memory allocated in this session.
5106 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
5107 Number of bytes of unshared memory remaining available in this session.
5112 DEFVAR_INT ("debug-allocation", &debug_allocation /*
5113 If non-zero, print out information to stderr about all objects allocated.
5114 See also `debug-allocation-backtrace-length'.
5116 debug_allocation = 0;
5118 DEFVAR_INT ("debug-allocation-backtrace-length",
5119 &debug_allocation_backtrace_length /*
5120 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
5122 debug_allocation_backtrace_length = 2;
5125 DEFVAR_BOOL ("purify-flag", &purify_flag /*
5126 Non-nil means loading Lisp code in order to dump an executable.
5127 This means that certain objects should be allocated in shared (pure) space.
5130 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
5131 Function or functions to be run just before each garbage collection.
5132 Interrupts, garbage collection, and errors are inhibited while this hook
5133 runs, so be extremely careful in what you add here. In particular, avoid
5134 consing, and do not interact with the user.
5136 Vpre_gc_hook = Qnil;
5138 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
5139 Function or functions to be run just after each garbage collection.
5140 Interrupts, garbage collection, and errors are inhibited while this hook
5141 runs, so be extremely careful in what you add here. In particular, avoid
5142 consing, and do not interact with the user.
5144 Vpost_gc_hook = Qnil;
5146 DEFVAR_LISP ("gc-message", &Vgc_message /*
5147 String to print to indicate that a garbage collection is in progress.
5148 This is printed in the echo area. If the selected frame is on a
5149 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
5150 image instance) in the domain of the selected frame, the mouse pointer
5151 will change instead of this message being printed.
5153 Vgc_message = make_pure_string ((CONST Bufbyte *) gc_default_message,
5154 countof (gc_default_message) - 1,
5157 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
5158 Pointer glyph used to indicate that a garbage collection is in progress.
5159 If the selected window is on a window system and this glyph specifies a
5160 value (i.e. a pointer image instance) in the domain of the selected
5161 window, the pointer will be changed as specified during garbage collection.
5162 Otherwise, a message will be printed in the echo area, as controlled
5168 complex_vars_of_alloc (void)
5170 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);