1 /* Storage allocation and gc for XEmacs Lisp interpreter.
2 Copyright (C) 1985-1998 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
4 Copyright (C) 1995, 1996 Ben Wing.
6 This file is part of XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from
28 FSF: Original version; a long time ago.
29 Mly: Significantly rewritten to use new 3-bit tags and
30 nicely abstracted object definitions, for 19.8.
31 JWZ: Improved code to keep track of purespace usage and
32 issue nice purespace and GC stats.
33 Ben Wing: Cleaned up frob-block lrecord code, added error-checking
34 and various changes for Mule, for 19.12.
35 Added bit vectors for 19.13.
36 Added lcrecord lists for 19.14.
37 slb: Lots of work on the purification and dump time code.
38 Synched Doug Lea malloc support from Emacs 20.2.
39 og: Killed the purespace. Portable dumper.
45 #include "backtrace.h"
56 #include "redisplay.h"
57 #include "specifier.h"
60 #include "console-stream.h"
62 #ifdef DOUG_LEA_MALLOC
74 const struct lrecord_description *desc;
78 static char *pdump_rt_list = 0;
81 EXFUN (Fgarbage_collect, 0);
83 #if 0 /* this is _way_ too slow to be part of the standard debug options */
84 #if defined(DEBUG_XEMACS) && defined(MULE)
85 #define VERIFY_STRING_CHARS_INTEGRITY
89 /* Define this to use malloc/free with no freelist for all datatypes,
90 the hope being that some debugging tools may help detect
91 freed memory references */
92 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
94 #define ALLOC_NO_POOLS
98 static int debug_allocation;
99 static int debug_allocation_backtrace_length;
102 /* Number of bytes of consing done since the last gc */
103 EMACS_INT consing_since_gc;
104 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
106 #define debug_allocation_backtrace() \
108 if (debug_allocation_backtrace_length > 0) \
109 debug_short_backtrace (debug_allocation_backtrace_length); \
113 #define INCREMENT_CONS_COUNTER(foosize, type) \
115 if (debug_allocation) \
117 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
118 debug_allocation_backtrace (); \
120 INCREMENT_CONS_COUNTER_1 (foosize); \
122 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
124 if (debug_allocation > 1) \
126 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
127 debug_allocation_backtrace (); \
129 INCREMENT_CONS_COUNTER_1 (foosize); \
132 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
133 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
134 INCREMENT_CONS_COUNTER_1 (size)
137 #define DECREMENT_CONS_COUNTER(size) do { \
138 consing_since_gc -= (size); \
139 if (consing_since_gc < 0) \
140 consing_since_gc = 0; \
143 /* Number of bytes of consing since gc before another gc should be done. */
144 EMACS_INT gc_cons_threshold;
146 /* Nonzero during gc */
149 /* Number of times GC has happened at this level or below.
150 * Level 0 is most volatile, contrary to usual convention.
151 * (Of course, there's only one level at present) */
152 EMACS_INT gc_generation_number[1];
154 /* This is just for use by the printer, to allow things to print uniquely */
155 static int lrecord_uid_counter;
157 /* Nonzero when calling certain hooks or doing other things where
159 int gc_currently_forbidden;
162 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
163 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
165 /* "Garbage collecting" */
166 Lisp_Object Vgc_message;
167 Lisp_Object Vgc_pointer_glyph;
168 static const char gc_default_message[] = "Garbage collecting";
169 Lisp_Object Qgarbage_collecting;
171 #ifndef VIRT_ADDR_VARIES
173 #endif /* VIRT_ADDR_VARIES */
174 EMACS_INT malloc_sbrk_used;
176 #ifndef VIRT_ADDR_VARIES
178 #endif /* VIRT_ADDR_VARIES */
179 EMACS_INT malloc_sbrk_unused;
181 /* Non-zero means we're in the process of doing the dump */
184 #ifdef ERROR_CHECK_TYPECHECK
186 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
191 c_readonly (Lisp_Object obj)
193 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
197 lisp_readonly (Lisp_Object obj)
199 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
203 /* Maximum amount of C stack to save when a GC happens. */
205 #ifndef MAX_SAVE_STACK
206 #define MAX_SAVE_STACK 0 /* 16000 */
209 /* Non-zero means ignore malloc warnings. Set during initialization. */
210 int ignore_malloc_warnings;
213 static void *breathing_space;
216 release_breathing_space (void)
220 void *tmp = breathing_space;
226 /* malloc calls this if it finds we are near exhausting storage */
228 malloc_warning (const char *str)
230 if (ignore_malloc_warnings)
236 "Killing some buffers may delay running out of memory.\n"
237 "However, certainly by the time you receive the 95%% warning,\n"
238 "you should clean up, kill this Emacs, and start a new one.",
242 /* Called if malloc returns zero */
246 /* Force a GC next time eval is called.
247 It's better to loop garbage-collecting (we might reclaim enough
248 to win) than to loop beeping and barfing "Memory exhausted"
250 consing_since_gc = gc_cons_threshold + 1;
251 release_breathing_space ();
253 /* Flush some histories which might conceivably contain garbalogical
255 if (!NILP (Fboundp (Qvalues)))
256 Fset (Qvalues, Qnil);
257 Vcommand_history = Qnil;
259 error ("Memory exhausted");
262 /* like malloc and realloc but check for no memory left, and block input. */
266 xmalloc (size_t size)
268 void *val = malloc (size);
270 if (!val && (size != 0)) memory_full ();
276 xcalloc (size_t nelem, size_t elsize)
278 void *val = calloc (nelem, elsize);
280 if (!val && (nelem != 0)) memory_full ();
285 xmalloc_and_zero (size_t size)
287 return xcalloc (size, sizeof (char));
292 xrealloc (void *block, size_t size)
294 /* We must call malloc explicitly when BLOCK is 0, since some
295 reallocs don't do this. */
296 void *val = block ? realloc (block, size) : malloc (size);
298 if (!val && (size != 0)) memory_full ();
303 #ifdef ERROR_CHECK_MALLOC
304 xfree_1 (void *block)
309 #ifdef ERROR_CHECK_MALLOC
310 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
311 error until much later on for many system mallocs, such as
312 the one that comes with Solaris 2.3. FMH!! */
313 assert (block != (void *) 0xDEADBEEF);
315 #endif /* ERROR_CHECK_MALLOC */
319 #ifdef ERROR_CHECK_GC
322 typedef unsigned int four_byte_t;
323 #elif SIZEOF_LONG == 4
324 typedef unsigned long four_byte_t;
325 #elif SIZEOF_SHORT == 4
326 typedef unsigned short four_byte_t;
328 What kind of strange-ass system are we running on?
332 deadbeef_memory (void *ptr, size_t size)
334 four_byte_t *ptr4 = (four_byte_t *) ptr;
335 size_t beefs = size >> 2;
337 /* In practice, size will always be a multiple of four. */
339 (*ptr4++) = 0xDEADBEEF;
342 #else /* !ERROR_CHECK_GC */
345 #define deadbeef_memory(ptr, size)
347 #endif /* !ERROR_CHECK_GC */
351 xstrdup (const char *str)
353 int len = strlen (str) + 1; /* for stupid terminating 0 */
355 void *val = xmalloc (len);
356 if (val == 0) return 0;
357 return (char *) memcpy (val, str, len);
362 strdup (const char *s)
366 #endif /* NEED_STRDUP */
370 allocate_lisp_storage (size_t size)
372 return xmalloc (size);
376 /* lcrecords are chained together through their "next" field.
377 After doing the mark phase, GC will walk this linked list
378 and free any lcrecord which hasn't been marked. */
379 static struct lcrecord_header *all_lcrecords;
382 alloc_lcrecord (size_t size, const struct lrecord_implementation *implementation)
384 struct lcrecord_header *lcheader;
386 #ifdef ERROR_CHECK_TYPECHECK
387 if (implementation->static_size == 0)
388 assert (implementation->size_in_bytes_method);
390 assert (implementation->static_size == size);
392 assert (! implementation->basic_p);
394 if (implementation->hash == NULL)
395 assert (implementation->equal == NULL);
398 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
399 set_lheader_implementation (&(lcheader->lheader), implementation);
400 lcheader->next = all_lcrecords;
401 #if 1 /* mly prefers to see small ID numbers */
402 lcheader->uid = lrecord_uid_counter++;
403 #else /* jwz prefers to see real addrs */
404 lcheader->uid = (int) &lcheader;
407 all_lcrecords = lcheader;
408 INCREMENT_CONS_COUNTER (size, implementation->name);
412 #if 0 /* Presently unused */
413 /* Very, very poor man's EGC?
414 * This may be slow and thrash pages all over the place.
415 * Only call it if you really feel you must (and if the
416 * lrecord was fairly recently allocated).
417 * Otherwise, just let the GC do its job -- that's what it's there for
420 free_lcrecord (struct lcrecord_header *lcrecord)
422 if (all_lcrecords == lcrecord)
424 all_lcrecords = lcrecord->next;
428 struct lrecord_header *header = all_lcrecords;
431 struct lrecord_header *next = header->next;
432 if (next == lcrecord)
434 header->next = lrecord->next;
443 if (lrecord->implementation->finalizer)
444 lrecord->implementation->finalizer (lrecord, 0);
452 disksave_object_finalization_1 (void)
454 struct lcrecord_header *header;
456 for (header = all_lcrecords; header; header = header->next)
458 if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
460 ((LHEADER_IMPLEMENTATION(&header->lheader)->finalizer)
465 /* Semi-kludge -- lrecord_symbol_value_forward objects get stuck
466 in const space and you get SEGV's if you attempt to mark them.
467 This sits in lheader->implementation->marker. */
470 this_one_is_unmarkable (Lisp_Object obj)
477 /************************************************************************/
478 /* Debugger support */
479 /************************************************************************/
480 /* Give gdb/dbx enough information to decode Lisp Objects. We make
481 sure certain symbols are always defined, so gdb doesn't complain
482 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
483 to see how this is used. */
485 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
486 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
488 #ifdef USE_UNION_TYPE
489 unsigned char dbg_USE_UNION_TYPE = 1;
491 unsigned char dbg_USE_UNION_TYPE = 0;
494 unsigned char Lisp_Type_Int = 100;
495 unsigned char Lisp_Type_Cons = 101;
496 unsigned char Lisp_Type_String = 102;
497 unsigned char Lisp_Type_Vector = 103;
498 unsigned char Lisp_Type_Symbol = 104;
501 unsigned char lrecord_char_table_entry;
502 unsigned char lrecord_charset;
504 unsigned char lrecord_coding_system;
508 #if !((defined HAVE_X_WINDOWS) && \
509 (defined (HAVE_MENUBARS) || \
510 defined (HAVE_SCROLLBARS) || \
511 defined (HAVE_DIALOGS) || \
512 defined (HAVE_TOOLBARS) || \
513 defined (HAVE_WIDGETS)))
514 unsigned char lrecord_popup_data;
517 #ifndef HAVE_TOOLBARS
518 unsigned char lrecord_toolbar_button;
522 unsigned char lrecord_tooltalk_message;
523 unsigned char lrecord_tooltalk_pattern;
526 #ifndef HAVE_DATABASE
527 unsigned char lrecord_database;
530 unsigned char dbg_valbits = VALBITS;
531 unsigned char dbg_gctypebits = GCTYPEBITS;
533 /* Macros turned into functions for ease of debugging.
534 Debuggers don't know about macros! */
535 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
537 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
539 return EQ (obj1, obj2);
543 /************************************************************************/
544 /* Fixed-size type macros */
545 /************************************************************************/
547 /* For fixed-size types that are commonly used, we malloc() large blocks
548 of memory at a time and subdivide them into chunks of the correct
549 size for an object of that type. This is more efficient than
550 malloc()ing each object separately because we save on malloc() time
551 and overhead due to the fewer number of malloc()ed blocks, and
552 also because we don't need any extra pointers within each object
553 to keep them threaded together for GC purposes. For less common
554 (and frequently large-size) types, we use lcrecords, which are
555 malloc()ed individually and chained together through a pointer
556 in the lcrecord header. lcrecords do not need to be fixed-size
557 (i.e. two objects of the same type need not have the same size;
558 however, the size of a particular object cannot vary dynamically).
559 It is also much easier to create a new lcrecord type because no
560 additional code needs to be added to alloc.c. Finally, lcrecords
561 may be more efficient when there are only a small number of them.
563 The types that are stored in these large blocks (or "frob blocks")
564 are cons, float, compiled-function, symbol, marker, extent, event,
567 Note that strings are special in that they are actually stored in
568 two parts: a structure containing information about the string, and
569 the actual data associated with the string. The former structure
570 (a struct Lisp_String) is a fixed-size structure and is managed the
571 same way as all the other such types. This structure contains a
572 pointer to the actual string data, which is stored in structures of
573 type struct string_chars_block. Each string_chars_block consists
574 of a pointer to a struct Lisp_String, followed by the data for that
575 string, followed by another pointer to a Lisp_String, followed by
576 the data for that string, etc. At GC time, the data in these
577 blocks is compacted by searching sequentially through all the
578 blocks and compressing out any holes created by unmarked strings.
579 Strings that are more than a certain size (bigger than the size of
580 a string_chars_block, although something like half as big might
581 make more sense) are malloc()ed separately and not stored in
582 string_chars_blocks. Furthermore, no one string stretches across
583 two string_chars_blocks.
585 Vectors are each malloc()ed separately, similar to lcrecords.
587 In the following discussion, we use conses, but it applies equally
588 well to the other fixed-size types.
590 We store cons cells inside of cons_blocks, allocating a new
591 cons_block with malloc() whenever necessary. Cons cells reclaimed
592 by GC are put on a free list to be reallocated before allocating
593 any new cons cells from the latest cons_block. Each cons_block is
594 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
595 the versions in malloc.c and gmalloc.c) really allocates in units
596 of powers of two and uses 4 bytes for its own overhead.
598 What GC actually does is to search through all the cons_blocks,
599 from the most recently allocated to the oldest, and put all
600 cons cells that are not marked (whether or not they're already
601 free) on a cons_free_list. The cons_free_list is a stack, and
602 so the cons cells in the oldest-allocated cons_block end up
603 at the head of the stack and are the first to be reallocated.
604 If any cons_block is entirely free, it is freed with free()
605 and its cons cells removed from the cons_free_list. Because
606 the cons_free_list ends up basically in memory order, we have
607 a high locality of reference (assuming a reasonable turnover
608 of allocating and freeing) and have a reasonable probability
609 of entirely freeing up cons_blocks that have been more recently
610 allocated. This stage is called the "sweep stage" of GC, and
611 is executed after the "mark stage", which involves starting
612 from all places that are known to point to in-use Lisp objects
613 (e.g. the obarray, where are all symbols are stored; the
614 current catches and condition-cases; the backtrace list of
615 currently executing functions; the gcpro list; etc.) and
616 recursively marking all objects that are accessible.
618 At the beginning of the sweep stage, the conses in the cons
619 blocks are in one of three states: in use and marked, in use
620 but not marked, and not in use (already freed). Any conses
621 that are marked have been marked in the mark stage just
622 executed, because as part of the sweep stage we unmark any
623 marked objects. The way we tell whether or not a cons cell
624 is in use is through the FREE_STRUCT_P macro. This basically
625 looks at the first 4 bytes (or however many bytes a pointer
626 fits in) to see if all the bits in those bytes are 1. The
627 resulting value (0xFFFFFFFF) is not a valid pointer and is
628 not a valid Lisp_Object. All current fixed-size types have
629 a pointer or Lisp_Object as their first element with the
630 exception of strings; they have a size value, which can
631 never be less than zero, and so 0xFFFFFFFF is invalid for
632 strings as well. Now assuming that a cons cell is in use,
633 the way we tell whether or not it is marked is to look at
634 the mark bit of its car (each Lisp_Object has one bit
635 reserved as a mark bit, in case it's needed). Note that
636 different types of objects use different fields to indicate
637 whether the object is marked, but the principle is the same.
639 Conses on the free_cons_list are threaded through a pointer
640 stored in the bytes directly after the bytes that are set
641 to 0xFFFFFFFF (we cannot overwrite these because the cons
642 is still in a cons_block and needs to remain marked as
643 not in use for the next time that GC happens). This
644 implies that all fixed-size types must be at least big
645 enough to store two pointers, which is indeed the case
646 for all current fixed-size types.
648 Some types of objects need additional "finalization" done
649 when an object is converted from in use to not in use;
650 this is the purpose of the ADDITIONAL_FREE_type macro.
651 For example, markers need to be removed from the chain
652 of markers that is kept in each buffer. This is because
653 markers in a buffer automatically disappear if the marker
654 is no longer referenced anywhere (the same does not
655 apply to extents, however).
657 WARNING: Things are in an extremely bizarre state when
658 the ADDITIONAL_FREE_type macros are called, so beware!
660 When ERROR_CHECK_GC is defined, we do things differently
661 so as to maximize our chances of catching places where
662 there is insufficient GCPROing. The thing we want to
663 avoid is having an object that we're using but didn't
664 GCPRO get freed by GC and then reallocated while we're
665 in the process of using it -- this will result in something
666 seemingly unrelated getting trashed, and is extremely
667 difficult to track down. If the object gets freed but
668 not reallocated, we can usually catch this because we
669 set all bytes of a freed object to 0xDEADBEEF. (The
670 first four bytes, however, are 0xFFFFFFFF, and the next
671 four are a pointer used to chain freed objects together;
672 we play some tricks with this pointer to make it more
673 bogus, so crashes are more likely to occur right away.)
675 We want freed objects to stay free as long as possible,
676 so instead of doing what we do above, we maintain the
677 free objects in a first-in first-out queue. We also
678 don't recompute the free list each GC, unlike above;
679 this ensures that the queue ordering is preserved.
680 [This means that we are likely to have worse locality
681 of reference, and that we can never free a frob block
682 once it's allocated. (Even if we know that all cells
683 in it are free, there's no easy way to remove all those
684 cells from the free list because the objects on the
685 free list are unlikely to be in memory order.)]
686 Furthermore, we never take objects off the free list
687 unless there's a large number (usually 1000, but
688 varies depending on type) of them already on the list.
689 This way, we ensure that an object that gets freed will
690 remain free for the next 1000 (or whatever) times that
691 an object of that type is allocated. */
693 #ifndef MALLOC_OVERHEAD
695 #define MALLOC_OVERHEAD 0
696 #elif defined (rcheck)
697 #define MALLOC_OVERHEAD 20
699 #define MALLOC_OVERHEAD 8
701 #endif /* MALLOC_OVERHEAD */
703 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
704 /* If we released our reserve (due to running out of memory),
705 and we have a fair amount free once again,
706 try to set aside another reserve in case we run out once more.
708 This is called when a relocatable block is freed in ralloc.c. */
709 void refill_memory_reserve (void);
711 refill_memory_reserve ()
713 if (breathing_space == 0)
714 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
718 #ifdef ALLOC_NO_POOLS
719 # define TYPE_ALLOC_SIZE(type, structtype) 1
721 # define TYPE_ALLOC_SIZE(type, structtype) \
722 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
723 / sizeof (structtype))
724 #endif /* ALLOC_NO_POOLS */
726 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
728 struct type##_block \
730 struct type##_block *prev; \
731 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
734 static struct type##_block *current_##type##_block; \
735 static int current_##type##_block_index; \
737 static structtype *type##_free_list; \
738 static structtype *type##_free_list_tail; \
741 init_##type##_alloc (void) \
743 current_##type##_block = 0; \
744 current_##type##_block_index = \
745 countof (current_##type##_block->block); \
746 type##_free_list = 0; \
747 type##_free_list_tail = 0; \
750 static int gc_count_num_##type##_in_use; \
751 static int gc_count_num_##type##_freelist
753 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
754 if (current_##type##_block_index \
755 == countof (current_##type##_block->block)) \
757 struct type##_block *AFTFB_new = (struct type##_block *) \
758 allocate_lisp_storage (sizeof (struct type##_block)); \
759 AFTFB_new->prev = current_##type##_block; \
760 current_##type##_block = AFTFB_new; \
761 current_##type##_block_index = 0; \
764 &(current_##type##_block->block[current_##type##_block_index++]); \
767 /* Allocate an instance of a type that is stored in blocks.
768 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
771 #ifdef ERROR_CHECK_GC
773 /* Note: if you get crashes in this function, suspect incorrect calls
774 to free_cons() and friends. This happened once because the cons
775 cell was not GC-protected and was getting collected before
776 free_cons() was called. */
778 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
781 if (gc_count_num_##type##_freelist > \
782 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
784 result = type##_free_list; \
785 /* Before actually using the chain pointer, we complement all its \
786 bits; see FREE_FIXED_TYPE(). */ \
788 (structtype *) ~(unsigned long) \
789 (* (structtype **) ((char *) result + sizeof (void *))); \
790 gc_count_num_##type##_freelist--; \
793 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
794 MARK_STRUCT_AS_NOT_FREE (result); \
797 #else /* !ERROR_CHECK_GC */
799 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
802 if (type##_free_list) \
804 result = type##_free_list; \
806 * (structtype **) ((char *) result + sizeof (void *)); \
809 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
810 MARK_STRUCT_AS_NOT_FREE (result); \
813 #endif /* !ERROR_CHECK_GC */
815 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
818 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
819 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
822 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
825 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
826 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
829 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
830 to a Lisp object and invalid as an actual Lisp_Object value. We have
831 to make sure that this value cannot be an integer in Lisp_Object form.
832 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
833 On a 32-bit system, the type bits will be non-zero, making the value
834 be a pointer, and the pointer will be misaligned.
836 Even if Emacs is run on some weirdo system that allows and allocates
837 byte-aligned pointers, this pointer is at the very top of the address
838 space and so it's almost inconceivable that it could ever be valid. */
841 # define INVALID_POINTER_VALUE 0xFFFFFFFF
843 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
845 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
847 You have some weird system and need to supply a reasonable value here.
850 #define FREE_STRUCT_P(ptr) \
851 (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
852 #define MARK_STRUCT_AS_FREE(ptr) \
853 (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
854 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
855 (* (void **) ptr = 0)
857 #ifdef ERROR_CHECK_GC
859 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
860 do { if (type##_free_list_tail) \
862 /* When we store the chain pointer, we complement all \
863 its bits; this should significantly increase its \
864 bogosity in case someone tries to use the value, and \
865 should make us dump faster if someone stores something \
866 over the pointer because when it gets un-complemented in \
867 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
868 extremely bogus. */ \
870 ((char *) type##_free_list_tail + sizeof (void *)) = \
871 (structtype *) ~(unsigned long) ptr; \
874 type##_free_list = ptr; \
875 type##_free_list_tail = ptr; \
878 #else /* !ERROR_CHECK_GC */
880 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
881 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
883 type##_free_list = (ptr); \
886 #endif /* !ERROR_CHECK_GC */
888 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
890 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
891 structtype *FFT_ptr = (ptr); \
892 ADDITIONAL_FREE_##type (FFT_ptr); \
893 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
894 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
895 MARK_STRUCT_AS_FREE (FFT_ptr); \
898 /* Like FREE_FIXED_TYPE() but used when we are explicitly
899 freeing a structure through free_cons(), free_marker(), etc.
900 rather than through the normal process of sweeping.
901 We attempt to undo the changes made to the allocation counters
902 as a result of this structure being allocated. This is not
903 completely necessary but helps keep things saner: e.g. this way,
904 repeatedly allocating and freeing a cons will not result in
905 the consing-since-gc counter advancing, which would cause a GC
906 and somewhat defeat the purpose of explicitly freeing. */
908 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
909 do { FREE_FIXED_TYPE (type, structtype, ptr); \
910 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
911 gc_count_num_##type##_freelist++; \
916 /************************************************************************/
917 /* Cons allocation */
918 /************************************************************************/
920 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
921 /* conses are used and freed so often that we set this really high */
922 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
923 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
926 mark_cons (Lisp_Object obj)
928 if (NILP (XCDR (obj)))
931 mark_object (XCAR (obj));
936 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
939 while (internal_equal (XCAR (ob1), XCAR (ob2), depth))
943 if (! CONSP (ob1) || ! CONSP (ob2))
944 return internal_equal (ob1, ob2, depth);
949 static const struct lrecord_description cons_description[] = {
950 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
951 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
955 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
956 mark_cons, print_cons, 0,
959 * No `hash' method needed.
960 * internal_hash knows how to
967 DEFUN ("cons", Fcons, 2, 2, 0, /*
968 Create a new cons, give it CAR and CDR as components, and return it.
972 /* This cannot GC. */
976 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
977 set_lheader_implementation (&(c->lheader), &lrecord_cons);
984 /* This is identical to Fcons() but it used for conses that we're
985 going to free later, and is useful when trying to track down
988 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
993 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
994 set_lheader_implementation (&(c->lheader), &lrecord_cons);
1001 DEFUN ("list", Flist, 0, MANY, 0, /*
1002 Return a newly created list with specified arguments as elements.
1003 Any number of arguments, even zero arguments, are allowed.
1005 (int nargs, Lisp_Object *args))
1007 Lisp_Object val = Qnil;
1008 Lisp_Object *argp = args + nargs;
1011 val = Fcons (*--argp, val);
1016 list1 (Lisp_Object obj0)
1018 /* This cannot GC. */
1019 return Fcons (obj0, Qnil);
1023 list2 (Lisp_Object obj0, Lisp_Object obj1)
1025 /* This cannot GC. */
1026 return Fcons (obj0, Fcons (obj1, Qnil));
1030 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1032 /* This cannot GC. */
1033 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1037 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1039 /* This cannot GC. */
1040 return Fcons (obj0, Fcons (obj1, obj2));
1044 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1046 return Fcons (Fcons (key, value), alist);
1050 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1052 /* This cannot GC. */
1053 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1057 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1060 /* This cannot GC. */
1061 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1065 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1066 Lisp_Object obj4, Lisp_Object obj5)
1068 /* This cannot GC. */
1069 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1072 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1073 Return a new list of length LENGTH, with each element being INIT.
1077 CHECK_NATNUM (length);
1080 Lisp_Object val = Qnil;
1081 size_t size = XINT (length);
1084 val = Fcons (init, val);
1090 /************************************************************************/
1091 /* Float allocation */
1092 /************************************************************************/
1094 #ifdef LISP_FLOAT_TYPE
1096 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
1097 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1100 make_float (double float_value)
1105 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
1107 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1108 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1111 set_lheader_implementation (&(f->lheader), &lrecord_float);
1112 float_data (f) = float_value;
1117 #endif /* LISP_FLOAT_TYPE */
1120 /************************************************************************/
1121 /* Vector allocation */
1122 /************************************************************************/
1125 mark_vector (Lisp_Object obj)
1127 Lisp_Vector *ptr = XVECTOR (obj);
1128 int len = vector_length (ptr);
1131 for (i = 0; i < len - 1; i++)
1132 mark_object (ptr->contents[i]);
1133 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1137 size_vector (const void *lheader)
1139 return offsetof (Lisp_Vector, contents[((Lisp_Vector *) lheader)->size]);
1143 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1145 int len = XVECTOR_LENGTH (obj1);
1146 if (len != XVECTOR_LENGTH (obj2))
1150 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1151 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1153 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1160 vector_hash (Lisp_Object obj, int depth)
1162 return HASH2 (XVECTOR_LENGTH (obj),
1163 internal_array_hash (XVECTOR_DATA (obj),
1164 XVECTOR_LENGTH (obj),
1168 static const struct lrecord_description vector_description[] = {
1169 { XD_LONG, offsetof (Lisp_Vector, size) },
1170 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1174 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1175 mark_vector, print_vector, 0,
1179 size_vector, Lisp_Vector);
1181 /* #### should allocate `small' vectors from a frob-block */
1182 static Lisp_Vector *
1183 make_vector_internal (size_t sizei)
1185 /* no vector_next */
1186 size_t sizem = offsetof (Lisp_Vector, contents[sizei]);
1187 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1194 make_vector (size_t length, Lisp_Object init)
1196 Lisp_Vector *vecp = make_vector_internal (length);
1197 Lisp_Object *p = vector_data (vecp);
1204 XSETVECTOR (vector, vecp);
1209 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1210 Return a new vector of length LENGTH, with each element being INIT.
1211 See also the function `vector'.
1215 CONCHECK_NATNUM (length);
1216 return make_vector (XINT (length), init);
1219 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1220 Return a newly created vector with specified arguments as elements.
1221 Any number of arguments, even zero arguments, are allowed.
1223 (int nargs, Lisp_Object *args))
1225 Lisp_Vector *vecp = make_vector_internal (nargs);
1226 Lisp_Object *p = vector_data (vecp);
1233 XSETVECTOR (vector, vecp);
1239 vector1 (Lisp_Object obj0)
1241 return Fvector (1, &obj0);
1245 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1247 Lisp_Object args[2];
1250 return Fvector (2, args);
1254 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1256 Lisp_Object args[3];
1260 return Fvector (3, args);
1263 #if 0 /* currently unused */
1266 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1269 Lisp_Object args[4];
1274 return Fvector (4, args);
1278 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1279 Lisp_Object obj3, Lisp_Object obj4)
1281 Lisp_Object args[5];
1287 return Fvector (5, args);
1291 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1292 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1294 Lisp_Object args[6];
1301 return Fvector (6, args);
1305 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1306 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1309 Lisp_Object args[7];
1317 return Fvector (7, args);
1321 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1322 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1323 Lisp_Object obj6, Lisp_Object obj7)
1325 Lisp_Object args[8];
1334 return Fvector (8, args);
1338 /************************************************************************/
1339 /* Bit Vector allocation */
1340 /************************************************************************/
1342 static Lisp_Object all_bit_vectors;
1344 /* #### should allocate `small' bit vectors from a frob-block */
1345 static Lisp_Bit_Vector *
1346 make_bit_vector_internal (size_t sizei)
1348 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1349 size_t sizem = offsetof (Lisp_Bit_Vector, bits[num_longs]);
1350 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1351 set_lheader_implementation (&(p->lheader), &lrecord_bit_vector);
1353 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1355 bit_vector_length (p) = sizei;
1356 bit_vector_next (p) = all_bit_vectors;
1357 /* make sure the extra bits in the last long are 0; the calling
1358 functions might not set them. */
1359 p->bits[num_longs - 1] = 0;
1360 XSETBIT_VECTOR (all_bit_vectors, p);
1365 make_bit_vector (size_t length, Lisp_Object init)
1367 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1368 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1373 memset (p->bits, 0, num_longs * sizeof (long));
1376 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1377 memset (p->bits, ~0, num_longs * sizeof (long));
1378 /* But we have to make sure that the unused bits in the
1379 last long are 0, so that equal/hash is easy. */
1381 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1385 Lisp_Object bit_vector;
1386 XSETBIT_VECTOR (bit_vector, p);
1392 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1395 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1397 for (i = 0; i < length; i++)
1398 set_bit_vector_bit (p, i, bytevec[i]);
1401 Lisp_Object bit_vector;
1402 XSETBIT_VECTOR (bit_vector, p);
1407 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1408 Return a new bit vector of length LENGTH. with each bit being INIT.
1409 Each element is set to INIT. See also the function `bit-vector'.
1413 CONCHECK_NATNUM (length);
1415 return make_bit_vector (XINT (length), init);
1418 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1419 Return a newly created bit vector with specified arguments as elements.
1420 Any number of arguments, even zero arguments, are allowed.
1422 (int nargs, Lisp_Object *args))
1425 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1427 for (i = 0; i < nargs; i++)
1429 CHECK_BIT (args[i]);
1430 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1434 Lisp_Object bit_vector;
1435 XSETBIT_VECTOR (bit_vector, p);
1441 /************************************************************************/
1442 /* Compiled-function allocation */
1443 /************************************************************************/
1445 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1446 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1449 make_compiled_function (void)
1451 Lisp_Compiled_Function *f;
1454 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1455 set_lheader_implementation (&(f->lheader), &lrecord_compiled_function);
1458 f->specpdl_depth = 0;
1459 f->flags.documentationp = 0;
1460 f->flags.interactivep = 0;
1461 f->flags.domainp = 0; /* I18N3 */
1462 f->instructions = Qzero;
1463 f->constants = Qzero;
1465 f->doc_and_interactive = Qnil;
1466 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1467 f->annotated = Qnil;
1469 XSETCOMPILED_FUNCTION (fun, f);
1473 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1474 Return a new compiled-function object.
1475 Usage: (arglist instructions constants stack-depth
1476 &optional doc-string interactive)
1477 Note that, unlike all other emacs-lisp functions, calling this with five
1478 arguments is NOT the same as calling it with six arguments, the last of
1479 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1480 that this function was defined with `(interactive)'. If the arg is not
1481 specified, then that means the function is not interactive.
1482 This is terrible behavior which is retained for compatibility with old
1483 `.elc' files which expect these semantics.
1485 (int nargs, Lisp_Object *args))
1487 /* In a non-insane world this function would have this arglist...
1488 (arglist instructions constants stack_depth &optional doc_string interactive)
1490 Lisp_Object fun = make_compiled_function ();
1491 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1493 Lisp_Object arglist = args[0];
1494 Lisp_Object instructions = args[1];
1495 Lisp_Object constants = args[2];
1496 Lisp_Object stack_depth = args[3];
1497 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1498 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1500 if (nargs < 4 || nargs > 6)
1501 return Fsignal (Qwrong_number_of_arguments,
1502 list2 (intern ("make-byte-code"), make_int (nargs)));
1504 /* Check for valid formal parameter list now, to allow us to use
1505 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1507 Lisp_Object symbol, tail;
1508 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1510 CHECK_SYMBOL (symbol);
1511 if (EQ (symbol, Qt) ||
1512 EQ (symbol, Qnil) ||
1513 SYMBOL_IS_KEYWORD (symbol))
1514 signal_simple_error_2
1515 ("Invalid constant symbol in formal parameter list",
1519 f->arglist = arglist;
1521 /* `instructions' is a string or a cons (string . int) for a
1522 lazy-loaded function. */
1523 if (CONSP (instructions))
1525 CHECK_STRING (XCAR (instructions));
1526 CHECK_INT (XCDR (instructions));
1530 CHECK_STRING (instructions);
1532 f->instructions = instructions;
1534 if (!NILP (constants))
1535 CHECK_VECTOR (constants);
1536 f->constants = constants;
1538 CHECK_NATNUM (stack_depth);
1539 f->stack_depth = XINT (stack_depth);
1541 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1542 if (!NILP (Vcurrent_compiled_function_annotation))
1543 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1544 else if (!NILP (Vload_file_name_internal_the_purecopy))
1545 f->annotated = Vload_file_name_internal_the_purecopy;
1546 else if (!NILP (Vload_file_name_internal))
1548 struct gcpro gcpro1;
1549 GCPRO1 (fun); /* don't let fun get reaped */
1550 Vload_file_name_internal_the_purecopy =
1551 Ffile_name_nondirectory (Vload_file_name_internal);
1552 f->annotated = Vload_file_name_internal_the_purecopy;
1555 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1557 /* doc_string may be nil, string, int, or a cons (string . int).
1558 interactive may be list or string (or unbound). */
1559 f->doc_and_interactive = Qunbound;
1561 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1562 f->doc_and_interactive = Vfile_domain;
1564 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1566 f->doc_and_interactive
1567 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1568 Fcons (interactive, f->doc_and_interactive));
1570 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1572 f->doc_and_interactive
1573 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1574 Fcons (doc_string, f->doc_and_interactive));
1576 if (UNBOUNDP (f->doc_and_interactive))
1577 f->doc_and_interactive = Qnil;
1583 /************************************************************************/
1584 /* Symbol allocation */
1585 /************************************************************************/
1587 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1588 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1590 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1591 Return a newly allocated uninterned symbol whose name is NAME.
1592 Its value and function definition are void, and its property list is nil.
1599 CHECK_STRING (name);
1601 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1602 set_lheader_implementation (&(p->lheader), &lrecord_symbol);
1603 p->name = XSTRING (name);
1605 p->value = Qunbound;
1606 p->function = Qunbound;
1607 symbol_next (p) = 0;
1608 XSETSYMBOL (val, p);
1613 /************************************************************************/
1614 /* Extent allocation */
1615 /************************************************************************/
1617 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1618 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1621 allocate_extent (void)
1625 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1626 set_lheader_implementation (&(e->lheader), &lrecord_extent);
1627 extent_object (e) = Qnil;
1628 set_extent_start (e, -1);
1629 set_extent_end (e, -1);
1634 extent_face (e) = Qnil;
1635 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1636 e->flags.detachable = 1;
1642 /************************************************************************/
1643 /* Event allocation */
1644 /************************************************************************/
1646 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1647 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1650 allocate_event (void)
1655 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1656 set_lheader_implementation (&(e->lheader), &lrecord_event);
1663 /************************************************************************/
1664 /* Marker allocation */
1665 /************************************************************************/
1667 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1668 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1670 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1671 Return a new marker which does not point at any place.
1678 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1679 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1682 marker_next (p) = 0;
1683 marker_prev (p) = 0;
1684 p->insertion_type = 0;
1685 XSETMARKER (val, p);
1690 noseeum_make_marker (void)
1695 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1696 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1699 marker_next (p) = 0;
1700 marker_prev (p) = 0;
1701 p->insertion_type = 0;
1702 XSETMARKER (val, p);
1707 /************************************************************************/
1708 /* String allocation */
1709 /************************************************************************/
1711 /* The data for "short" strings generally resides inside of structs of type
1712 string_chars_block. The Lisp_String structure is allocated just like any
1713 other Lisp object (except for vectors), and these are freelisted when
1714 they get garbage collected. The data for short strings get compacted,
1715 but the data for large strings do not.
1717 Previously Lisp_String structures were relocated, but this caused a lot
1718 of bus-errors because the C code didn't include enough GCPRO's for
1719 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1720 that the reference would get relocated).
1722 This new method makes things somewhat bigger, but it is MUCH safer. */
1724 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1725 /* strings are used and freed quite often */
1726 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1727 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1730 mark_string (Lisp_Object obj)
1732 Lisp_String *ptr = XSTRING (obj);
1734 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1735 flush_cached_extent_info (XCAR (ptr->plist));
1740 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1743 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1744 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1747 static const struct lrecord_description string_description[] = {
1748 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1749 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1750 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1754 /* We store the string's extent info as the first element of the string's
1755 property list; and the string's MODIFF as the first or second element
1756 of the string's property list (depending on whether the extent info
1757 is present), but only if the string has been modified. This is ugly
1758 but it reduces the memory allocated for the string in the vast
1759 majority of cases, where the string is never modified and has no
1762 #### This means you can't use an int as a key in a string's plist. */
1764 static Lisp_Object *
1765 string_plist_ptr (Lisp_Object string)
1767 Lisp_Object *ptr = &XSTRING (string)->plist;
1769 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
1771 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
1777 string_getprop (Lisp_Object string, Lisp_Object property)
1779 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
1783 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
1785 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
1790 string_remprop (Lisp_Object string, Lisp_Object property)
1792 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
1796 string_plist (Lisp_Object string)
1798 return *string_plist_ptr (string);
1801 /* No `finalize', or `hash' methods.
1802 internal_hash() already knows how to hash strings and finalization
1803 is done with the ADDITIONAL_FREE_string macro, which is the
1804 standard way to do finalization when using
1805 SWEEP_FIXED_TYPE_BLOCK(). */
1806 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
1807 mark_string, print_string,
1816 /* String blocks contain this many useful bytes. */
1817 #define STRING_CHARS_BLOCK_SIZE \
1818 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1819 ((2 * sizeof (struct string_chars_block *)) \
1820 + sizeof (EMACS_INT))))
1821 /* Block header for small strings. */
1822 struct string_chars_block
1825 struct string_chars_block *next;
1826 struct string_chars_block *prev;
1827 /* Contents of string_chars_block->string_chars are interleaved
1828 string_chars structures (see below) and the actual string data */
1829 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1832 static struct string_chars_block *first_string_chars_block;
1833 static struct string_chars_block *current_string_chars_block;
1835 /* If SIZE is the length of a string, this returns how many bytes
1836 * the string occupies in string_chars_block->string_chars
1837 * (including alignment padding).
1839 #define STRING_FULLSIZE(size) \
1840 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1841 ALIGNOF (Lisp_String *))
1843 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1844 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1848 Lisp_String *string;
1849 unsigned char chars[1];
1852 struct unused_string_chars
1854 Lisp_String *string;
1859 init_string_chars_alloc (void)
1861 first_string_chars_block = xnew (struct string_chars_block);
1862 first_string_chars_block->prev = 0;
1863 first_string_chars_block->next = 0;
1864 first_string_chars_block->pos = 0;
1865 current_string_chars_block = first_string_chars_block;
1868 static struct string_chars *
1869 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1872 struct string_chars *s_chars;
1875 (countof (current_string_chars_block->string_chars)
1876 - current_string_chars_block->pos))
1878 /* This string can fit in the current string chars block */
1879 s_chars = (struct string_chars *)
1880 (current_string_chars_block->string_chars
1881 + current_string_chars_block->pos);
1882 current_string_chars_block->pos += fullsize;
1886 /* Make a new current string chars block */
1887 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1889 current_string_chars_block->next = new_scb;
1890 new_scb->prev = current_string_chars_block;
1892 current_string_chars_block = new_scb;
1893 new_scb->pos = fullsize;
1894 s_chars = (struct string_chars *)
1895 current_string_chars_block->string_chars;
1898 s_chars->string = string_it_goes_with;
1900 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1906 make_uninit_string (Bytecount length)
1909 EMACS_INT fullsize = STRING_FULLSIZE (length);
1912 assert (length >= 0 && fullsize > 0);
1914 /* Allocate the string header */
1915 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1916 set_lheader_implementation (&(s->lheader), &lrecord_string);
1918 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1919 ? xnew_array (Bufbyte, length + 1)
1920 : allocate_string_chars_struct (s, fullsize)->chars);
1922 set_string_length (s, length);
1925 set_string_byte (s, length, 0);
1927 XSETSTRING (val, s);
1931 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1932 static void verify_string_chars_integrity (void);
1935 /* Resize the string S so that DELTA bytes can be inserted starting
1936 at POS. If DELTA < 0, it means deletion starting at POS. If
1937 POS < 0, resize the string but don't copy any characters. Use
1938 this if you're planning on completely overwriting the string.
1942 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
1944 Bytecount oldfullsize, newfullsize;
1945 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1946 verify_string_chars_integrity ();
1949 #ifdef ERROR_CHECK_BUFPOS
1952 assert (pos <= string_length (s));
1954 assert (pos + (-delta) <= string_length (s));
1959 assert ((-delta) <= string_length (s));
1961 #endif /* ERROR_CHECK_BUFPOS */
1964 /* simplest case: no size change. */
1967 if (pos >= 0 && delta < 0)
1968 /* If DELTA < 0, the functions below will delete the characters
1969 before POS. We want to delete characters *after* POS, however,
1970 so convert this to the appropriate form. */
1973 oldfullsize = STRING_FULLSIZE (string_length (s));
1974 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1976 if (BIG_STRING_FULLSIZE_P (oldfullsize))
1978 if (BIG_STRING_FULLSIZE_P (newfullsize))
1980 /* Both strings are big. We can just realloc().
1981 But careful! If the string is shrinking, we have to
1982 memmove() _before_ realloc(), and if growing, we have to
1983 memmove() _after_ realloc() - otherwise the access is
1984 illegal, and we might crash. */
1985 Bytecount len = string_length (s) + 1 - pos;
1987 if (delta < 0 && pos >= 0)
1988 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1989 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1990 string_length (s) + delta + 1));
1991 if (delta > 0 && pos >= 0)
1992 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1994 else /* String has been demoted from BIG_STRING. */
1997 allocate_string_chars_struct (s, newfullsize)->chars;
1998 Bufbyte *old_data = string_data (s);
2002 memcpy (new_data, old_data, pos);
2003 memcpy (new_data + pos + delta, old_data + pos,
2004 string_length (s) + 1 - pos);
2006 set_string_data (s, new_data);
2010 else /* old string is small */
2012 if (oldfullsize == newfullsize)
2014 /* special case; size change but the necessary
2015 allocation size won't change (up or down; code
2016 somewhere depends on there not being any unused
2017 allocation space, modulo any alignment
2021 Bufbyte *addroff = pos + string_data (s);
2023 memmove (addroff + delta, addroff,
2024 /* +1 due to zero-termination. */
2025 string_length (s) + 1 - pos);
2030 Bufbyte *old_data = string_data (s);
2032 BIG_STRING_FULLSIZE_P (newfullsize)
2033 ? xnew_array (Bufbyte, string_length (s) + delta + 1)
2034 : allocate_string_chars_struct (s, newfullsize)->chars;
2038 memcpy (new_data, old_data, pos);
2039 memcpy (new_data + pos + delta, old_data + pos,
2040 string_length (s) + 1 - pos);
2042 set_string_data (s, new_data);
2045 /* We need to mark this chunk of the string_chars_block
2046 as unused so that compact_string_chars() doesn't
2048 struct string_chars *old_s_chars = (struct string_chars *)
2049 ((char *) old_data - offsetof (struct string_chars, chars));
2050 /* Sanity check to make sure we aren't hosed by strange
2051 alignment/padding. */
2052 assert (old_s_chars->string == s);
2053 MARK_STRUCT_AS_FREE (old_s_chars);
2054 ((struct unused_string_chars *) old_s_chars)->fullsize =
2060 set_string_length (s, string_length (s) + delta);
2061 /* If pos < 0, the string won't be zero-terminated.
2062 Terminate now just to make sure. */
2063 string_data (s)[string_length (s)] = '\0';
2069 XSETSTRING (string, s);
2070 /* We also have to adjust all of the extent indices after the
2071 place we did the change. We say "pos - 1" because
2072 adjust_extents() is exclusive of the starting position
2074 adjust_extents (string, pos - 1, string_length (s),
2078 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2079 verify_string_chars_integrity ();
2086 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2088 Bufbyte newstr[MAX_EMCHAR_LEN];
2089 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2090 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2091 Bytecount newlen = set_charptr_emchar (newstr, c);
2093 if (oldlen != newlen)
2094 resize_string (s, bytoff, newlen - oldlen);
2095 /* Remember, string_data (s) might have changed so we can't cache it. */
2096 memcpy (string_data (s) + bytoff, newstr, newlen);
2101 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2102 Return a new string of length LENGTH, with each character being INIT.
2103 LENGTH must be an integer and INIT must be a character.
2107 CHECK_NATNUM (length);
2108 CHECK_CHAR_COERCE_INT (init);
2110 Bufbyte init_str[MAX_EMCHAR_LEN];
2111 int len = set_charptr_emchar (init_str, XCHAR (init));
2112 Lisp_Object val = make_uninit_string (len * XINT (length));
2115 /* Optimize the single-byte case */
2116 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2120 Bufbyte *ptr = XSTRING_DATA (val);
2122 for (i = XINT (length); i; i--)
2124 Bufbyte *init_ptr = init_str;
2127 case 4: *ptr++ = *init_ptr++;
2128 case 3: *ptr++ = *init_ptr++;
2129 case 2: *ptr++ = *init_ptr++;
2130 case 1: *ptr++ = *init_ptr++;
2138 DEFUN ("string", Fstring, 0, MANY, 0, /*
2139 Concatenate all the argument characters and make the result a string.
2141 (int nargs, Lisp_Object *args))
2143 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2144 Bufbyte *p = storage;
2146 for (; nargs; nargs--, args++)
2148 Lisp_Object lisp_char = *args;
2149 CHECK_CHAR_COERCE_INT (lisp_char);
2150 p += set_charptr_emchar (p, XCHAR (lisp_char));
2152 return make_string (storage, p - storage);
2156 /* Take some raw memory, which MUST already be in internal format,
2157 and package it up into a Lisp string. */
2159 make_string (const Bufbyte *contents, Bytecount length)
2163 /* Make sure we find out about bad make_string's when they happen */
2164 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2165 bytecount_to_charcount (contents, length); /* Just for the assertions */
2168 val = make_uninit_string (length);
2169 memcpy (XSTRING_DATA (val), contents, length);
2173 /* Take some raw memory, encoded in some external data format,
2174 and convert it into a Lisp string. */
2176 make_ext_string (const Extbyte *contents, EMACS_INT length,
2177 Lisp_Object coding_system)
2180 TO_INTERNAL_FORMAT (DATA, (contents, length),
2181 LISP_STRING, string,
2187 build_string (const char *str)
2189 /* Some strlen's crash and burn if passed null. */
2190 return make_string ((const Bufbyte *) str, (str ? strlen(str) : 0));
2194 build_ext_string (const char *str, Lisp_Object coding_system)
2196 /* Some strlen's crash and burn if passed null. */
2197 return make_ext_string ((const Extbyte *) str, (str ? strlen(str) : 0),
2202 build_translated_string (const char *str)
2204 return build_string (GETTEXT (str));
2208 make_string_nocopy (const Bufbyte *contents, Bytecount length)
2213 /* Make sure we find out about bad make_string_nocopy's when they happen */
2214 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2215 bytecount_to_charcount (contents, length); /* Just for the assertions */
2218 /* Allocate the string header */
2219 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2220 set_lheader_implementation (&(s->lheader), &lrecord_string);
2221 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2223 set_string_data (s, (Bufbyte *)contents);
2224 set_string_length (s, length);
2226 XSETSTRING (val, s);
2231 /************************************************************************/
2232 /* lcrecord lists */
2233 /************************************************************************/
2235 /* Lcrecord lists are used to manage the allocation of particular
2236 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2237 malloc() and garbage-collection junk) as much as possible.
2238 It is similar to the Blocktype class.
2242 1) Create an lcrecord-list object using make_lcrecord_list().
2243 This is often done at initialization. Remember to staticpro_nodump
2244 this object! The arguments to make_lcrecord_list() are the
2245 same as would be passed to alloc_lcrecord().
2246 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2247 and pass the lcrecord-list earlier created.
2248 3) When done with the lcrecord, call free_managed_lcrecord().
2249 The standard freeing caveats apply: ** make sure there are no
2250 pointers to the object anywhere! **
2251 4) Calling free_managed_lcrecord() is just like kissing the
2252 lcrecord goodbye as if it were garbage-collected. This means:
2253 -- the contents of the freed lcrecord are undefined, and the
2254 contents of something produced by allocate_managed_lcrecord()
2255 are undefined, just like for alloc_lcrecord().
2256 -- the mark method for the lcrecord's type will *NEVER* be called
2258 -- the finalize method for the lcrecord's type will be called
2259 at the time that free_managed_lcrecord() is called.
2264 mark_lcrecord_list (Lisp_Object obj)
2266 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2267 Lisp_Object chain = list->free;
2269 while (!NILP (chain))
2271 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2272 struct free_lcrecord_header *free_header =
2273 (struct free_lcrecord_header *) lheader;
2275 #ifdef ERROR_CHECK_GC
2276 const struct lrecord_implementation *implementation
2277 = LHEADER_IMPLEMENTATION(lheader);
2279 /* There should be no other pointers to the free list. */
2280 assert (!MARKED_RECORD_HEADER_P (lheader));
2281 /* Only lcrecords should be here. */
2282 assert (!implementation->basic_p);
2283 /* Only free lcrecords should be here. */
2284 assert (free_header->lcheader.free);
2285 /* The type of the lcrecord must be right. */
2286 assert (implementation == list->implementation);
2287 /* So must the size. */
2288 assert (implementation->static_size == 0
2289 || implementation->static_size == list->size);
2290 #endif /* ERROR_CHECK_GC */
2292 MARK_RECORD_HEADER (lheader);
2293 chain = free_header->chain;
2299 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2300 mark_lcrecord_list, internal_object_printer,
2301 0, 0, 0, 0, struct lcrecord_list);
2303 make_lcrecord_list (size_t size,
2304 const struct lrecord_implementation *implementation)
2306 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2307 &lrecord_lcrecord_list);
2310 p->implementation = implementation;
2313 XSETLCRECORD_LIST (val, p);
2318 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2320 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2321 if (!NILP (list->free))
2323 Lisp_Object val = list->free;
2324 struct free_lcrecord_header *free_header =
2325 (struct free_lcrecord_header *) XPNTR (val);
2327 #ifdef ERROR_CHECK_GC
2328 struct lrecord_header *lheader =
2329 (struct lrecord_header *) free_header;
2330 const struct lrecord_implementation *implementation
2331 = LHEADER_IMPLEMENTATION (lheader);
2333 /* There should be no other pointers to the free list. */
2334 assert (!MARKED_RECORD_HEADER_P (lheader));
2335 /* Only lcrecords should be here. */
2336 assert (!implementation->basic_p);
2337 /* Only free lcrecords should be here. */
2338 assert (free_header->lcheader.free);
2339 /* The type of the lcrecord must be right. */
2340 assert (implementation == list->implementation);
2341 /* So must the size. */
2342 assert (implementation->static_size == 0
2343 || implementation->static_size == list->size);
2344 #endif /* ERROR_CHECK_GC */
2345 list->free = free_header->chain;
2346 free_header->lcheader.free = 0;
2353 XSETOBJ (val, Lisp_Type_Record,
2354 alloc_lcrecord (list->size, list->implementation));
2360 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2362 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2363 struct free_lcrecord_header *free_header =
2364 (struct free_lcrecord_header *) XPNTR (lcrecord);
2365 struct lrecord_header *lheader =
2366 (struct lrecord_header *) free_header;
2367 const struct lrecord_implementation *implementation
2368 = LHEADER_IMPLEMENTATION (lheader);
2370 #ifdef ERROR_CHECK_GC
2371 /* Make sure the size is correct. This will catch, for example,
2372 putting a window configuration on the wrong free list. */
2373 if (implementation->size_in_bytes_method)
2374 assert (implementation->size_in_bytes_method (lheader) == list->size);
2376 assert (implementation->static_size == list->size);
2377 #endif /* ERROR_CHECK_GC */
2379 if (implementation->finalizer)
2380 implementation->finalizer (lheader, 0);
2381 free_header->chain = list->free;
2382 free_header->lcheader.free = 1;
2383 list->free = lcrecord;
2389 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2390 Kept for compatibility, returns its argument.
2392 Make a copy of OBJECT in pure storage.
2393 Recursively copies contents of vectors and cons cells.
2394 Does not copy symbols.
2403 /************************************************************************/
2404 /* Garbage Collection */
2405 /************************************************************************/
2407 /* This will be used more extensively In The Future */
2408 static int last_lrecord_type_index_assigned;
2410 const struct lrecord_implementation *lrecord_implementations_table[128];
2411 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
2413 struct gcpro *gcprolist;
2415 /* 415 used Mly 29-Jun-93 */
2416 /* 1327 used slb 28-Feb-98 */
2417 /* 1328 used og 03-Oct-99 (moving slowly, heh?) */
2419 #define NSTATICS 4000
2421 #define NSTATICS 2000
2423 /* Not "static" because of linker lossage on some systems */
2424 Lisp_Object *staticvec[NSTATICS]
2425 /* Force it into data space! */
2427 static int staticidx;
2429 /* Put an entry in staticvec, pointing at the variable whose address is given
2432 staticpro (Lisp_Object *varaddress)
2434 if (staticidx >= countof (staticvec))
2435 /* #### This is now a dubious abort() since this routine may be called */
2436 /* by Lisp attempting to load a DLL. */
2438 staticvec[staticidx++] = varaddress;
2441 /* Not "static" because of linker lossage on some systems */
2442 Lisp_Object *staticvec_nodump[200]
2443 /* Force it into data space! */
2445 static int staticidx_nodump;
2447 /* Put an entry in staticvec_nodump, pointing at the variable whose address is given
2450 staticpro_nodump (Lisp_Object *varaddress)
2452 if (staticidx_nodump >= countof (staticvec_nodump))
2453 /* #### This is now a dubious abort() since this routine may be called */
2454 /* by Lisp attempting to load a DLL. */
2456 staticvec_nodump[staticidx_nodump++] = varaddress;
2459 /* Not "static" because of linker lossage on some systems */
2463 const struct struct_description *desc;
2464 } dumpstructvec[200];
2466 static int dumpstructidx;
2468 /* Put an entry in dumpstructvec, pointing at the variable whose address is given
2471 dumpstruct (void *varaddress, const struct struct_description *desc)
2473 if (dumpstructidx >= countof (dumpstructvec))
2475 dumpstructvec[dumpstructidx].data = varaddress;
2476 dumpstructvec[dumpstructidx].desc = desc;
2480 /* Not "static" because of linker lossage on some systems */
2481 struct dumpopaque_info
2485 } dumpopaquevec[200];
2487 static int dumpopaqueidx;
2489 /* Put an entry in dumpopaquevec, pointing at the variable whose address is given
2492 dumpopaque (void *varaddress, size_t size)
2494 if (dumpopaqueidx >= countof (dumpopaquevec))
2496 dumpopaquevec[dumpopaqueidx].data = varaddress;
2497 dumpopaquevec[dumpopaqueidx].size = size;
2501 Lisp_Object *pdump_wirevec[50];
2502 static int pdump_wireidx;
2504 /* Put an entry in pdump_wirevec, pointing at the variable whose address is given
2507 pdump_wire (Lisp_Object *varaddress)
2509 if (pdump_wireidx >= countof (pdump_wirevec))
2511 pdump_wirevec[pdump_wireidx++] = varaddress;
2515 Lisp_Object *pdump_wirevec_list[50];
2516 static int pdump_wireidx_list;
2518 /* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given
2521 pdump_wire_list (Lisp_Object *varaddress)
2523 if (pdump_wireidx_list >= countof (pdump_wirevec_list))
2525 pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
2529 /* Mark reference to a Lisp_Object. If the object referred to has not been
2530 seen yet, recursively mark all the references contained in it. */
2533 mark_object (Lisp_Object obj)
2537 #ifdef ERROR_CHECK_GC
2538 assert (! (EQ (obj, Qnull_pointer)));
2540 /* Checks we used to perform */
2541 /* if (EQ (obj, Qnull_pointer)) return; */
2542 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2543 /* if (PURIFIED (XPNTR (obj))) return; */
2545 if (XTYPE (obj) == Lisp_Type_Record)
2547 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2548 #if defined (ERROR_CHECK_GC)
2549 assert (lheader->type <= last_lrecord_type_index_assigned);
2551 if (C_READONLY_RECORD_HEADER_P (lheader))
2554 if (! MARKED_RECORD_HEADER_P (lheader) &&
2555 ! UNMARKABLE_RECORD_HEADER_P (lheader))
2557 const struct lrecord_implementation *implementation =
2558 LHEADER_IMPLEMENTATION (lheader);
2559 MARK_RECORD_HEADER (lheader);
2560 #ifdef ERROR_CHECK_GC
2561 if (!implementation->basic_p)
2562 assert (! ((struct lcrecord_header *) lheader)->free);
2564 if (implementation->marker)
2566 obj = implementation->marker (obj);
2567 if (!NILP (obj)) goto tail_recurse;
2573 /* mark all of the conses in a list and mark the final cdr; but
2574 DO NOT mark the cars.
2576 Use only for internal lists! There should never be other pointers
2577 to the cons cells, because if so, the cars will remain unmarked
2578 even when they maybe should be marked. */
2580 mark_conses_in_list (Lisp_Object obj)
2584 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2586 if (CONS_MARKED_P (XCONS (rest)))
2588 MARK_CONS (XCONS (rest));
2595 /* Find all structures not marked, and free them. */
2597 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2598 static int gc_count_bit_vector_storage;
2599 static int gc_count_num_short_string_in_use;
2600 static int gc_count_string_total_size;
2601 static int gc_count_short_string_total_size;
2603 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2607 lrecord_type_index (const struct lrecord_implementation *implementation)
2609 int type_index = *(implementation->lrecord_type_index);
2610 /* Have to do this circuitous validation test because of problems
2611 dumping out initialized variables (ie can't set xxx_type_index to -1
2612 because that would make xxx_type_index read-only in a dumped emacs. */
2613 if (type_index < 0 || type_index > max_lrecord_type
2614 || lrecord_implementations_table[type_index] != implementation)
2616 assert (last_lrecord_type_index_assigned < max_lrecord_type);
2617 type_index = ++last_lrecord_type_index_assigned;
2618 lrecord_implementations_table[type_index] = implementation;
2619 *(implementation->lrecord_type_index) = type_index;
2624 /* stats on lcrecords in use - kinda kludgy */
2628 int instances_in_use;
2630 int instances_freed;
2632 int instances_on_free_list;
2633 } lcrecord_stats [countof (lrecord_implementations_table)];
2636 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
2638 const struct lrecord_implementation *implementation =
2639 LHEADER_IMPLEMENTATION (h);
2640 int type_index = lrecord_type_index (implementation);
2642 if (((struct lcrecord_header *) h)->free)
2645 lcrecord_stats[type_index].instances_on_free_list++;
2649 size_t sz = (implementation->size_in_bytes_method
2650 ? implementation->size_in_bytes_method (h)
2651 : implementation->static_size);
2655 lcrecord_stats[type_index].instances_freed++;
2656 lcrecord_stats[type_index].bytes_freed += sz;
2660 lcrecord_stats[type_index].instances_in_use++;
2661 lcrecord_stats[type_index].bytes_in_use += sz;
2667 /* Free all unmarked records */
2669 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2671 struct lcrecord_header *header;
2673 /* int total_size = 0; */
2675 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2677 /* First go through and call all the finalize methods.
2678 Then go through and free the objects. There used to
2679 be only one loop here, with the call to the finalizer
2680 occurring directly before the xfree() below. That
2681 is marginally faster but much less safe -- if the
2682 finalize method for an object needs to reference any
2683 other objects contained within it (and many do),
2684 we could easily be screwed by having already freed that
2687 for (header = *prev; header; header = header->next)
2689 struct lrecord_header *h = &(header->lheader);
2690 if (!C_READONLY_RECORD_HEADER_P(h)
2691 && !MARKED_RECORD_HEADER_P (h)
2692 && ! (header->free))
2694 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2695 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2699 for (header = *prev; header; )
2701 struct lrecord_header *h = &(header->lheader);
2702 if (C_READONLY_RECORD_HEADER_P(h) || MARKED_RECORD_HEADER_P (h))
2704 if (MARKED_RECORD_HEADER_P (h))
2705 UNMARK_RECORD_HEADER (h);
2707 /* total_size += n->implementation->size_in_bytes (h);*/
2708 /* #### May modify header->next on a C_READONLY lcrecord */
2709 prev = &(header->next);
2711 tick_lcrecord_stats (h, 0);
2715 struct lcrecord_header *next = header->next;
2717 tick_lcrecord_stats (h, 1);
2718 /* used to call finalizer right here. */
2724 /* *total = total_size; */
2729 sweep_bit_vectors_1 (Lisp_Object *prev,
2730 int *used, int *total, int *storage)
2732 Lisp_Object bit_vector;
2735 int total_storage = 0;
2737 /* BIT_VECTORP fails because the objects are marked, which changes
2738 their implementation */
2739 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2741 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2743 if (C_READONLY_RECORD_HEADER_P(&(v->lheader)) || MARKED_RECORD_P (bit_vector))
2745 if (MARKED_RECORD_P (bit_vector))
2746 UNMARK_RECORD_HEADER (&(v->lheader));
2750 offsetof (Lisp_Bit_Vector, bits[BIT_VECTOR_LONG_STORAGE (len)]);
2752 /* #### May modify next on a C_READONLY bitvector */
2753 prev = &(bit_vector_next (v));
2758 Lisp_Object next = bit_vector_next (v);
2765 *total = total_size;
2766 *storage = total_storage;
2769 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2770 to make macros prettier. */
2772 #ifdef ERROR_CHECK_GC
2774 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2776 struct typename##_block *SFTB_current; \
2777 struct typename##_block **SFTB_prev; \
2779 int num_free = 0, num_used = 0; \
2781 for (SFTB_prev = ¤t_##typename##_block, \
2782 SFTB_current = current_##typename##_block, \
2783 SFTB_limit = current_##typename##_block_index; \
2789 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2791 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2793 if (FREE_STRUCT_P (SFTB_victim)) \
2797 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2801 else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2804 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2809 UNMARK_##typename (SFTB_victim); \
2812 SFTB_prev = &(SFTB_current->prev); \
2813 SFTB_current = SFTB_current->prev; \
2814 SFTB_limit = countof (current_##typename##_block->block); \
2817 gc_count_num_##typename##_in_use = num_used; \
2818 gc_count_num_##typename##_freelist = num_free; \
2821 #else /* !ERROR_CHECK_GC */
2823 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2825 struct typename##_block *SFTB_current; \
2826 struct typename##_block **SFTB_prev; \
2828 int num_free = 0, num_used = 0; \
2830 typename##_free_list = 0; \
2832 for (SFTB_prev = ¤t_##typename##_block, \
2833 SFTB_current = current_##typename##_block, \
2834 SFTB_limit = current_##typename##_block_index; \
2839 int SFTB_empty = 1; \
2840 obj_type *SFTB_old_free_list = typename##_free_list; \
2842 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2844 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2846 if (FREE_STRUCT_P (SFTB_victim)) \
2849 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2851 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2856 else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2859 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2865 UNMARK_##typename (SFTB_victim); \
2870 SFTB_prev = &(SFTB_current->prev); \
2871 SFTB_current = SFTB_current->prev; \
2873 else if (SFTB_current == current_##typename##_block \
2874 && !SFTB_current->prev) \
2876 /* No real point in freeing sole allocation block */ \
2881 struct typename##_block *SFTB_victim_block = SFTB_current; \
2882 if (SFTB_victim_block == current_##typename##_block) \
2883 current_##typename##_block_index \
2884 = countof (current_##typename##_block->block); \
2885 SFTB_current = SFTB_current->prev; \
2887 *SFTB_prev = SFTB_current; \
2888 xfree (SFTB_victim_block); \
2889 /* Restore free list to what it was before victim was swept */ \
2890 typename##_free_list = SFTB_old_free_list; \
2891 num_free -= SFTB_limit; \
2894 SFTB_limit = countof (current_##typename##_block->block); \
2897 gc_count_num_##typename##_in_use = num_used; \
2898 gc_count_num_##typename##_freelist = num_free; \
2901 #endif /* !ERROR_CHECK_GC */
2909 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2910 #define ADDITIONAL_FREE_cons(ptr)
2912 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2915 /* Explicitly free a cons cell. */
2917 free_cons (Lisp_Cons *ptr)
2919 #ifdef ERROR_CHECK_GC
2920 /* If the CAR is not an int, then it will be a pointer, which will
2921 always be four-byte aligned. If this cons cell has already been
2922 placed on the free list, however, its car will probably contain
2923 a chain pointer to the next cons on the list, which has cleverly
2924 had all its 0's and 1's inverted. This allows for a quick
2925 check to make sure we're not freeing something already freed. */
2926 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2927 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2928 #endif /* ERROR_CHECK_GC */
2930 #ifndef ALLOC_NO_POOLS
2931 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2932 #endif /* ALLOC_NO_POOLS */
2935 /* explicitly free a list. You **must make sure** that you have
2936 created all the cons cells that make up this list and that there
2937 are no pointers to any of these cons cells anywhere else. If there
2938 are, you will lose. */
2941 free_list (Lisp_Object list)
2943 Lisp_Object rest, next;
2945 for (rest = list; !NILP (rest); rest = next)
2948 free_cons (XCONS (rest));
2952 /* explicitly free an alist. You **must make sure** that you have
2953 created all the cons cells that make up this alist and that there
2954 are no pointers to any of these cons cells anywhere else. If there
2955 are, you will lose. */
2958 free_alist (Lisp_Object alist)
2960 Lisp_Object rest, next;
2962 for (rest = alist; !NILP (rest); rest = next)
2965 free_cons (XCONS (XCAR (rest)));
2966 free_cons (XCONS (rest));
2971 sweep_compiled_functions (void)
2973 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2974 #define ADDITIONAL_FREE_compiled_function(ptr)
2976 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2980 #ifdef LISP_FLOAT_TYPE
2984 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2985 #define ADDITIONAL_FREE_float(ptr)
2987 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
2989 #endif /* LISP_FLOAT_TYPE */
2992 sweep_symbols (void)
2994 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2995 #define ADDITIONAL_FREE_symbol(ptr)
2997 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
3001 sweep_extents (void)
3003 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3004 #define ADDITIONAL_FREE_extent(ptr)
3006 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
3012 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3013 #define ADDITIONAL_FREE_event(ptr)
3015 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
3019 sweep_markers (void)
3021 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3022 #define ADDITIONAL_FREE_marker(ptr) \
3023 do { Lisp_Object tem; \
3024 XSETMARKER (tem, ptr); \
3025 unchain_marker (tem); \
3028 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
3031 /* Explicitly free a marker. */
3033 free_marker (Lisp_Marker *ptr)
3035 #ifdef ERROR_CHECK_GC
3036 /* Perhaps this will catch freeing an already-freed marker. */
3038 XSETMARKER (temmy, ptr);
3039 assert (MARKERP (temmy));
3040 #endif /* ERROR_CHECK_GC */
3042 #ifndef ALLOC_NO_POOLS
3043 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
3044 #endif /* ALLOC_NO_POOLS */
3048 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
3051 verify_string_chars_integrity (void)
3053 struct string_chars_block *sb;
3055 /* Scan each existing string block sequentially, string by string. */
3056 for (sb = first_string_chars_block; sb; sb = sb->next)
3059 /* POS is the index of the next string in the block. */
3060 while (pos < sb->pos)
3062 struct string_chars *s_chars =
3063 (struct string_chars *) &(sb->string_chars[pos]);
3064 Lisp_String *string;
3068 /* If the string_chars struct is marked as free (i.e. the STRING
3069 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3070 storage. (See below.) */
3072 if (FREE_STRUCT_P (s_chars))
3074 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3079 string = s_chars->string;
3080 /* Must be 32-bit aligned. */
3081 assert ((((int) string) & 3) == 0);
3083 size = string_length (string);
3084 fullsize = STRING_FULLSIZE (size);
3086 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3087 assert (string_data (string) == s_chars->chars);
3090 assert (pos == sb->pos);
3094 #endif /* MULE && ERROR_CHECK_GC */
3096 /* Compactify string chars, relocating the reference to each --
3097 free any empty string_chars_block we see. */
3099 compact_string_chars (void)
3101 struct string_chars_block *to_sb = first_string_chars_block;
3103 struct string_chars_block *from_sb;
3105 /* Scan each existing string block sequentially, string by string. */
3106 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3109 /* FROM_POS is the index of the next string in the block. */
3110 while (from_pos < from_sb->pos)
3112 struct string_chars *from_s_chars =
3113 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3114 struct string_chars *to_s_chars;
3115 Lisp_String *string;
3119 /* If the string_chars struct is marked as free (i.e. the STRING
3120 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3121 storage. This happens under Mule when a string's size changes
3122 in such a way that its fullsize changes. (Strings can change
3123 size because a different-length character can be substituted
3124 for another character.) In this case, after the bogus string
3125 pointer is the "fullsize" of this entry, i.e. how many bytes
3128 if (FREE_STRUCT_P (from_s_chars))
3130 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3131 from_pos += fullsize;
3135 string = from_s_chars->string;
3136 assert (!(FREE_STRUCT_P (string)));
3138 size = string_length (string);
3139 fullsize = STRING_FULLSIZE (size);
3141 if (BIG_STRING_FULLSIZE_P (fullsize))
3144 /* Just skip it if it isn't marked. */
3145 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3147 from_pos += fullsize;
3151 /* If it won't fit in what's left of TO_SB, close TO_SB out
3152 and go on to the next string_chars_block. We know that TO_SB
3153 cannot advance past FROM_SB here since FROM_SB is large enough
3154 to currently contain this string. */
3155 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3157 to_sb->pos = to_pos;
3158 to_sb = to_sb->next;
3162 /* Compute new address of this string
3163 and update TO_POS for the space being used. */
3164 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3166 /* Copy the string_chars to the new place. */
3167 if (from_s_chars != to_s_chars)
3168 memmove (to_s_chars, from_s_chars, fullsize);
3170 /* Relocate FROM_S_CHARS's reference */
3171 set_string_data (string, &(to_s_chars->chars[0]));
3173 from_pos += fullsize;
3178 /* Set current to the last string chars block still used and
3179 free any that follow. */
3181 struct string_chars_block *victim;
3183 for (victim = to_sb->next; victim; )
3185 struct string_chars_block *next = victim->next;
3190 current_string_chars_block = to_sb;
3191 current_string_chars_block->pos = to_pos;
3192 current_string_chars_block->next = 0;
3196 #if 1 /* Hack to debug missing purecopy's */
3197 static int debug_string_purity;
3200 debug_string_purity_print (Lisp_String *p)
3203 Charcount s = string_char_length (p);
3204 putc ('\"', stderr);
3205 for (i = 0; i < s; i++)
3207 Emchar ch = string_char (p, i);
3208 if (ch < 32 || ch >= 126)
3209 stderr_out ("\\%03o", ch);
3210 else if (ch == '\\' || ch == '\"')
3211 stderr_out ("\\%c", ch);
3213 stderr_out ("%c", ch);
3215 stderr_out ("\"\n");
3221 sweep_strings (void)
3223 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3224 int debug = debug_string_purity;
3226 #define UNMARK_string(ptr) do { \
3227 Lisp_String *p = (ptr); \
3228 size_t size = string_length (p); \
3229 UNMARK_RECORD_HEADER (&(p->lheader)); \
3230 num_bytes += size; \
3231 if (!BIG_STRING_SIZE_P (size)) \
3232 { num_small_bytes += size; \
3236 debug_string_purity_print (p); \
3238 #define ADDITIONAL_FREE_string(ptr) do { \
3239 size_t size = string_length (ptr); \
3240 if (BIG_STRING_SIZE_P (size)) \
3241 xfree (ptr->data); \
3244 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3246 gc_count_num_short_string_in_use = num_small_used;
3247 gc_count_string_total_size = num_bytes;
3248 gc_count_short_string_total_size = num_small_bytes;
3252 /* I hate duplicating all this crap! */
3254 marked_p (Lisp_Object obj)
3256 #ifdef ERROR_CHECK_GC
3257 assert (! (EQ (obj, Qnull_pointer)));
3259 /* Checks we used to perform. */
3260 /* if (EQ (obj, Qnull_pointer)) return 1; */
3261 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3262 /* if (PURIFIED (XPNTR (obj))) return 1; */
3264 if (XTYPE (obj) == Lisp_Type_Record)
3266 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3267 #if defined (ERROR_CHECK_GC)
3268 assert (lheader->type <= last_lrecord_type_index_assigned);
3270 return C_READONLY_RECORD_HEADER_P (lheader) || MARKED_RECORD_HEADER_P (lheader);
3278 /* Free all unmarked records. Do this at the very beginning,
3279 before anything else, so that the finalize methods can safely
3280 examine items in the objects. sweep_lcrecords_1() makes
3281 sure to call all the finalize methods *before* freeing anything,
3282 to complete the safety. */
3285 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3288 compact_string_chars ();
3290 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3291 macros) must be *extremely* careful to make sure they're not
3292 referencing freed objects. The only two existing finalize
3293 methods (for strings and markers) pass muster -- the string
3294 finalizer doesn't look at anything but its own specially-
3295 created block, and the marker finalizer only looks at live
3296 buffers (which will never be freed) and at the markers before
3297 and after it in the chain (which, by induction, will never be
3298 freed because if so, they would have already removed themselves
3301 /* Put all unmarked strings on free list, free'ing the string chars
3302 of large unmarked strings */
3305 /* Put all unmarked conses on free list */
3308 /* Free all unmarked bit vectors */
3309 sweep_bit_vectors_1 (&all_bit_vectors,
3310 &gc_count_num_bit_vector_used,
3311 &gc_count_bit_vector_total_size,
3312 &gc_count_bit_vector_storage);
3314 /* Free all unmarked compiled-function objects */
3315 sweep_compiled_functions ();
3317 #ifdef LISP_FLOAT_TYPE
3318 /* Put all unmarked floats on free list */
3322 /* Put all unmarked symbols on free list */
3325 /* Put all unmarked extents on free list */
3328 /* Put all unmarked markers on free list.
3329 Dechain each one first from the buffer into which it points. */
3335 /* Unmark all dumped objects */
3338 char *p = pdump_rt_list;
3342 pdump_reloc_table *rt = (pdump_reloc_table *)p;
3343 p += sizeof (pdump_reloc_table);
3346 for (i=0; i<rt->count; i++)
3348 UNMARK_RECORD_HEADER ((struct lrecord_header *)(*(EMACS_INT *)p));
3349 p += sizeof (EMACS_INT);
3358 /* Clearing for disksave. */
3361 disksave_object_finalization (void)
3363 /* It's important that certain information from the environment not get
3364 dumped with the executable (pathnames, environment variables, etc.).
3365 To make it easier to tell when this has happened with strings(1) we
3366 clear some known-to-be-garbage blocks of memory, so that leftover
3367 results of old evaluation don't look like potential problems.
3368 But first we set some notable variables to nil and do one more GC,
3369 to turn those strings into garbage.
3372 /* Yeah, this list is pretty ad-hoc... */
3373 Vprocess_environment = Qnil;
3374 Vexec_directory = Qnil;
3375 Vdata_directory = Qnil;
3376 Vsite_directory = Qnil;
3377 Vdoc_directory = Qnil;
3378 Vconfigure_info_directory = Qnil;
3381 /* Vdump_load_path = Qnil; */
3382 /* Release hash tables for locate_file */
3383 Flocate_file_clear_hashing (Qt);
3384 uncache_home_directory();
3386 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3387 defined(LOADHIST_BUILTIN))
3388 Vload_history = Qnil;
3390 Vshell_file_name = Qnil;
3392 garbage_collect_1 ();
3394 /* Run the disksave finalization methods of all live objects. */
3395 disksave_object_finalization_1 ();
3397 /* Zero out the uninitialized (really, unused) part of the containers
3398 for the live strings. */
3400 struct string_chars_block *scb;
3401 for (scb = first_string_chars_block; scb; scb = scb->next)
3403 int count = sizeof (scb->string_chars) - scb->pos;
3405 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3408 /* from the block's fill ptr to the end */
3409 memset ((scb->string_chars + scb->pos), 0, count);
3414 /* There, that ought to be enough... */
3420 restore_gc_inhibit (Lisp_Object val)
3422 gc_currently_forbidden = XINT (val);
3426 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3427 static int gc_hooks_inhibited;
3431 garbage_collect_1 (void)
3433 #if MAX_SAVE_STACK > 0
3434 char stack_top_variable;
3435 extern char *stack_bottom;
3440 Lisp_Object pre_gc_cursor;
3441 struct gcpro gcpro1;
3444 || gc_currently_forbidden
3446 || preparing_for_armageddon)
3449 /* We used to call selected_frame() here.
3451 The following functions cannot be called inside GC
3452 so we move to after the above tests. */
3455 Lisp_Object device = Fselected_device (Qnil);
3456 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3458 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3460 signal_simple_error ("No frames exist on device", device);
3464 pre_gc_cursor = Qnil;
3467 GCPRO1 (pre_gc_cursor);
3469 /* Very important to prevent GC during any of the following
3470 stuff that might run Lisp code; otherwise, we'll likely
3471 have infinite GC recursion. */
3472 speccount = specpdl_depth ();
3473 record_unwind_protect (restore_gc_inhibit,
3474 make_int (gc_currently_forbidden));
3475 gc_currently_forbidden = 1;
3477 if (!gc_hooks_inhibited)
3478 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3480 /* Now show the GC cursor/message. */
3481 if (!noninteractive)
3483 if (FRAME_WIN_P (f))
3485 Lisp_Object frame = make_frame (f);
3486 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3487 FRAME_SELECTED_WINDOW (f),
3489 pre_gc_cursor = f->pointer;
3490 if (POINTER_IMAGE_INSTANCEP (cursor)
3491 /* don't change if we don't know how to change back. */
3492 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3495 Fset_frame_pointer (frame, cursor);
3499 /* Don't print messages to the stream device. */
3500 if (!cursor_changed && !FRAME_STREAM_P (f))
3502 char *msg = (STRINGP (Vgc_message)
3503 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3505 Lisp_Object args[2], whole_msg;
3506 args[0] = build_string (msg ? msg :
3507 GETTEXT ((const char *) gc_default_message));
3508 args[1] = build_string ("...");
3509 whole_msg = Fconcat (2, args);
3510 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3511 Qgarbage_collecting);
3515 /***** Now we actually start the garbage collection. */
3519 gc_generation_number[0]++;
3521 #if MAX_SAVE_STACK > 0
3523 /* Save a copy of the contents of the stack, for debugging. */
3526 /* Static buffer in which we save a copy of the C stack at each GC. */
3527 static char *stack_copy;
3528 static size_t stack_copy_size;
3530 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3531 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3532 if (stack_size < MAX_SAVE_STACK)
3534 if (stack_copy_size < stack_size)
3536 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3537 stack_copy_size = stack_size;
3541 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3545 #endif /* MAX_SAVE_STACK > 0 */
3547 /* Do some totally ad-hoc resource clearing. */
3548 /* #### generalize this? */
3549 clear_event_resource ();
3550 cleanup_specifiers ();
3552 /* Mark all the special slots that serve as the roots of accessibility. */
3556 for (i = 0; i < staticidx; i++)
3557 mark_object (*(staticvec[i]));
3558 for (i = 0; i < staticidx_nodump; i++)
3559 mark_object (*(staticvec_nodump[i]));
3565 for (tail = gcprolist; tail; tail = tail->next)
3566 for (i = 0; i < tail->nvars; i++)
3567 mark_object (tail->var[i]);
3571 struct specbinding *bind;
3572 for (bind = specpdl; bind != specpdl_ptr; bind++)
3574 mark_object (bind->symbol);
3575 mark_object (bind->old_value);
3580 struct catchtag *catch;
3581 for (catch = catchlist; catch; catch = catch->next)
3583 mark_object (catch->tag);
3584 mark_object (catch->val);
3589 struct backtrace *backlist;
3590 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3592 int nargs = backlist->nargs;
3595 mark_object (*backlist->function);
3596 if (nargs == UNEVALLED || nargs == MANY)
3597 mark_object (backlist->args[0]);
3599 for (i = 0; i < nargs; i++)
3600 mark_object (backlist->args[i]);
3605 mark_profiling_info ();
3607 /* OK, now do the after-mark stuff. This is for things that
3608 are only marked when something else is marked (e.g. weak hash tables).
3609 There may be complex dependencies between such objects -- e.g.
3610 a weak hash table might be unmarked, but after processing a later
3611 weak hash table, the former one might get marked. So we have to
3612 iterate until nothing more gets marked. */
3614 while (finish_marking_weak_hash_tables () > 0 ||
3615 finish_marking_weak_lists () > 0)
3618 /* And prune (this needs to be called after everything else has been
3619 marked and before we do any sweeping). */
3620 /* #### this is somewhat ad-hoc and should probably be an object
3622 prune_weak_hash_tables ();
3623 prune_weak_lists ();
3624 prune_specifiers ();
3625 prune_syntax_tables ();
3629 consing_since_gc = 0;
3630 #ifndef DEBUG_XEMACS
3631 /* Allow you to set it really fucking low if you really want ... */
3632 if (gc_cons_threshold < 10000)
3633 gc_cons_threshold = 10000;
3638 /******* End of garbage collection ********/
3640 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3642 /* Now remove the GC cursor/message */
3643 if (!noninteractive)
3646 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3647 else if (!FRAME_STREAM_P (f))
3649 char *msg = (STRINGP (Vgc_message)
3650 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3653 /* Show "...done" only if the echo area would otherwise be empty. */
3654 if (NILP (clear_echo_area (selected_frame (),
3655 Qgarbage_collecting, 0)))
3657 Lisp_Object args[2], whole_msg;
3658 args[0] = build_string (msg ? msg :
3659 GETTEXT ((const char *)
3660 gc_default_message));
3661 args[1] = build_string ("... done");
3662 whole_msg = Fconcat (2, args);
3663 echo_area_message (selected_frame (), (Bufbyte *) 0,
3665 Qgarbage_collecting);
3670 /* now stop inhibiting GC */
3671 unbind_to (speccount, Qnil);
3673 if (!breathing_space)
3675 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3682 /* Debugging aids. */
3685 gc_plist_hack (const char *name, int value, Lisp_Object tail)
3687 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3688 or portable numeric datatypes, or bit-vectors, or characters, or
3689 arrays, or exceptions, or ...) */
3690 return cons3 (intern (name), make_int (value), tail);
3693 #define HACK_O_MATIC(type, name, pl) do { \
3695 struct type##_block *x = current_##type##_block; \
3696 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3697 (pl) = gc_plist_hack ((name), s, (pl)); \
3700 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3701 Reclaim storage for Lisp objects no longer needed.
3702 Return info on amount of space in use:
3703 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3704 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3706 where `PLIST' is a list of alternating keyword/value pairs providing
3707 more detailed information.
3708 Garbage collection happens automatically if you cons more than
3709 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3713 Lisp_Object pl = Qnil;
3715 int gc_count_vector_total_size = 0;
3717 garbage_collect_1 ();
3719 for (i = 0; i <= last_lrecord_type_index_assigned; i++)
3721 if (lcrecord_stats[i].bytes_in_use != 0
3722 || lcrecord_stats[i].bytes_freed != 0
3723 || lcrecord_stats[i].instances_on_free_list != 0)
3726 const char *name = lrecord_implementations_table[i]->name;
3727 int len = strlen (name);
3728 /* save this for the FSFmacs-compatible part of the summary */
3729 if (i == *lrecord_vector.lrecord_type_index)
3730 gc_count_vector_total_size =
3731 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3733 sprintf (buf, "%s-storage", name);
3734 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3735 /* Okay, simple pluralization check for `symbol-value-varalias' */
3736 if (name[len-1] == 's')
3737 sprintf (buf, "%ses-freed", name);
3739 sprintf (buf, "%ss-freed", name);
3740 if (lcrecord_stats[i].instances_freed != 0)
3741 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3742 if (name[len-1] == 's')
3743 sprintf (buf, "%ses-on-free-list", name);
3745 sprintf (buf, "%ss-on-free-list", name);
3746 if (lcrecord_stats[i].instances_on_free_list != 0)
3747 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3749 if (name[len-1] == 's')
3750 sprintf (buf, "%ses-used", name);
3752 sprintf (buf, "%ss-used", name);
3753 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3757 HACK_O_MATIC (extent, "extent-storage", pl);
3758 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3759 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3760 HACK_O_MATIC (event, "event-storage", pl);
3761 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3762 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3763 HACK_O_MATIC (marker, "marker-storage", pl);
3764 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3765 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3766 #ifdef LISP_FLOAT_TYPE
3767 HACK_O_MATIC (float, "float-storage", pl);
3768 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3769 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3770 #endif /* LISP_FLOAT_TYPE */
3771 HACK_O_MATIC (string, "string-header-storage", pl);
3772 pl = gc_plist_hack ("long-strings-total-length",
3773 gc_count_string_total_size
3774 - gc_count_short_string_total_size, pl);
3775 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3776 pl = gc_plist_hack ("short-strings-total-length",
3777 gc_count_short_string_total_size, pl);
3778 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3779 pl = gc_plist_hack ("long-strings-used",
3780 gc_count_num_string_in_use
3781 - gc_count_num_short_string_in_use, pl);
3782 pl = gc_plist_hack ("short-strings-used",
3783 gc_count_num_short_string_in_use, pl);
3785 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3786 pl = gc_plist_hack ("compiled-functions-free",
3787 gc_count_num_compiled_function_freelist, pl);
3788 pl = gc_plist_hack ("compiled-functions-used",
3789 gc_count_num_compiled_function_in_use, pl);
3791 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3792 pl = gc_plist_hack ("bit-vectors-total-length",
3793 gc_count_bit_vector_total_size, pl);
3794 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3796 HACK_O_MATIC (symbol, "symbol-storage", pl);
3797 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3798 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3800 HACK_O_MATIC (cons, "cons-storage", pl);
3801 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3802 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3804 /* The things we do for backwards-compatibility */
3806 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3807 make_int (gc_count_num_cons_freelist)),
3808 Fcons (make_int (gc_count_num_symbol_in_use),
3809 make_int (gc_count_num_symbol_freelist)),
3810 Fcons (make_int (gc_count_num_marker_in_use),
3811 make_int (gc_count_num_marker_freelist)),
3812 make_int (gc_count_string_total_size),
3813 make_int (gc_count_vector_total_size),
3818 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3819 Return the number of bytes consed since the last garbage collection.
3820 \"Consed\" is a misnomer in that this actually counts allocation
3821 of all different kinds of objects, not just conses.
3823 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3827 return make_int (consing_since_gc);
3831 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
3832 Return the address of the last byte Emacs has allocated, divided by 1024.
3833 This may be helpful in debugging Emacs's memory usage.
3834 The value is divided by 1024 to make sure it will fit in a lisp integer.
3838 return make_int ((EMACS_INT) sbrk (0) / 1024);
3844 object_dead_p (Lisp_Object obj)
3846 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3847 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3848 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3849 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3850 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3851 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3852 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3855 #ifdef MEMORY_USAGE_STATS
3857 /* Attempt to determine the actual amount of space that is used for
3858 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3860 It seems that the following holds:
3862 1. When using the old allocator (malloc.c):
3864 -- blocks are always allocated in chunks of powers of two. For
3865 each block, there is an overhead of 8 bytes if rcheck is not
3866 defined, 20 bytes if it is defined. In other words, a
3867 one-byte allocation needs 8 bytes of overhead for a total of
3868 9 bytes, and needs to have 16 bytes of memory chunked out for
3871 2. When using the new allocator (gmalloc.c):
3873 -- blocks are always allocated in chunks of powers of two up
3874 to 4096 bytes. Larger blocks are allocated in chunks of
3875 an integral multiple of 4096 bytes. The minimum block
3876 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3877 is defined. There is no per-block overhead, but there
3878 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3881 3. When using the system malloc, anything goes, but they are
3882 generally slower and more space-efficient than the GNU
3883 allocators. One possibly reasonable assumption to make
3884 for want of better data is that sizeof (void *), or maybe
3885 2 * sizeof (void *), is required as overhead and that
3886 blocks are allocated in the minimum required size except
3887 that some minimum block size is imposed (e.g. 16 bytes). */
3890 malloced_storage_size (void *ptr, size_t claimed_size,
3891 struct overhead_stats *stats)
3893 size_t orig_claimed_size = claimed_size;
3897 if (claimed_size < 2 * sizeof (void *))
3898 claimed_size = 2 * sizeof (void *);
3899 # ifdef SUNOS_LOCALTIME_BUG
3900 if (claimed_size < 16)
3903 if (claimed_size < 4096)
3907 /* compute the log base two, more or less, then use it to compute
3908 the block size needed. */
3910 /* It's big, it's heavy, it's wood! */
3911 while ((claimed_size /= 2) != 0)
3914 /* It's better than bad, it's good! */
3920 /* We have to come up with some average about the amount of
3922 if ((size_t) (rand () & 4095) < claimed_size)
3923 claimed_size += 3 * sizeof (void *);
3927 claimed_size += 4095;
3928 claimed_size &= ~4095;
3929 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3932 #elif defined (SYSTEM_MALLOC)
3934 if (claimed_size < 16)
3936 claimed_size += 2 * sizeof (void *);
3938 #else /* old GNU allocator */
3940 # ifdef rcheck /* #### may not be defined here */
3948 /* compute the log base two, more or less, then use it to compute
3949 the block size needed. */
3951 /* It's big, it's heavy, it's wood! */
3952 while ((claimed_size /= 2) != 0)
3955 /* It's better than bad, it's good! */
3963 #endif /* old GNU allocator */
3967 stats->was_requested += orig_claimed_size;
3968 stats->malloc_overhead += claimed_size - orig_claimed_size;
3970 return claimed_size;
3974 fixed_type_block_overhead (size_t size)
3976 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3977 size_t overhead = 0;
3978 size_t storage_size = malloced_storage_size (0, per_block, 0);
3979 while (size >= per_block)
3982 overhead += sizeof (void *) + per_block - storage_size;
3984 if (rand () % per_block < size)
3985 overhead += sizeof (void *) + per_block - storage_size;
3989 #endif /* MEMORY_USAGE_STATS */
3992 /* Initialization */
3994 reinit_alloc_once_early (void)
3996 gc_generation_number[0] = 0;
3997 breathing_space = 0;
3998 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3999 XSETINT (Vgc_message, 0);
4001 ignore_malloc_warnings = 1;
4002 #ifdef DOUG_LEA_MALLOC
4003 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
4004 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
4005 #if 0 /* Moved to emacs.c */
4006 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
4009 init_string_alloc ();
4010 init_string_chars_alloc ();
4012 init_symbol_alloc ();
4013 init_compiled_function_alloc ();
4014 #ifdef LISP_FLOAT_TYPE
4015 init_float_alloc ();
4016 #endif /* LISP_FLOAT_TYPE */
4017 init_marker_alloc ();
4018 init_extent_alloc ();
4019 init_event_alloc ();
4021 ignore_malloc_warnings = 0;
4023 staticidx_nodump = 0;
4027 consing_since_gc = 0;
4029 gc_cons_threshold = 500000; /* XEmacs change */
4031 gc_cons_threshold = 15000; /* debugging */
4033 #ifdef VIRT_ADDR_VARIES
4034 malloc_sbrk_unused = 1<<22; /* A large number */
4035 malloc_sbrk_used = 100000; /* as reasonable as any number */
4036 #endif /* VIRT_ADDR_VARIES */
4037 lrecord_uid_counter = 259;
4038 debug_string_purity = 0;
4041 gc_currently_forbidden = 0;
4042 gc_hooks_inhibited = 0;
4044 #ifdef ERROR_CHECK_TYPECHECK
4045 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4048 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
4050 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
4052 #endif /* ERROR_CHECK_TYPECHECK */
4056 init_alloc_once_early (void)
4060 reinit_alloc_once_early ();
4062 last_lrecord_type_index_assigned = -1;
4063 for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
4065 lrecord_implementations_table[iii] = 0;
4070 * defined subr lrecords were initialized with lheader->type == 0.
4071 * See subr_lheader_initializer in lisp.h. Force type index 0 to be
4072 * assigned to lrecord_subr so that those predefined indexes match
4075 lrecord_type_index (&lrecord_subr);
4076 assert (*(lrecord_subr.lrecord_type_index) == 0);
4078 * The same is true for symbol_value_forward objects, except the
4081 lrecord_type_index (&lrecord_symbol_value_forward);
4082 assert (*(lrecord_symbol_value_forward.lrecord_type_index) == 1);
4087 int pure_bytes_used = 0;
4096 syms_of_alloc (void)
4098 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
4099 defsymbol (&Qpost_gc_hook, "post-gc-hook");
4100 defsymbol (&Qgarbage_collecting, "garbage-collecting");
4105 DEFSUBR (Fbit_vector);
4106 DEFSUBR (Fmake_byte_code);
4107 DEFSUBR (Fmake_list);
4108 DEFSUBR (Fmake_vector);
4109 DEFSUBR (Fmake_bit_vector);
4110 DEFSUBR (Fmake_string);
4112 DEFSUBR (Fmake_symbol);
4113 DEFSUBR (Fmake_marker);
4114 DEFSUBR (Fpurecopy);
4115 DEFSUBR (Fgarbage_collect);
4117 DEFSUBR (Fmemory_limit);
4119 DEFSUBR (Fconsing_since_gc);
4123 vars_of_alloc (void)
4125 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
4126 *Number of bytes of consing between garbage collections.
4127 \"Consing\" is a misnomer in that this actually counts allocation
4128 of all different kinds of objects, not just conses.
4129 Garbage collection can happen automatically once this many bytes have been
4130 allocated since the last garbage collection. All data types count.
4132 Garbage collection happens automatically when `eval' or `funcall' are
4133 called. (Note that `funcall' is called implicitly as part of evaluation.)
4134 By binding this temporarily to a large number, you can effectively
4135 prevent garbage collection during a part of the program.
4137 See also `consing-since-gc'.
4140 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
4141 Number of bytes of sharable Lisp data allocated so far.
4145 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
4146 Number of bytes of unshared memory allocated in this session.
4149 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
4150 Number of bytes of unshared memory remaining available in this session.
4155 DEFVAR_INT ("debug-allocation", &debug_allocation /*
4156 If non-zero, print out information to stderr about all objects allocated.
4157 See also `debug-allocation-backtrace-length'.
4159 debug_allocation = 0;
4161 DEFVAR_INT ("debug-allocation-backtrace-length",
4162 &debug_allocation_backtrace_length /*
4163 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4165 debug_allocation_backtrace_length = 2;
4168 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4169 Non-nil means loading Lisp code in order to dump an executable.
4170 This means that certain objects should be allocated in readonly space.
4173 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4174 Function or functions to be run just before each garbage collection.
4175 Interrupts, garbage collection, and errors are inhibited while this hook
4176 runs, so be extremely careful in what you add here. In particular, avoid
4177 consing, and do not interact with the user.
4179 Vpre_gc_hook = Qnil;
4181 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4182 Function or functions to be run just after each garbage collection.
4183 Interrupts, garbage collection, and errors are inhibited while this hook
4184 runs, so be extremely careful in what you add here. In particular, avoid
4185 consing, and do not interact with the user.
4187 Vpost_gc_hook = Qnil;
4189 DEFVAR_LISP ("gc-message", &Vgc_message /*
4190 String to print to indicate that a garbage collection is in progress.
4191 This is printed in the echo area. If the selected frame is on a
4192 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4193 image instance) in the domain of the selected frame, the mouse pointer
4194 will change instead of this message being printed.
4196 Vgc_message = build_string (gc_default_message);
4198 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4199 Pointer glyph used to indicate that a garbage collection is in progress.
4200 If the selected window is on a window system and this glyph specifies a
4201 value (i.e. a pointer image instance) in the domain of the selected
4202 window, the pointer will be changed as specified during garbage collection.
4203 Otherwise, a message will be printed in the echo area, as controlled
4209 complex_vars_of_alloc (void)
4211 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
4217 /* The structure of the file
4220 * 256 - dumped objects
4221 * stab_offset - nb_staticpro*(Lisp_Object *) from staticvec
4222 * - nb_staticpro*(relocated Lisp_Object) pointed to by staticpro
4223 * - nb_structdmp*pair(void *, adr) for pointers to structures
4224 * - lrecord_implementations_table[]
4225 * - relocation table
4226 * - wired variable address/value couples with the count preceding the list
4231 EMACS_UINT stab_offset;
4232 EMACS_UINT reloc_address;
4239 char *pdump_start, *pdump_end;
4241 static const unsigned char align_table[256] =
4243 8, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4244 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4245 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4246 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4247 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4248 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4249 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4250 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4251 7, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4252 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4253 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4254 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4255 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4256 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4257 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4258 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0
4261 typedef struct pdump_entry_list_elmt
4263 struct pdump_entry_list_elmt *next;
4268 EMACS_INT save_offset;
4269 } pdump_entry_list_elmt;
4273 pdump_entry_list_elmt *first;
4278 typedef struct pdump_struct_list_elmt
4280 pdump_entry_list list;
4281 const struct struct_description *sdesc;
4282 } pdump_struct_list_elmt;
4286 pdump_struct_list_elmt *list;
4289 } pdump_struct_list;
4291 static pdump_entry_list pdump_object_table[256];
4292 static pdump_entry_list pdump_opaque_data_list;
4293 static pdump_struct_list pdump_struct_table;
4294 static pdump_entry_list_elmt *pdump_qnil;
4296 static int pdump_alert_undump_object[256];
4298 static unsigned long cur_offset;
4299 static size_t max_size;
4300 static int pdump_fd;
4301 static void *pdump_buf;
4303 #define PDUMP_HASHSIZE 200001
4305 static pdump_entry_list_elmt **pdump_hash;
4307 /* Since most pointers are eight bytes aligned, the >>3 allows for a better hash */
4309 pdump_make_hash (const void *obj)
4311 return ((unsigned long)(obj)>>3) % PDUMP_HASHSIZE;
4314 static pdump_entry_list_elmt *
4315 pdump_get_entry (const void *obj)
4317 int pos = pdump_make_hash (obj);
4318 pdump_entry_list_elmt *e;
4322 while ((e = pdump_hash[pos]) != 0)
4328 if (pos == PDUMP_HASHSIZE)
4335 pdump_add_entry (pdump_entry_list *list, const void *obj, size_t size, int count, int is_lrecord)
4337 pdump_entry_list_elmt *e;
4339 int pos = pdump_make_hash (obj);
4341 while ((e = pdump_hash[pos]) != 0)
4347 if (pos == PDUMP_HASHSIZE)
4351 e = xnew (pdump_entry_list_elmt);
4353 e->next = list->first;
4357 e->is_lrecord = is_lrecord;
4360 list->count += count;
4361 pdump_hash[pos] = e;
4363 align = align_table[size & 255];
4364 if (align < 2 && is_lrecord)
4367 if (align < list->align)
4368 list->align = align;
4371 static pdump_entry_list *
4372 pdump_get_entry_list (const struct struct_description *sdesc)
4375 for (i=0; i<pdump_struct_table.count; i++)
4376 if (pdump_struct_table.list[i].sdesc == sdesc)
4377 return &pdump_struct_table.list[i].list;
4379 if (pdump_struct_table.size <= pdump_struct_table.count)
4381 if (pdump_struct_table.size == -1)
4382 pdump_struct_table.size = 10;
4384 pdump_struct_table.size = pdump_struct_table.size * 2;
4385 pdump_struct_table.list = (pdump_struct_list_elmt *)
4386 xrealloc (pdump_struct_table.list,
4387 pdump_struct_table.size * sizeof (pdump_struct_list_elmt));
4389 pdump_struct_table.list[pdump_struct_table.count].list.first = 0;
4390 pdump_struct_table.list[pdump_struct_table.count].list.align = 8;
4391 pdump_struct_table.list[pdump_struct_table.count].list.count = 0;
4392 pdump_struct_table.list[pdump_struct_table.count].sdesc = sdesc;
4394 return &pdump_struct_table.list[pdump_struct_table.count++].list;
4399 struct lrecord_header *obj;
4406 static void pdump_backtrace (void)
4409 fprintf (stderr, "pdump backtrace :\n");
4410 for (i=0;i<depth;i++)
4412 if (!backtrace[i].obj)
4413 fprintf (stderr, " - ind. (%d, %d)\n", backtrace[i].position, backtrace[i].offset);
4416 fprintf (stderr, " - %s (%d, %d)\n",
4417 LHEADER_IMPLEMENTATION (backtrace[i].obj)->name,
4418 backtrace[i].position,
4419 backtrace[i].offset);
4424 static void pdump_register_object (Lisp_Object obj);
4425 static void pdump_register_struct (const void *data, const struct struct_description *sdesc, int count);
4428 pdump_get_indirect_count (EMACS_INT code, const struct lrecord_description *idesc, const void *idata)
4433 int line = XD_INDIRECT_VAL (code);
4434 int delta = XD_INDIRECT_DELTA (code);
4436 irdata = ((char *)idata) + idesc[line].offset;
4437 switch (idesc[line].type)
4440 count = *(size_t *)irdata;
4443 count = *(int *)irdata;
4446 count = *(long *)irdata;
4449 count = *(Bytecount *)irdata;
4452 fprintf (stderr, "Unsupported count type : %d (line = %d, code=%ld)\n", idesc[line].type, line, (long)code);
4461 pdump_register_sub (const void *data, const struct lrecord_description *desc, int me)
4466 for (pos = 0; desc[pos].type != XD_END; pos++)
4468 const void *rdata = (const char *)data + desc[pos].offset;
4470 backtrace[me].position = pos;
4471 backtrace[me].offset = desc[pos].offset;
4473 switch (desc[pos].type)
4475 case XD_SPECIFIER_END:
4477 desc = ((const Lisp_Specifier *)data)->methods->extra_description;
4483 case XD_LO_RESET_NIL:
4487 case XD_OPAQUE_DATA_PTR:
4489 EMACS_INT count = desc[pos].data1;
4490 if (XD_IS_INDIRECT (count))
4491 count = pdump_get_indirect_count (count, desc, data);
4493 pdump_add_entry (&pdump_opaque_data_list,
4502 const char *str = *(const char **)rdata;
4504 pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
4509 const char *str = *(const char **)rdata;
4510 if ((EMACS_INT)str > 0)
4511 pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
4514 case XD_LISP_OBJECT:
4516 const Lisp_Object *pobj = (const Lisp_Object *)rdata;
4518 assert (desc[pos].data1 == 0);
4520 backtrace[me].offset = (const char *)pobj - (const char *)data;
4521 pdump_register_object (*pobj);
4524 case XD_LISP_OBJECT_ARRAY:
4527 EMACS_INT count = desc[pos].data1;
4528 if (XD_IS_INDIRECT (count))
4529 count = pdump_get_indirect_count (count, desc, data);
4531 for (i = 0; i < count; i++)
4533 const Lisp_Object *pobj = ((const Lisp_Object *)rdata) + i;
4534 Lisp_Object dobj = *pobj;
4536 backtrace[me].offset = (const char *)pobj - (const char *)data;
4537 pdump_register_object (dobj);
4543 EMACS_INT count = desc[pos].data1;
4544 const struct struct_description *sdesc = desc[pos].data2;
4545 const char *dobj = *(const char **)rdata;
4548 if (XD_IS_INDIRECT (count))
4549 count = pdump_get_indirect_count (count, desc, data);
4551 pdump_register_struct (dobj, sdesc, count);
4556 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4564 pdump_register_object (Lisp_Object obj)
4566 struct lrecord_header *objh;
4568 if (!POINTER_TYPE_P (XTYPE (obj)))
4571 objh = XRECORD_LHEADER (obj);
4575 if (pdump_get_entry (objh))
4578 if (LHEADER_IMPLEMENTATION (objh)->description)
4583 fprintf (stderr, "Backtrace overflow, loop ?\n");
4586 backtrace[me].obj = objh;
4587 backtrace[me].position = 0;
4588 backtrace[me].offset = 0;
4590 pdump_add_entry (pdump_object_table + objh->type,
4592 LHEADER_IMPLEMENTATION (objh)->static_size ?
4593 LHEADER_IMPLEMENTATION (objh)->static_size :
4594 LHEADER_IMPLEMENTATION (objh)->size_in_bytes_method (objh),
4597 pdump_register_sub (objh,
4598 LHEADER_IMPLEMENTATION (objh)->description,
4604 pdump_alert_undump_object[objh->type]++;
4605 fprintf (stderr, "Undumpable object type : %s\n", LHEADER_IMPLEMENTATION (objh)->name);
4611 pdump_register_struct (const void *data, const struct struct_description *sdesc, int count)
4613 if (data && !pdump_get_entry (data))
4619 fprintf (stderr, "Backtrace overflow, loop ?\n");
4622 backtrace[me].obj = 0;
4623 backtrace[me].position = 0;
4624 backtrace[me].offset = 0;
4626 pdump_add_entry (pdump_get_entry_list (sdesc),
4631 for (i=0; i<count; i++)
4633 pdump_register_sub (((char *)data) + sdesc->size*i,
4642 pdump_dump_data (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
4644 size_t size = elmt->size;
4645 int count = elmt->count;
4649 memcpy (pdump_buf, elmt->obj, size*count);
4651 for (i=0; i<count; i++)
4653 char *cur = ((char *)pdump_buf) + i*size;
4655 for (pos = 0; desc[pos].type != XD_END; pos++)
4657 void *rdata = cur + desc[pos].offset;
4658 switch (desc[pos].type)
4660 case XD_SPECIFIER_END:
4661 desc = ((const Lisp_Specifier *)(elmt->obj))->methods->extra_description;
4668 case XD_LO_RESET_NIL:
4670 EMACS_INT count = desc[pos].data1;
4672 if (XD_IS_INDIRECT (count))
4673 count = pdump_get_indirect_count (count, desc, elmt->obj);
4674 for (i=0; i<count; i++)
4675 ((EMACS_INT *)rdata)[i] = pdump_qnil->save_offset;
4680 EMACS_INT val = desc[pos].data1;
4681 if (XD_IS_INDIRECT (val))
4682 val = pdump_get_indirect_count (val, desc, elmt->obj);
4683 *(int *)rdata = val;
4686 case XD_OPAQUE_DATA_PTR:
4690 void *ptr = *(void **)rdata;
4692 *(EMACS_INT *)rdata = pdump_get_entry (ptr)->save_offset;
4697 Lisp_Object obj = *(Lisp_Object *)rdata;
4698 pdump_entry_list_elmt *elmt1;
4701 elmt1 = pdump_get_entry (XRECORD_LHEADER (obj));
4704 obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
4706 *(EMACS_INT *)rdata = elmt1->save_offset;
4709 case XD_LISP_OBJECT:
4711 Lisp_Object *pobj = (Lisp_Object *) rdata;
4713 assert (desc[pos].data1 == 0);
4715 if (POINTER_TYPE_P (XTYPE (*pobj)) && XRECORD_LHEADER (*pobj))
4716 *(EMACS_INT *)pobj =
4717 pdump_get_entry (XRECORD_LHEADER (*pobj))->save_offset;
4720 case XD_LISP_OBJECT_ARRAY:
4722 EMACS_INT count = desc[pos].data1;
4724 if (XD_IS_INDIRECT (count))
4725 count = pdump_get_indirect_count (count, desc, elmt->obj);
4727 for (i=0; i<count; i++)
4729 Lisp_Object *pobj = ((Lisp_Object *)rdata) + i;
4730 if (POINTER_TYPE_P (XTYPE (*pobj)) && XRECORD_LHEADER (*pobj))
4731 *(EMACS_INT *)pobj =
4732 pdump_get_entry (XRECORD_LHEADER (*pobj))->save_offset;
4738 EMACS_INT str = *(EMACS_INT *)rdata;
4740 *(EMACS_INT *)rdata = pdump_get_entry ((void *)str)->save_offset;
4744 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4750 write (pdump_fd, desc ? pdump_buf : elmt->obj, size*count);
4751 if (elmt->is_lrecord && ((size*count) & 3))
4752 write (pdump_fd, "\0\0\0", 4-((size*count) & 3));
4756 pdump_reloc_one (void *data, EMACS_INT delta, const struct lrecord_description *desc)
4761 for (pos = 0; desc[pos].type != XD_END; pos++)
4763 void *rdata = (char *)data + desc[pos].offset;
4764 switch (desc[pos].type)
4766 case XD_SPECIFIER_END:
4768 desc = ((const Lisp_Specifier *)data)->methods->extra_description;
4776 case XD_OPAQUE_DATA_PTR:
4781 EMACS_INT ptr = *(EMACS_INT *)rdata;
4783 *(EMACS_INT *)rdata = ptr+delta;
4786 case XD_LISP_OBJECT:
4788 Lisp_Object *pobj = (Lisp_Object *) rdata;
4790 assert (desc[pos].data1 == 0);
4792 if (POINTER_TYPE_P (XTYPE (*pobj))
4793 && ! EQ (*pobj, Qnull_pointer))
4794 XSETOBJ (*pobj, XTYPE (*pobj), (char *) XPNTR (*pobj) + delta);
4798 case XD_LISP_OBJECT_ARRAY:
4799 case XD_LO_RESET_NIL:
4801 EMACS_INT count = desc[pos].data1;
4803 if (XD_IS_INDIRECT (count))
4804 count = pdump_get_indirect_count (count, desc, data);
4806 for (i=0; i<count; i++)
4808 Lisp_Object *pobj = (Lisp_Object *) rdata + i;
4810 if (POINTER_TYPE_P (XTYPE (*pobj))
4811 && ! EQ (*pobj, Qnull_pointer))
4812 XSETOBJ (*pobj, XTYPE (*pobj), (char *) XPNTR (*pobj) + delta);
4818 EMACS_INT str = *(EMACS_INT *)rdata;
4820 *(EMACS_INT *)rdata = str + delta;
4824 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4831 pdump_allocate_offset (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
4833 size_t size = (elmt->is_lrecord ? (elmt->size + 3) & ~3 : elmt->size)*elmt->count;
4834 elmt->save_offset = cur_offset;
4841 pdump_scan_by_alignment (void (*f)(pdump_entry_list_elmt *, const struct lrecord_description *))
4844 const struct lrecord_description *idesc;
4845 pdump_entry_list_elmt *elmt;
4846 for (align=8; align>=0; align--)
4848 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4849 if (pdump_object_table[i].align == align)
4851 elmt = pdump_object_table[i].first;
4854 idesc = lrecord_implementations_table[i]->description;
4862 for (i=0; i<pdump_struct_table.count; i++)
4863 if (pdump_struct_table.list[i].list.align == align)
4865 elmt = pdump_struct_table.list[i].list.first;
4866 idesc = pdump_struct_table.list[i].sdesc->description;
4874 elmt = pdump_opaque_data_list.first;
4877 if (align_table[elmt->size & 255] == align)
4885 pdump_dump_staticvec (void)
4887 EMACS_INT *reloc = xnew_array (EMACS_INT, staticidx);
4889 write (pdump_fd, staticvec, staticidx*sizeof (Lisp_Object *));
4891 for (i=0; i<staticidx; i++)
4893 Lisp_Object obj = *staticvec[i];
4894 if (POINTER_TYPE_P (XTYPE (obj)))
4895 reloc[i] = pdump_get_entry (XRECORD_LHEADER (obj))->save_offset;
4897 reloc[i] = *(EMACS_INT *)(staticvec[i]);
4899 write (pdump_fd, reloc, staticidx*sizeof (Lisp_Object));
4904 pdump_dump_structvec (void)
4907 for (i=0; i<dumpstructidx; i++)
4910 write (pdump_fd, &(dumpstructvec[i].data), sizeof (void *));
4911 adr = pdump_get_entry (*(void **)(dumpstructvec[i].data))->save_offset;
4912 write (pdump_fd, &adr, sizeof (adr));
4917 pdump_dump_opaquevec (void)
4920 for (i=0; i<dumpopaqueidx; i++)
4922 write (pdump_fd, &(dumpopaquevec[i]), sizeof (dumpopaquevec[i]));
4923 write (pdump_fd, dumpopaquevec[i].data, dumpopaquevec[i].size);
4928 pdump_dump_itable (void)
4930 write (pdump_fd, lrecord_implementations_table, sizeof (lrecord_implementations_table));
4934 pdump_dump_rtables (void)
4937 pdump_entry_list_elmt *elmt;
4938 pdump_reloc_table rt;
4940 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4942 elmt = pdump_object_table[i].first;
4945 rt.desc = lrecord_implementations_table[i]->description;
4946 rt.count = pdump_object_table[i].count;
4947 write (pdump_fd, &rt, sizeof (rt));
4950 EMACS_INT rdata = pdump_get_entry (elmt->obj)->save_offset;
4951 write (pdump_fd, &rdata, sizeof (rdata));
4958 write (pdump_fd, &rt, sizeof (rt));
4960 for (i=0; i<pdump_struct_table.count; i++)
4962 elmt = pdump_struct_table.list[i].list.first;
4963 rt.desc = pdump_struct_table.list[i].sdesc->description;
4964 rt.count = pdump_struct_table.list[i].list.count;
4965 write (pdump_fd, &rt, sizeof (rt));
4968 EMACS_INT rdata = pdump_get_entry (elmt->obj)->save_offset;
4969 for (j=0; j<elmt->count; j++)
4971 write (pdump_fd, &rdata, sizeof (rdata));
4972 rdata += elmt->size;
4979 write (pdump_fd, &rt, sizeof (rt));
4983 pdump_dump_wired (void)
4985 EMACS_INT count = pdump_wireidx + pdump_wireidx_list;
4988 write (pdump_fd, &count, sizeof (count));
4990 for (i=0; i<pdump_wireidx; i++)
4992 EMACS_INT obj = pdump_get_entry (XRECORD_LHEADER (*(pdump_wirevec[i])))->save_offset;
4993 write (pdump_fd, &pdump_wirevec[i], sizeof (pdump_wirevec[i]));
4994 write (pdump_fd, &obj, sizeof (obj));
4997 for (i=0; i<pdump_wireidx_list; i++)
4999 Lisp_Object obj = *(pdump_wirevec_list[i]);
5000 pdump_entry_list_elmt *elmt;
5005 const struct lrecord_description *desc;
5007 elmt = pdump_get_entry (XRECORD_LHEADER (obj));
5010 desc = XRECORD_LHEADER_IMPLEMENTATION (obj)->description;
5011 for (pos = 0; desc[pos].type != XD_LO_LINK; pos++)
5012 if (desc[pos].type == XD_END)
5015 obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
5017 res = elmt->save_offset;
5019 write (pdump_fd, &pdump_wirevec_list[i], sizeof (pdump_wirevec_list[i]));
5020 write (pdump_fd, &res, sizeof (res));
5028 Lisp_Object t_console, t_device, t_frame;
5032 /* These appear in a DEFVAR_LISP, which does a staticpro() */
5033 t_console = Vterminal_console;
5034 t_frame = Vterminal_frame;
5035 t_device = Vterminal_device;
5037 Vterminal_console = Qnil;
5038 Vterminal_frame = Qnil;
5039 Vterminal_device = Qnil;
5041 pdump_hash = xnew_array_and_zero (pdump_entry_list_elmt *, PDUMP_HASHSIZE);
5043 for (i=0; i<=last_lrecord_type_index_assigned; i++)
5045 pdump_object_table[i].first = 0;
5046 pdump_object_table[i].align = 8;
5047 pdump_object_table[i].count = 0;
5048 pdump_alert_undump_object[i] = 0;
5050 pdump_struct_table.count = 0;
5051 pdump_struct_table.size = -1;
5053 pdump_opaque_data_list.first = 0;
5054 pdump_opaque_data_list.align = 8;
5055 pdump_opaque_data_list.count = 0;
5058 for (i=0; i<staticidx; i++)
5059 pdump_register_object (*staticvec[i]);
5060 for (i=0; i<pdump_wireidx; i++)
5061 pdump_register_object (*pdump_wirevec[i]);
5064 for (i=0; i<=last_lrecord_type_index_assigned; i++)
5065 if (pdump_alert_undump_object[i])
5068 printf ("Undumpable types list :\n");
5070 printf (" - %s (%d)\n", lrecord_implementations_table[i]->name, pdump_alert_undump_object[i]);
5075 for (i=0; i<dumpstructidx; i++)
5076 pdump_register_struct (*(void **)(dumpstructvec[i].data), dumpstructvec[i].desc, 1);
5078 memcpy (hd.signature, "XEmacsDP", 8);
5079 hd.reloc_address = 0;
5080 hd.nb_staticpro = staticidx;
5081 hd.nb_structdmp = dumpstructidx;
5082 hd.nb_opaquedmp = dumpopaqueidx;
5083 hd.last_type = last_lrecord_type_index_assigned;
5088 pdump_scan_by_alignment (pdump_allocate_offset);
5089 pdump_qnil = pdump_get_entry (XRECORD_LHEADER (Qnil));
5091 pdump_buf = xmalloc (max_size);
5092 /* Avoid use of the `open' macro. We want the real function. */
5094 pdump_fd = open ("xemacs.dmp",
5095 O_WRONLY | O_CREAT | O_TRUNC | OPEN_BINARY, 0666);
5096 hd.stab_offset = (cur_offset + 3) & ~3;
5098 write (pdump_fd, &hd, sizeof (hd));
5099 lseek (pdump_fd, 256, SEEK_SET);
5101 pdump_scan_by_alignment (pdump_dump_data);
5103 lseek (pdump_fd, hd.stab_offset, SEEK_SET);
5105 pdump_dump_staticvec ();
5106 pdump_dump_structvec ();
5107 pdump_dump_opaquevec ();
5108 pdump_dump_itable ();
5109 pdump_dump_rtables ();
5110 pdump_dump_wired ();
5117 Vterminal_console = t_console;
5118 Vterminal_frame = t_frame;
5119 Vterminal_device = t_device;
5131 #define PDUMP_READ(p, type) (p = (char*) (((type *) p) + 1), *((type *) p - 1))
5133 pdump_start = pdump_end = 0;
5135 pdump_fd = open ("xemacs.dmp", O_RDONLY | OPEN_BINARY);
5139 length = lseek (pdump_fd, 0, SEEK_END);
5140 lseek (pdump_fd, 0, SEEK_SET);
5143 pdump_start = (char *) mmap (0, length, PROT_READ|PROT_WRITE, MAP_PRIVATE, pdump_fd, 0);
5144 if (pdump_start == MAP_FAILED)
5150 pdump_start = (char *)((((unsigned long)(xmalloc(length+255))) + 255) & ~255);
5151 read (pdump_fd, pdump_start, length);
5156 pdump_end = pdump_start + length;
5158 staticidx = ((dump_header *)(pdump_start))->nb_staticpro;
5159 last_lrecord_type_index_assigned = ((dump_header *)pdump_start)->last_type;
5160 delta = ((EMACS_INT)pdump_start) - ((dump_header *)pdump_start)->reloc_address;
5161 p = pdump_start + ((dump_header *)pdump_start)->stab_offset;
5163 /* Put back the staticvec in place */
5164 memcpy (staticvec, p, staticidx*sizeof (Lisp_Object *));
5165 p += staticidx*sizeof (Lisp_Object *);
5166 for (i=0; i<staticidx; i++)
5168 Lisp_Object obj = PDUMP_READ (p, Lisp_Object);
5169 if (POINTER_TYPE_P (XTYPE (obj)))
5170 XSETOBJ (obj, XTYPE (obj), (char *) XPNTR (obj) + delta);
5171 *staticvec[i] = obj;
5174 /* Put back the dumpstructs */
5175 for (i=0; i<((dump_header *)pdump_start)->nb_structdmp; i++)
5177 void **adr = PDUMP_READ (p, void **);
5178 *adr = (void *) (PDUMP_READ (p, char *) + delta);
5181 /* Put back the opaques */
5182 for (i=0; i<((dump_header *)pdump_start)->nb_opaquedmp; i++)
5184 struct dumpopaque_info di = PDUMP_READ (p, struct dumpopaque_info);
5185 memcpy (di.data, p, di.size);
5189 /* Put back the lrecord_implementations_table */
5190 memcpy (lrecord_implementations_table, p, sizeof (lrecord_implementations_table));
5191 p += sizeof (lrecord_implementations_table);
5193 /* Give back their numbers to the lrecord implementations */
5194 for (i = 0; i < countof (lrecord_implementations_table); i++)
5195 if (lrecord_implementations_table[i])
5197 *(lrecord_implementations_table[i]->lrecord_type_index) = i;
5198 last_lrecord_type_index_assigned = i;
5201 /* Do the relocations */
5206 pdump_reloc_table rt = PDUMP_READ (p, pdump_reloc_table);
5209 for (i=0; i < rt.count; i++)
5211 char *adr = delta + *(char **)p;
5213 pdump_reloc_one (adr, delta, rt.desc);
5214 p += sizeof (char *);
5221 /* Put the pdump_wire variables in place */
5222 count = PDUMP_READ (p, EMACS_INT);
5224 for (i=0; i<count; i++)
5226 Lisp_Object *var = PDUMP_READ (p, Lisp_Object *);
5227 Lisp_Object obj = PDUMP_READ (p, Lisp_Object);
5229 if (POINTER_TYPE_P (XTYPE (obj)))
5230 XSETOBJ (obj, XTYPE (obj), (char *) XPNTR (obj) + delta);
5235 /* Final cleanups */
5236 /* reorganize hash tables */
5240 pdump_reloc_table rt = PDUMP_READ (p, pdump_reloc_table);
5243 if (rt.desc == hash_table_description)
5245 for (i=0; i < rt.count; i++)
5246 pdump_reorganize_hash_table (PDUMP_READ (p, Lisp_Object));
5249 p += sizeof (Lisp_Object) * rt.count;
5252 /* Put back noninteractive1 to its real value */
5253 noninteractive1 = noninteractive;