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 /* Return the true size of a struct with a variable-length array field. */
84 #define STRETCHY_STRUCT_SIZEOF(stretchy_struct_type, \
85 stretchy_array_field, \
86 stretchy_array_length) \
87 (offsetof (stretchy_struct_type, stretchy_array_field) + \
88 (offsetof (stretchy_struct_type, stretchy_array_field[1]) - \
89 offsetof (stretchy_struct_type, stretchy_array_field[0])) * \
90 (stretchy_array_length))
92 #if 0 /* this is _way_ too slow to be part of the standard debug options */
93 #if defined(DEBUG_XEMACS) && defined(MULE)
94 #define VERIFY_STRING_CHARS_INTEGRITY
98 /* Define this to use malloc/free with no freelist for all datatypes,
99 the hope being that some debugging tools may help detect
100 freed memory references */
101 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
103 #define ALLOC_NO_POOLS
107 static int debug_allocation;
108 static int debug_allocation_backtrace_length;
111 /* Number of bytes of consing done since the last gc */
112 EMACS_INT consing_since_gc;
113 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
115 #define debug_allocation_backtrace() \
117 if (debug_allocation_backtrace_length > 0) \
118 debug_short_backtrace (debug_allocation_backtrace_length); \
122 #define INCREMENT_CONS_COUNTER(foosize, type) \
124 if (debug_allocation) \
126 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
127 debug_allocation_backtrace (); \
129 INCREMENT_CONS_COUNTER_1 (foosize); \
131 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
133 if (debug_allocation > 1) \
135 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
136 debug_allocation_backtrace (); \
138 INCREMENT_CONS_COUNTER_1 (foosize); \
141 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
142 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
143 INCREMENT_CONS_COUNTER_1 (size)
146 #define DECREMENT_CONS_COUNTER(size) do { \
147 consing_since_gc -= (size); \
148 if (consing_since_gc < 0) \
149 consing_since_gc = 0; \
152 /* Number of bytes of consing since gc before another gc should be done. */
153 EMACS_INT gc_cons_threshold;
155 /* Nonzero during gc */
158 /* Number of times GC has happened at this level or below.
159 * Level 0 is most volatile, contrary to usual convention.
160 * (Of course, there's only one level at present) */
161 EMACS_INT gc_generation_number[1];
163 /* This is just for use by the printer, to allow things to print uniquely */
164 static int lrecord_uid_counter;
166 /* Nonzero when calling certain hooks or doing other things where
168 int gc_currently_forbidden;
171 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
172 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
174 /* "Garbage collecting" */
175 Lisp_Object Vgc_message;
176 Lisp_Object Vgc_pointer_glyph;
177 static CONST char gc_default_message[] = "Garbage collecting";
178 Lisp_Object Qgarbage_collecting;
180 #ifndef VIRT_ADDR_VARIES
182 #endif /* VIRT_ADDR_VARIES */
183 EMACS_INT malloc_sbrk_used;
185 #ifndef VIRT_ADDR_VARIES
187 #endif /* VIRT_ADDR_VARIES */
188 EMACS_INT malloc_sbrk_unused;
190 /* Non-zero means we're in the process of doing the dump */
193 #ifdef ERROR_CHECK_TYPECHECK
195 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
200 c_readonly (Lisp_Object obj)
202 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
206 lisp_readonly (Lisp_Object obj)
208 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
212 /* Maximum amount of C stack to save when a GC happens. */
214 #ifndef MAX_SAVE_STACK
215 #define MAX_SAVE_STACK 0 /* 16000 */
218 /* Non-zero means ignore malloc warnings. Set during initialization. */
219 int ignore_malloc_warnings;
222 static void *breathing_space;
225 release_breathing_space (void)
229 void *tmp = breathing_space;
235 /* malloc calls this if it finds we are near exhausting storage */
237 malloc_warning (CONST char *str)
239 if (ignore_malloc_warnings)
245 "Killing some buffers may delay running out of memory.\n"
246 "However, certainly by the time you receive the 95%% warning,\n"
247 "you should clean up, kill this Emacs, and start a new one.",
251 /* Called if malloc returns zero */
255 /* Force a GC next time eval is called.
256 It's better to loop garbage-collecting (we might reclaim enough
257 to win) than to loop beeping and barfing "Memory exhausted"
259 consing_since_gc = gc_cons_threshold + 1;
260 release_breathing_space ();
262 /* Flush some histories which might conceivably contain garbalogical
264 if (!NILP (Fboundp (Qvalues)))
265 Fset (Qvalues, Qnil);
266 Vcommand_history = Qnil;
268 error ("Memory exhausted");
271 /* like malloc and realloc but check for no memory left, and block input. */
275 xmalloc (size_t size)
277 void *val = malloc (size);
279 if (!val && (size != 0)) memory_full ();
285 xcalloc (size_t nelem, size_t elsize)
287 void *val = calloc (nelem, elsize);
289 if (!val && (nelem != 0)) memory_full ();
294 xmalloc_and_zero (size_t size)
296 return xcalloc (size, sizeof (char));
301 xrealloc (void *block, size_t size)
303 /* We must call malloc explicitly when BLOCK is 0, since some
304 reallocs don't do this. */
305 void *val = block ? realloc (block, size) : malloc (size);
307 if (!val && (size != 0)) memory_full ();
312 #ifdef ERROR_CHECK_MALLOC
313 xfree_1 (void *block)
318 #ifdef ERROR_CHECK_MALLOC
319 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
320 error until much later on for many system mallocs, such as
321 the one that comes with Solaris 2.3. FMH!! */
322 assert (block != (void *) 0xDEADBEEF);
324 #endif /* ERROR_CHECK_MALLOC */
328 #ifdef ERROR_CHECK_GC
331 typedef unsigned int four_byte_t;
332 #elif SIZEOF_LONG == 4
333 typedef unsigned long four_byte_t;
334 #elif SIZEOF_SHORT == 4
335 typedef unsigned short four_byte_t;
337 What kind of strange-ass system are we running on?
341 deadbeef_memory (void *ptr, size_t size)
343 four_byte_t *ptr4 = (four_byte_t *) ptr;
344 size_t beefs = size >> 2;
346 /* In practice, size will always be a multiple of four. */
348 (*ptr4++) = 0xDEADBEEF;
351 #else /* !ERROR_CHECK_GC */
354 #define deadbeef_memory(ptr, size)
356 #endif /* !ERROR_CHECK_GC */
360 xstrdup (CONST char *str)
362 int len = strlen (str) + 1; /* for stupid terminating 0 */
364 void *val = xmalloc (len);
365 if (val == 0) return 0;
366 return (char *) memcpy (val, str, len);
371 strdup (CONST char *s)
375 #endif /* NEED_STRDUP */
379 allocate_lisp_storage (size_t size)
381 return xmalloc (size);
385 /* lrecords are chained together through their "next.v" field.
386 * After doing the mark phase, the GC will walk this linked
387 * list and free any record which hasn't been marked.
389 static struct lcrecord_header *all_lcrecords;
392 alloc_lcrecord (size_t size, CONST struct lrecord_implementation *implementation)
394 struct lcrecord_header *lcheader;
396 #ifdef ERROR_CHECK_GC
397 if (implementation->static_size == 0)
398 assert (implementation->size_in_bytes_method);
400 assert (implementation->static_size == size);
403 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
404 set_lheader_implementation (&(lcheader->lheader), implementation);
405 lcheader->next = all_lcrecords;
406 #if 1 /* mly prefers to see small ID numbers */
407 lcheader->uid = lrecord_uid_counter++;
408 #else /* jwz prefers to see real addrs */
409 lcheader->uid = (int) &lcheader;
412 all_lcrecords = lcheader;
413 INCREMENT_CONS_COUNTER (size, implementation->name);
417 #if 0 /* Presently unused */
418 /* Very, very poor man's EGC?
419 * This may be slow and thrash pages all over the place.
420 * Only call it if you really feel you must (and if the
421 * lrecord was fairly recently allocated).
422 * Otherwise, just let the GC do its job -- that's what it's there for
425 free_lcrecord (struct lcrecord_header *lcrecord)
427 if (all_lcrecords == lcrecord)
429 all_lcrecords = lcrecord->next;
433 struct lrecord_header *header = all_lcrecords;
436 struct lrecord_header *next = header->next;
437 if (next == lcrecord)
439 header->next = lrecord->next;
448 if (lrecord->implementation->finalizer)
449 lrecord->implementation->finalizer (lrecord, 0);
457 disksave_object_finalization_1 (void)
459 struct lcrecord_header *header;
461 for (header = all_lcrecords; header; header = header->next)
463 if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
465 ((LHEADER_IMPLEMENTATION(&header->lheader)->finalizer)
470 /* Semi-kludge -- lrecord_symbol_value_forward objects get stuck
471 in CONST space and you get SEGV's if you attempt to mark them.
472 This sits in lheader->implementation->marker. */
475 this_one_is_unmarkable (Lisp_Object obj)
482 /************************************************************************/
483 /* Debugger support */
484 /************************************************************************/
485 /* Give gdb/dbx enough information to decode Lisp Objects. We make
486 sure certain symbols are always defined, so gdb doesn't complain
487 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
488 to see how this is used. */
490 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
491 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
493 #ifdef USE_UNION_TYPE
494 unsigned char dbg_USE_UNION_TYPE = 1;
496 unsigned char dbg_USE_UNION_TYPE = 0;
499 unsigned char Lisp_Type_Int = 100;
500 unsigned char Lisp_Type_Cons = 101;
501 unsigned char Lisp_Type_String = 102;
502 unsigned char Lisp_Type_Vector = 103;
503 unsigned char Lisp_Type_Symbol = 104;
506 unsigned char lrecord_char_table_entry;
507 unsigned char lrecord_charset;
509 unsigned char lrecord_coding_system;
513 #if !((defined HAVE_X_WINDOWS) && \
514 (defined (HAVE_MENUBARS) || \
515 defined (HAVE_SCROLLBARS) || \
516 defined (HAVE_DIALOGS) || \
517 defined (HAVE_TOOLBARS) || \
518 defined (HAVE_WIDGETS)))
519 unsigned char lrecord_popup_data;
522 #ifndef HAVE_TOOLBARS
523 unsigned char lrecord_toolbar_button;
527 unsigned char lrecord_tooltalk_message;
528 unsigned char lrecord_tooltalk_pattern;
531 #ifndef HAVE_DATABASE
532 unsigned char lrecord_database;
535 unsigned char dbg_valbits = VALBITS;
536 unsigned char dbg_gctypebits = GCTYPEBITS;
538 /* Macros turned into functions for ease of debugging.
539 Debuggers don't know about macros! */
540 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
542 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
544 return EQ (obj1, obj2);
548 /************************************************************************/
549 /* Fixed-size type macros */
550 /************************************************************************/
552 /* For fixed-size types that are commonly used, we malloc() large blocks
553 of memory at a time and subdivide them into chunks of the correct
554 size for an object of that type. This is more efficient than
555 malloc()ing each object separately because we save on malloc() time
556 and overhead due to the fewer number of malloc()ed blocks, and
557 also because we don't need any extra pointers within each object
558 to keep them threaded together for GC purposes. For less common
559 (and frequently large-size) types, we use lcrecords, which are
560 malloc()ed individually and chained together through a pointer
561 in the lcrecord header. lcrecords do not need to be fixed-size
562 (i.e. two objects of the same type need not have the same size;
563 however, the size of a particular object cannot vary dynamically).
564 It is also much easier to create a new lcrecord type because no
565 additional code needs to be added to alloc.c. Finally, lcrecords
566 may be more efficient when there are only a small number of them.
568 The types that are stored in these large blocks (or "frob blocks")
569 are cons, float, compiled-function, symbol, marker, extent, event,
572 Note that strings are special in that they are actually stored in
573 two parts: a structure containing information about the string, and
574 the actual data associated with the string. The former structure
575 (a struct Lisp_String) is a fixed-size structure and is managed the
576 same way as all the other such types. This structure contains a
577 pointer to the actual string data, which is stored in structures of
578 type struct string_chars_block. Each string_chars_block consists
579 of a pointer to a struct Lisp_String, followed by the data for that
580 string, followed by another pointer to a Lisp_String, followed by
581 the data for that string, etc. At GC time, the data in these
582 blocks is compacted by searching sequentially through all the
583 blocks and compressing out any holes created by unmarked strings.
584 Strings that are more than a certain size (bigger than the size of
585 a string_chars_block, although something like half as big might
586 make more sense) are malloc()ed separately and not stored in
587 string_chars_blocks. Furthermore, no one string stretches across
588 two string_chars_blocks.
590 Vectors are each malloc()ed separately, similar to lcrecords.
592 In the following discussion, we use conses, but it applies equally
593 well to the other fixed-size types.
595 We store cons cells inside of cons_blocks, allocating a new
596 cons_block with malloc() whenever necessary. Cons cells reclaimed
597 by GC are put on a free list to be reallocated before allocating
598 any new cons cells from the latest cons_block. Each cons_block is
599 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
600 the versions in malloc.c and gmalloc.c) really allocates in units
601 of powers of two and uses 4 bytes for its own overhead.
603 What GC actually does is to search through all the cons_blocks,
604 from the most recently allocated to the oldest, and put all
605 cons cells that are not marked (whether or not they're already
606 free) on a cons_free_list. The cons_free_list is a stack, and
607 so the cons cells in the oldest-allocated cons_block end up
608 at the head of the stack and are the first to be reallocated.
609 If any cons_block is entirely free, it is freed with free()
610 and its cons cells removed from the cons_free_list. Because
611 the cons_free_list ends up basically in memory order, we have
612 a high locality of reference (assuming a reasonable turnover
613 of allocating and freeing) and have a reasonable probability
614 of entirely freeing up cons_blocks that have been more recently
615 allocated. This stage is called the "sweep stage" of GC, and
616 is executed after the "mark stage", which involves starting
617 from all places that are known to point to in-use Lisp objects
618 (e.g. the obarray, where are all symbols are stored; the
619 current catches and condition-cases; the backtrace list of
620 currently executing functions; the gcpro list; etc.) and
621 recursively marking all objects that are accessible.
623 At the beginning of the sweep stage, the conses in the cons
624 blocks are in one of three states: in use and marked, in use
625 but not marked, and not in use (already freed). Any conses
626 that are marked have been marked in the mark stage just
627 executed, because as part of the sweep stage we unmark any
628 marked objects. The way we tell whether or not a cons cell
629 is in use is through the FREE_STRUCT_P macro. This basically
630 looks at the first 4 bytes (or however many bytes a pointer
631 fits in) to see if all the bits in those bytes are 1. The
632 resulting value (0xFFFFFFFF) is not a valid pointer and is
633 not a valid Lisp_Object. All current fixed-size types have
634 a pointer or Lisp_Object as their first element with the
635 exception of strings; they have a size value, which can
636 never be less than zero, and so 0xFFFFFFFF is invalid for
637 strings as well. Now assuming that a cons cell is in use,
638 the way we tell whether or not it is marked is to look at
639 the mark bit of its car (each Lisp_Object has one bit
640 reserved as a mark bit, in case it's needed). Note that
641 different types of objects use different fields to indicate
642 whether the object is marked, but the principle is the same.
644 Conses on the free_cons_list are threaded through a pointer
645 stored in the bytes directly after the bytes that are set
646 to 0xFFFFFFFF (we cannot overwrite these because the cons
647 is still in a cons_block and needs to remain marked as
648 not in use for the next time that GC happens). This
649 implies that all fixed-size types must be at least big
650 enough to store two pointers, which is indeed the case
651 for all current fixed-size types.
653 Some types of objects need additional "finalization" done
654 when an object is converted from in use to not in use;
655 this is the purpose of the ADDITIONAL_FREE_type macro.
656 For example, markers need to be removed from the chain
657 of markers that is kept in each buffer. This is because
658 markers in a buffer automatically disappear if the marker
659 is no longer referenced anywhere (the same does not
660 apply to extents, however).
662 WARNING: Things are in an extremely bizarre state when
663 the ADDITIONAL_FREE_type macros are called, so beware!
665 When ERROR_CHECK_GC is defined, we do things differently
666 so as to maximize our chances of catching places where
667 there is insufficient GCPROing. The thing we want to
668 avoid is having an object that we're using but didn't
669 GCPRO get freed by GC and then reallocated while we're
670 in the process of using it -- this will result in something
671 seemingly unrelated getting trashed, and is extremely
672 difficult to track down. If the object gets freed but
673 not reallocated, we can usually catch this because we
674 set all bytes of a freed object to 0xDEADBEEF. (The
675 first four bytes, however, are 0xFFFFFFFF, and the next
676 four are a pointer used to chain freed objects together;
677 we play some tricks with this pointer to make it more
678 bogus, so crashes are more likely to occur right away.)
680 We want freed objects to stay free as long as possible,
681 so instead of doing what we do above, we maintain the
682 free objects in a first-in first-out queue. We also
683 don't recompute the free list each GC, unlike above;
684 this ensures that the queue ordering is preserved.
685 [This means that we are likely to have worse locality
686 of reference, and that we can never free a frob block
687 once it's allocated. (Even if we know that all cells
688 in it are free, there's no easy way to remove all those
689 cells from the free list because the objects on the
690 free list are unlikely to be in memory order.)]
691 Furthermore, we never take objects off the free list
692 unless there's a large number (usually 1000, but
693 varies depending on type) of them already on the list.
694 This way, we ensure that an object that gets freed will
695 remain free for the next 1000 (or whatever) times that
696 an object of that type is allocated. */
698 #ifndef MALLOC_OVERHEAD
700 #define MALLOC_OVERHEAD 0
701 #elif defined (rcheck)
702 #define MALLOC_OVERHEAD 20
704 #define MALLOC_OVERHEAD 8
706 #endif /* MALLOC_OVERHEAD */
708 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
709 /* If we released our reserve (due to running out of memory),
710 and we have a fair amount free once again,
711 try to set aside another reserve in case we run out once more.
713 This is called when a relocatable block is freed in ralloc.c. */
714 void refill_memory_reserve (void);
716 refill_memory_reserve ()
718 if (breathing_space == 0)
719 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
723 #ifdef ALLOC_NO_POOLS
724 # define TYPE_ALLOC_SIZE(type, structtype) 1
726 # define TYPE_ALLOC_SIZE(type, structtype) \
727 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
728 / sizeof (structtype))
729 #endif /* ALLOC_NO_POOLS */
731 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
733 struct type##_block \
735 struct type##_block *prev; \
736 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
739 static struct type##_block *current_##type##_block; \
740 static int current_##type##_block_index; \
742 static structtype *type##_free_list; \
743 static structtype *type##_free_list_tail; \
746 init_##type##_alloc (void) \
748 current_##type##_block = 0; \
749 current_##type##_block_index = \
750 countof (current_##type##_block->block); \
751 type##_free_list = 0; \
752 type##_free_list_tail = 0; \
755 static int gc_count_num_##type##_in_use; \
756 static int gc_count_num_##type##_freelist
758 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
759 if (current_##type##_block_index \
760 == countof (current_##type##_block->block)) \
762 struct type##_block *AFTFB_new = (struct type##_block *) \
763 allocate_lisp_storage (sizeof (struct type##_block)); \
764 AFTFB_new->prev = current_##type##_block; \
765 current_##type##_block = AFTFB_new; \
766 current_##type##_block_index = 0; \
769 &(current_##type##_block->block[current_##type##_block_index++]); \
772 /* Allocate an instance of a type that is stored in blocks.
773 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
776 #ifdef ERROR_CHECK_GC
778 /* Note: if you get crashes in this function, suspect incorrect calls
779 to free_cons() and friends. This happened once because the cons
780 cell was not GC-protected and was getting collected before
781 free_cons() was called. */
783 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
786 if (gc_count_num_##type##_freelist > \
787 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
789 result = type##_free_list; \
790 /* Before actually using the chain pointer, we complement all its \
791 bits; see FREE_FIXED_TYPE(). */ \
793 (structtype *) ~(unsigned long) \
794 (* (structtype **) ((char *) result + sizeof (void *))); \
795 gc_count_num_##type##_freelist--; \
798 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
799 MARK_STRUCT_AS_NOT_FREE (result); \
802 #else /* !ERROR_CHECK_GC */
804 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
807 if (type##_free_list) \
809 result = type##_free_list; \
811 * (structtype **) ((char *) result + sizeof (void *)); \
814 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
815 MARK_STRUCT_AS_NOT_FREE (result); \
818 #endif /* !ERROR_CHECK_GC */
820 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
823 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
824 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
827 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
830 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
831 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
834 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
835 to a Lisp object and invalid as an actual Lisp_Object value. We have
836 to make sure that this value cannot be an integer in Lisp_Object form.
837 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
838 On a 32-bit system, the type bits will be non-zero, making the value
839 be a pointer, and the pointer will be misaligned.
841 Even if Emacs is run on some weirdo system that allows and allocates
842 byte-aligned pointers, this pointer is at the very top of the address
843 space and so it's almost inconceivable that it could ever be valid. */
846 # define INVALID_POINTER_VALUE 0xFFFFFFFF
848 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
850 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
852 You have some weird system and need to supply a reasonable value here.
855 #define FREE_STRUCT_P(ptr) \
856 (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
857 #define MARK_STRUCT_AS_FREE(ptr) \
858 (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
859 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
860 (* (void **) ptr = 0)
862 #ifdef ERROR_CHECK_GC
864 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
865 do { if (type##_free_list_tail) \
867 /* When we store the chain pointer, we complement all \
868 its bits; this should significantly increase its \
869 bogosity in case someone tries to use the value, and \
870 should make us dump faster if someone stores something \
871 over the pointer because when it gets un-complemented in \
872 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
873 extremely bogus. */ \
875 ((char *) type##_free_list_tail + sizeof (void *)) = \
876 (structtype *) ~(unsigned long) ptr; \
879 type##_free_list = ptr; \
880 type##_free_list_tail = ptr; \
883 #else /* !ERROR_CHECK_GC */
885 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
886 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
888 type##_free_list = (ptr); \
891 #endif /* !ERROR_CHECK_GC */
893 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
895 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
896 structtype *FFT_ptr = (ptr); \
897 ADDITIONAL_FREE_##type (FFT_ptr); \
898 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
899 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
900 MARK_STRUCT_AS_FREE (FFT_ptr); \
903 /* Like FREE_FIXED_TYPE() but used when we are explicitly
904 freeing a structure through free_cons(), free_marker(), etc.
905 rather than through the normal process of sweeping.
906 We attempt to undo the changes made to the allocation counters
907 as a result of this structure being allocated. This is not
908 completely necessary but helps keep things saner: e.g. this way,
909 repeatedly allocating and freeing a cons will not result in
910 the consing-since-gc counter advancing, which would cause a GC
911 and somewhat defeat the purpose of explicitly freeing. */
913 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
914 do { FREE_FIXED_TYPE (type, structtype, ptr); \
915 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
916 gc_count_num_##type##_freelist++; \
921 /************************************************************************/
922 /* Cons allocation */
923 /************************************************************************/
925 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
926 /* conses are used and freed so often that we set this really high */
927 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
928 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
931 mark_cons (Lisp_Object obj)
933 if (NILP (XCDR (obj)))
936 mark_object (XCAR (obj));
941 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
943 while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1))
947 if (! CONSP (ob1) || ! CONSP (ob2))
948 return internal_equal (ob1, ob2, depth + 1);
953 static const struct lrecord_description cons_description[] = {
954 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
955 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
959 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
960 mark_cons, print_cons, 0,
963 * No `hash' method needed.
964 * internal_hash knows how to
971 DEFUN ("cons", Fcons, 2, 2, 0, /*
972 Create a new cons, give it CAR and CDR as components, and return it.
976 /* This cannot GC. */
980 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
981 set_lheader_implementation (&(c->lheader), &lrecord_cons);
988 /* This is identical to Fcons() but it used for conses that we're
989 going to free later, and is useful when trying to track down
992 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
997 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
998 set_lheader_implementation (&(c->lheader), &lrecord_cons);
1005 DEFUN ("list", Flist, 0, MANY, 0, /*
1006 Return a newly created list with specified arguments as elements.
1007 Any number of arguments, even zero arguments, are allowed.
1009 (int nargs, Lisp_Object *args))
1011 Lisp_Object val = Qnil;
1012 Lisp_Object *argp = args + nargs;
1015 val = Fcons (*--argp, val);
1020 list1 (Lisp_Object obj0)
1022 /* This cannot GC. */
1023 return Fcons (obj0, Qnil);
1027 list2 (Lisp_Object obj0, Lisp_Object obj1)
1029 /* This cannot GC. */
1030 return Fcons (obj0, Fcons (obj1, Qnil));
1034 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1036 /* This cannot GC. */
1037 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1041 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1043 /* This cannot GC. */
1044 return Fcons (obj0, Fcons (obj1, obj2));
1048 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1050 return Fcons (Fcons (key, value), alist);
1054 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1056 /* This cannot GC. */
1057 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1061 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1064 /* This cannot GC. */
1065 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1069 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1070 Lisp_Object obj4, Lisp_Object obj5)
1072 /* This cannot GC. */
1073 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1076 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1077 Return a new list of length LENGTH, with each element being INIT.
1081 CHECK_NATNUM (length);
1084 Lisp_Object val = Qnil;
1085 size_t size = XINT (length);
1088 val = Fcons (init, val);
1094 /************************************************************************/
1095 /* Float allocation */
1096 /************************************************************************/
1098 #ifdef LISP_FLOAT_TYPE
1100 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
1101 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1104 make_float (double float_value)
1109 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
1111 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1112 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1115 set_lheader_implementation (&(f->lheader), &lrecord_float);
1116 float_data (f) = float_value;
1121 #endif /* LISP_FLOAT_TYPE */
1124 /************************************************************************/
1125 /* Vector allocation */
1126 /************************************************************************/
1129 mark_vector (Lisp_Object obj)
1131 Lisp_Vector *ptr = XVECTOR (obj);
1132 int len = vector_length (ptr);
1135 for (i = 0; i < len - 1; i++)
1136 mark_object (ptr->contents[i]);
1137 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1141 size_vector (CONST void *lheader)
1143 return STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents,
1144 ((Lisp_Vector *) lheader)->size);
1148 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1150 int len = XVECTOR_LENGTH (obj1);
1151 if (len != XVECTOR_LENGTH (obj2))
1155 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1156 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1158 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1164 static const struct lrecord_description vector_description[] = {
1165 { XD_LONG, offsetof (Lisp_Vector, size) },
1166 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1170 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1171 mark_vector, print_vector, 0,
1174 * No `hash' method needed for
1175 * vectors. internal_hash
1176 * knows how to handle vectors.
1180 size_vector, Lisp_Vector);
1182 /* #### should allocate `small' vectors from a frob-block */
1183 static Lisp_Vector *
1184 make_vector_internal (size_t sizei)
1186 /* no vector_next */
1187 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1188 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1195 make_vector (size_t length, Lisp_Object init)
1197 Lisp_Vector *vecp = make_vector_internal (length);
1198 Lisp_Object *p = vector_data (vecp);
1205 XSETVECTOR (vector, vecp);
1210 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1211 Return a new vector of length LENGTH, with each element being INIT.
1212 See also the function `vector'.
1216 CONCHECK_NATNUM (length);
1217 return make_vector (XINT (length), init);
1220 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1221 Return a newly created vector with specified arguments as elements.
1222 Any number of arguments, even zero arguments, are allowed.
1224 (int nargs, Lisp_Object *args))
1226 Lisp_Vector *vecp = make_vector_internal (nargs);
1227 Lisp_Object *p = vector_data (vecp);
1234 XSETVECTOR (vector, vecp);
1240 vector1 (Lisp_Object obj0)
1242 return Fvector (1, &obj0);
1246 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1248 Lisp_Object args[2];
1251 return Fvector (2, args);
1255 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1257 Lisp_Object args[3];
1261 return Fvector (3, args);
1264 #if 0 /* currently unused */
1267 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1270 Lisp_Object args[4];
1275 return Fvector (4, args);
1279 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1280 Lisp_Object obj3, Lisp_Object obj4)
1282 Lisp_Object args[5];
1288 return Fvector (5, args);
1292 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1293 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1295 Lisp_Object args[6];
1302 return Fvector (6, args);
1306 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1307 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1310 Lisp_Object args[7];
1318 return Fvector (7, args);
1322 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1323 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1324 Lisp_Object obj6, Lisp_Object obj7)
1326 Lisp_Object args[8];
1335 return Fvector (8, args);
1339 /************************************************************************/
1340 /* Bit Vector allocation */
1341 /************************************************************************/
1343 static Lisp_Object all_bit_vectors;
1345 /* #### should allocate `small' bit vectors from a frob-block */
1346 static Lisp_Bit_Vector *
1347 make_bit_vector_internal (size_t sizei)
1349 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1350 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1351 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1352 set_lheader_implementation (&(p->lheader), &lrecord_bit_vector);
1354 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1356 bit_vector_length (p) = sizei;
1357 bit_vector_next (p) = all_bit_vectors;
1358 /* make sure the extra bits in the last long are 0; the calling
1359 functions might not set them. */
1360 p->bits[num_longs - 1] = 0;
1361 XSETBIT_VECTOR (all_bit_vectors, p);
1366 make_bit_vector (size_t length, Lisp_Object init)
1368 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1369 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1374 memset (p->bits, 0, num_longs * sizeof (long));
1377 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1378 memset (p->bits, ~0, num_longs * sizeof (long));
1379 /* But we have to make sure that the unused bits in the
1380 last long are 0, so that equal/hash is easy. */
1382 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1386 Lisp_Object bit_vector;
1387 XSETBIT_VECTOR (bit_vector, p);
1393 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1396 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1398 for (i = 0; i < length; i++)
1399 set_bit_vector_bit (p, i, bytevec[i]);
1402 Lisp_Object bit_vector;
1403 XSETBIT_VECTOR (bit_vector, p);
1408 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1409 Return a new bit vector of length LENGTH. with each bit being INIT.
1410 Each element is set to INIT. See also the function `bit-vector'.
1414 CONCHECK_NATNUM (length);
1416 return make_bit_vector (XINT (length), init);
1419 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1420 Return a newly created bit vector with specified arguments as elements.
1421 Any number of arguments, even zero arguments, are allowed.
1423 (int nargs, Lisp_Object *args))
1426 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1428 for (i = 0; i < nargs; i++)
1430 CHECK_BIT (args[i]);
1431 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1435 Lisp_Object bit_vector;
1436 XSETBIT_VECTOR (bit_vector, p);
1442 /************************************************************************/
1443 /* Compiled-function allocation */
1444 /************************************************************************/
1446 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1447 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1450 make_compiled_function (void)
1452 Lisp_Compiled_Function *f;
1455 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1456 set_lheader_implementation (&(f->lheader), &lrecord_compiled_function);
1459 f->specpdl_depth = 0;
1460 f->flags.documentationp = 0;
1461 f->flags.interactivep = 0;
1462 f->flags.domainp = 0; /* I18N3 */
1463 f->instructions = Qzero;
1464 f->constants = Qzero;
1466 f->doc_and_interactive = Qnil;
1467 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1468 f->annotated = Qnil;
1470 XSETCOMPILED_FUNCTION (fun, f);
1474 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1475 Return a new compiled-function object.
1476 Usage: (arglist instructions constants stack-depth
1477 &optional doc-string interactive)
1478 Note that, unlike all other emacs-lisp functions, calling this with five
1479 arguments is NOT the same as calling it with six arguments, the last of
1480 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1481 that this function was defined with `(interactive)'. If the arg is not
1482 specified, then that means the function is not interactive.
1483 This is terrible behavior which is retained for compatibility with old
1484 `.elc' files which expect these semantics.
1486 (int nargs, Lisp_Object *args))
1488 /* In a non-insane world this function would have this arglist...
1489 (arglist instructions constants stack_depth &optional doc_string interactive)
1491 Lisp_Object fun = make_compiled_function ();
1492 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1494 Lisp_Object arglist = args[0];
1495 Lisp_Object instructions = args[1];
1496 Lisp_Object constants = args[2];
1497 Lisp_Object stack_depth = args[3];
1498 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1499 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1501 if (nargs < 4 || nargs > 6)
1502 return Fsignal (Qwrong_number_of_arguments,
1503 list2 (intern ("make-byte-code"), make_int (nargs)));
1505 /* Check for valid formal parameter list now, to allow us to use
1506 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1508 Lisp_Object symbol, tail;
1509 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1511 CHECK_SYMBOL (symbol);
1512 if (EQ (symbol, Qt) ||
1513 EQ (symbol, Qnil) ||
1514 SYMBOL_IS_KEYWORD (symbol))
1515 signal_simple_error_2
1516 ("Invalid constant symbol in formal parameter list",
1520 f->arglist = arglist;
1522 /* `instructions' is a string or a cons (string . int) for a
1523 lazy-loaded function. */
1524 if (CONSP (instructions))
1526 CHECK_STRING (XCAR (instructions));
1527 CHECK_INT (XCDR (instructions));
1531 CHECK_STRING (instructions);
1533 f->instructions = instructions;
1535 if (!NILP (constants))
1536 CHECK_VECTOR (constants);
1537 f->constants = constants;
1539 CHECK_NATNUM (stack_depth);
1540 f->stack_depth = XINT (stack_depth);
1542 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1543 if (!NILP (Vcurrent_compiled_function_annotation))
1544 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1545 else if (!NILP (Vload_file_name_internal_the_purecopy))
1546 f->annotated = Vload_file_name_internal_the_purecopy;
1547 else if (!NILP (Vload_file_name_internal))
1549 struct gcpro gcpro1;
1550 GCPRO1 (fun); /* don't let fun get reaped */
1551 Vload_file_name_internal_the_purecopy =
1552 Ffile_name_nondirectory (Vload_file_name_internal);
1553 f->annotated = Vload_file_name_internal_the_purecopy;
1556 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1558 /* doc_string may be nil, string, int, or a cons (string . int).
1559 interactive may be list or string (or unbound). */
1560 f->doc_and_interactive = Qunbound;
1562 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1563 f->doc_and_interactive = Vfile_domain;
1565 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1567 f->doc_and_interactive
1568 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1569 Fcons (interactive, f->doc_and_interactive));
1571 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1573 f->doc_and_interactive
1574 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1575 Fcons (doc_string, f->doc_and_interactive));
1577 if (UNBOUNDP (f->doc_and_interactive))
1578 f->doc_and_interactive = Qnil;
1584 /************************************************************************/
1585 /* Symbol allocation */
1586 /************************************************************************/
1588 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1589 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1591 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1592 Return a newly allocated uninterned symbol whose name is NAME.
1593 Its value and function definition are void, and its property list is nil.
1600 CHECK_STRING (name);
1602 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1603 set_lheader_implementation (&(p->lheader), &lrecord_symbol);
1604 p->name = XSTRING (name);
1606 p->value = Qunbound;
1607 p->function = Qunbound;
1608 symbol_next (p) = 0;
1609 XSETSYMBOL (val, p);
1614 /************************************************************************/
1615 /* Extent allocation */
1616 /************************************************************************/
1618 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1619 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1622 allocate_extent (void)
1626 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1627 set_lheader_implementation (&(e->lheader), &lrecord_extent);
1628 extent_object (e) = Qnil;
1629 set_extent_start (e, -1);
1630 set_extent_end (e, -1);
1635 extent_face (e) = Qnil;
1636 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1637 e->flags.detachable = 1;
1643 /************************************************************************/
1644 /* Event allocation */
1645 /************************************************************************/
1647 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1648 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1651 allocate_event (void)
1656 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1657 set_lheader_implementation (&(e->lheader), &lrecord_event);
1664 /************************************************************************/
1665 /* Marker allocation */
1666 /************************************************************************/
1668 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1669 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1671 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1672 Return a new marker which does not point at any place.
1679 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1680 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1683 marker_next (p) = 0;
1684 marker_prev (p) = 0;
1685 p->insertion_type = 0;
1686 XSETMARKER (val, p);
1691 noseeum_make_marker (void)
1696 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1697 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1700 marker_next (p) = 0;
1701 marker_prev (p) = 0;
1702 p->insertion_type = 0;
1703 XSETMARKER (val, p);
1708 /************************************************************************/
1709 /* String allocation */
1710 /************************************************************************/
1712 /* The data for "short" strings generally resides inside of structs of type
1713 string_chars_block. The Lisp_String structure is allocated just like any
1714 other Lisp object (except for vectors), and these are freelisted when
1715 they get garbage collected. The data for short strings get compacted,
1716 but the data for large strings do not.
1718 Previously Lisp_String structures were relocated, but this caused a lot
1719 of bus-errors because the C code didn't include enough GCPRO's for
1720 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1721 that the reference would get relocated).
1723 This new method makes things somewhat bigger, but it is MUCH safer. */
1725 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1726 /* strings are used and freed quite often */
1727 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1728 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1731 mark_string (Lisp_Object obj)
1733 Lisp_String *ptr = XSTRING (obj);
1735 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1736 flush_cached_extent_info (XCAR (ptr->plist));
1741 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1744 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1745 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1748 static const struct lrecord_description string_description[] = {
1749 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1750 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1751 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1755 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
1756 mark_string, print_string,
1758 * No `finalize', or `hash' methods.
1759 * internal_hash already knows how
1760 * to hash strings and finalization
1762 * ADDITIONAL_FREE_string macro,
1763 * which is the standard way to do
1764 * finalization when using
1765 * SWEEP_FIXED_TYPE_BLOCK().
1771 /* String blocks contain this many useful bytes. */
1772 #define STRING_CHARS_BLOCK_SIZE \
1773 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1774 ((2 * sizeof (struct string_chars_block *)) \
1775 + sizeof (EMACS_INT))))
1776 /* Block header for small strings. */
1777 struct string_chars_block
1780 struct string_chars_block *next;
1781 struct string_chars_block *prev;
1782 /* Contents of string_chars_block->string_chars are interleaved
1783 string_chars structures (see below) and the actual string data */
1784 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1787 static struct string_chars_block *first_string_chars_block;
1788 static struct string_chars_block *current_string_chars_block;
1790 /* If SIZE is the length of a string, this returns how many bytes
1791 * the string occupies in string_chars_block->string_chars
1792 * (including alignment padding).
1794 #define STRING_FULLSIZE(size) \
1795 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1796 ALIGNOF (Lisp_String *))
1798 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1799 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1803 Lisp_String *string;
1804 unsigned char chars[1];
1807 struct unused_string_chars
1809 Lisp_String *string;
1814 init_string_chars_alloc (void)
1816 first_string_chars_block = xnew (struct string_chars_block);
1817 first_string_chars_block->prev = 0;
1818 first_string_chars_block->next = 0;
1819 first_string_chars_block->pos = 0;
1820 current_string_chars_block = first_string_chars_block;
1823 static struct string_chars *
1824 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1827 struct string_chars *s_chars;
1830 (countof (current_string_chars_block->string_chars)
1831 - current_string_chars_block->pos))
1833 /* This string can fit in the current string chars block */
1834 s_chars = (struct string_chars *)
1835 (current_string_chars_block->string_chars
1836 + current_string_chars_block->pos);
1837 current_string_chars_block->pos += fullsize;
1841 /* Make a new current string chars block */
1842 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1844 current_string_chars_block->next = new_scb;
1845 new_scb->prev = current_string_chars_block;
1847 current_string_chars_block = new_scb;
1848 new_scb->pos = fullsize;
1849 s_chars = (struct string_chars *)
1850 current_string_chars_block->string_chars;
1853 s_chars->string = string_it_goes_with;
1855 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1861 make_uninit_string (Bytecount length)
1864 EMACS_INT fullsize = STRING_FULLSIZE (length);
1867 assert (length >= 0 && fullsize > 0);
1869 /* Allocate the string header */
1870 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1871 set_lheader_implementation (&(s->lheader), &lrecord_string);
1873 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1874 ? xnew_array (Bufbyte, length + 1)
1875 : allocate_string_chars_struct (s, fullsize)->chars);
1877 set_string_length (s, length);
1880 set_string_byte (s, length, 0);
1882 XSETSTRING (val, s);
1886 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1887 static void verify_string_chars_integrity (void);
1890 /* Resize the string S so that DELTA bytes can be inserted starting
1891 at POS. If DELTA < 0, it means deletion starting at POS. If
1892 POS < 0, resize the string but don't copy any characters. Use
1893 this if you're planning on completely overwriting the string.
1897 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
1899 Bytecount oldfullsize, newfullsize;
1900 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1901 verify_string_chars_integrity ();
1904 #ifdef ERROR_CHECK_BUFPOS
1907 assert (pos <= string_length (s));
1909 assert (pos + (-delta) <= string_length (s));
1914 assert ((-delta) <= string_length (s));
1916 #endif /* ERROR_CHECK_BUFPOS */
1919 /* simplest case: no size change. */
1922 if (pos >= 0 && delta < 0)
1923 /* If DELTA < 0, the functions below will delete the characters
1924 before POS. We want to delete characters *after* POS, however,
1925 so convert this to the appropriate form. */
1928 oldfullsize = STRING_FULLSIZE (string_length (s));
1929 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1931 if (BIG_STRING_FULLSIZE_P (oldfullsize))
1933 if (BIG_STRING_FULLSIZE_P (newfullsize))
1935 /* Both strings are big. We can just realloc().
1936 But careful! If the string is shrinking, we have to
1937 memmove() _before_ realloc(), and if growing, we have to
1938 memmove() _after_ realloc() - otherwise the access is
1939 illegal, and we might crash. */
1940 Bytecount len = string_length (s) + 1 - pos;
1942 if (delta < 0 && pos >= 0)
1943 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1944 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1945 string_length (s) + delta + 1));
1946 if (delta > 0 && pos >= 0)
1947 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1949 else /* String has been demoted from BIG_STRING. */
1952 allocate_string_chars_struct (s, newfullsize)->chars;
1953 Bufbyte *old_data = string_data (s);
1957 memcpy (new_data, old_data, pos);
1958 memcpy (new_data + pos + delta, old_data + pos,
1959 string_length (s) + 1 - pos);
1961 set_string_data (s, new_data);
1965 else /* old string is small */
1967 if (oldfullsize == newfullsize)
1969 /* special case; size change but the necessary
1970 allocation size won't change (up or down; code
1971 somewhere depends on there not being any unused
1972 allocation space, modulo any alignment
1976 Bufbyte *addroff = pos + string_data (s);
1978 memmove (addroff + delta, addroff,
1979 /* +1 due to zero-termination. */
1980 string_length (s) + 1 - pos);
1985 Bufbyte *old_data = string_data (s);
1987 BIG_STRING_FULLSIZE_P (newfullsize)
1988 ? xnew_array (Bufbyte, string_length (s) + delta + 1)
1989 : allocate_string_chars_struct (s, newfullsize)->chars;
1993 memcpy (new_data, old_data, pos);
1994 memcpy (new_data + pos + delta, old_data + pos,
1995 string_length (s) + 1 - pos);
1997 set_string_data (s, new_data);
2000 /* We need to mark this chunk of the string_chars_block
2001 as unused so that compact_string_chars() doesn't
2003 struct string_chars *old_s_chars = (struct string_chars *)
2004 ((char *) old_data - offsetof (struct string_chars, chars));
2005 /* Sanity check to make sure we aren't hosed by strange
2006 alignment/padding. */
2007 assert (old_s_chars->string == s);
2008 MARK_STRUCT_AS_FREE (old_s_chars);
2009 ((struct unused_string_chars *) old_s_chars)->fullsize =
2015 set_string_length (s, string_length (s) + delta);
2016 /* If pos < 0, the string won't be zero-terminated.
2017 Terminate now just to make sure. */
2018 string_data (s)[string_length (s)] = '\0';
2024 XSETSTRING (string, s);
2025 /* We also have to adjust all of the extent indices after the
2026 place we did the change. We say "pos - 1" because
2027 adjust_extents() is exclusive of the starting position
2029 adjust_extents (string, pos - 1, string_length (s),
2033 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2034 verify_string_chars_integrity ();
2041 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2043 Bufbyte newstr[MAX_EMCHAR_LEN];
2044 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2045 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2046 Bytecount newlen = set_charptr_emchar (newstr, c);
2048 if (oldlen != newlen)
2049 resize_string (s, bytoff, newlen - oldlen);
2050 /* Remember, string_data (s) might have changed so we can't cache it. */
2051 memcpy (string_data (s) + bytoff, newstr, newlen);
2056 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2057 Return a new string of length LENGTH, with each character being INIT.
2058 LENGTH must be an integer and INIT must be a character.
2062 CHECK_NATNUM (length);
2063 CHECK_CHAR_COERCE_INT (init);
2065 Bufbyte init_str[MAX_EMCHAR_LEN];
2066 int len = set_charptr_emchar (init_str, XCHAR (init));
2067 Lisp_Object val = make_uninit_string (len * XINT (length));
2070 /* Optimize the single-byte case */
2071 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2075 Bufbyte *ptr = XSTRING_DATA (val);
2077 for (i = XINT (length); i; i--)
2079 Bufbyte *init_ptr = init_str;
2083 case 6: *ptr++ = *init_ptr++;
2084 case 5: *ptr++ = *init_ptr++;
2086 case 4: *ptr++ = *init_ptr++;
2087 case 3: *ptr++ = *init_ptr++;
2088 case 2: *ptr++ = *init_ptr++;
2089 case 1: *ptr++ = *init_ptr++;
2097 DEFUN ("string", Fstring, 0, MANY, 0, /*
2098 Concatenate all the argument characters and make the result a string.
2100 (int nargs, Lisp_Object *args))
2102 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2103 Bufbyte *p = storage;
2105 for (; nargs; nargs--, args++)
2107 Lisp_Object lisp_char = *args;
2108 CHECK_CHAR_COERCE_INT (lisp_char);
2109 p += set_charptr_emchar (p, XCHAR (lisp_char));
2111 return make_string (storage, p - storage);
2115 /* Take some raw memory, which MUST already be in internal format,
2116 and package it up into a Lisp string. */
2118 make_string (CONST Bufbyte *contents, Bytecount length)
2122 /* Make sure we find out about bad make_string's when they happen */
2123 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2124 bytecount_to_charcount (contents, length); /* Just for the assertions */
2127 val = make_uninit_string (length);
2128 memcpy (XSTRING_DATA (val), contents, length);
2132 /* Take some raw memory, encoded in some external data format,
2133 and convert it into a Lisp string. */
2135 make_ext_string (CONST Extbyte *contents, EMACS_INT length,
2136 Lisp_Object coding_system)
2139 TO_INTERNAL_FORMAT (DATA, (contents, length),
2140 LISP_STRING, string,
2146 build_string (CONST char *str)
2148 /* Some strlen's crash and burn if passed null. */
2149 return make_string ((CONST Bufbyte *) str, (str ? strlen(str) : 0));
2153 build_ext_string (CONST char *str, Lisp_Object coding_system)
2155 /* Some strlen's crash and burn if passed null. */
2156 return make_ext_string ((CONST Extbyte *) str, (str ? strlen(str) : 0),
2161 build_translated_string (CONST char *str)
2163 return build_string (GETTEXT (str));
2167 make_string_nocopy (CONST Bufbyte *contents, Bytecount length)
2172 /* Make sure we find out about bad make_string_nocopy's when they happen */
2173 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2174 bytecount_to_charcount (contents, length); /* Just for the assertions */
2177 /* Allocate the string header */
2178 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2179 set_lheader_implementation (&(s->lheader), &lrecord_string);
2180 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2182 set_string_data (s, (Bufbyte *)contents);
2183 set_string_length (s, length);
2185 XSETSTRING (val, s);
2190 /************************************************************************/
2191 /* lcrecord lists */
2192 /************************************************************************/
2194 /* Lcrecord lists are used to manage the allocation of particular
2195 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2196 malloc() and garbage-collection junk) as much as possible.
2197 It is similar to the Blocktype class.
2201 1) Create an lcrecord-list object using make_lcrecord_list().
2202 This is often done at initialization. Remember to staticpro_nodump
2203 this object! The arguments to make_lcrecord_list() are the
2204 same as would be passed to alloc_lcrecord().
2205 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2206 and pass the lcrecord-list earlier created.
2207 3) When done with the lcrecord, call free_managed_lcrecord().
2208 The standard freeing caveats apply: ** make sure there are no
2209 pointers to the object anywhere! **
2210 4) Calling free_managed_lcrecord() is just like kissing the
2211 lcrecord goodbye as if it were garbage-collected. This means:
2212 -- the contents of the freed lcrecord are undefined, and the
2213 contents of something produced by allocate_managed_lcrecord()
2214 are undefined, just like for alloc_lcrecord().
2215 -- the mark method for the lcrecord's type will *NEVER* be called
2217 -- the finalize method for the lcrecord's type will be called
2218 at the time that free_managed_lcrecord() is called.
2223 mark_lcrecord_list (Lisp_Object obj)
2225 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2226 Lisp_Object chain = list->free;
2228 while (!NILP (chain))
2230 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2231 struct free_lcrecord_header *free_header =
2232 (struct free_lcrecord_header *) lheader;
2234 #ifdef ERROR_CHECK_GC
2235 CONST struct lrecord_implementation *implementation
2236 = LHEADER_IMPLEMENTATION(lheader);
2238 /* There should be no other pointers to the free list. */
2239 assert (!MARKED_RECORD_HEADER_P (lheader));
2240 /* Only lcrecords should be here. */
2241 assert (!implementation->basic_p);
2242 /* Only free lcrecords should be here. */
2243 assert (free_header->lcheader.free);
2244 /* The type of the lcrecord must be right. */
2245 assert (implementation == list->implementation);
2246 /* So must the size. */
2247 assert (implementation->static_size == 0
2248 || implementation->static_size == list->size);
2249 #endif /* ERROR_CHECK_GC */
2251 MARK_RECORD_HEADER (lheader);
2252 chain = free_header->chain;
2258 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2259 mark_lcrecord_list, internal_object_printer,
2260 0, 0, 0, 0, struct lcrecord_list);
2262 make_lcrecord_list (size_t size,
2263 CONST struct lrecord_implementation *implementation)
2265 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2266 &lrecord_lcrecord_list);
2269 p->implementation = implementation;
2272 XSETLCRECORD_LIST (val, p);
2277 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2279 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2280 if (!NILP (list->free))
2282 Lisp_Object val = list->free;
2283 struct free_lcrecord_header *free_header =
2284 (struct free_lcrecord_header *) XPNTR (val);
2286 #ifdef ERROR_CHECK_GC
2287 struct lrecord_header *lheader =
2288 (struct lrecord_header *) free_header;
2289 CONST struct lrecord_implementation *implementation
2290 = LHEADER_IMPLEMENTATION (lheader);
2292 /* There should be no other pointers to the free list. */
2293 assert (!MARKED_RECORD_HEADER_P (lheader));
2294 /* Only lcrecords should be here. */
2295 assert (!implementation->basic_p);
2296 /* Only free lcrecords should be here. */
2297 assert (free_header->lcheader.free);
2298 /* The type of the lcrecord must be right. */
2299 assert (implementation == list->implementation);
2300 /* So must the size. */
2301 assert (implementation->static_size == 0
2302 || implementation->static_size == list->size);
2303 #endif /* ERROR_CHECK_GC */
2304 list->free = free_header->chain;
2305 free_header->lcheader.free = 0;
2312 XSETOBJ (val, Lisp_Type_Record,
2313 alloc_lcrecord (list->size, list->implementation));
2319 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2321 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2322 struct free_lcrecord_header *free_header =
2323 (struct free_lcrecord_header *) XPNTR (lcrecord);
2324 struct lrecord_header *lheader =
2325 (struct lrecord_header *) free_header;
2326 CONST struct lrecord_implementation *implementation
2327 = LHEADER_IMPLEMENTATION (lheader);
2329 #ifdef ERROR_CHECK_GC
2330 /* Make sure the size is correct. This will catch, for example,
2331 putting a window configuration on the wrong free list. */
2332 if (implementation->size_in_bytes_method)
2333 assert (implementation->size_in_bytes_method (lheader) == list->size);
2335 assert (implementation->static_size == list->size);
2336 #endif /* ERROR_CHECK_GC */
2338 if (implementation->finalizer)
2339 implementation->finalizer (lheader, 0);
2340 free_header->chain = list->free;
2341 free_header->lcheader.free = 1;
2342 list->free = lcrecord;
2348 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2349 Kept for compatibility, returns its argument.
2351 Make a copy of OBJECT in pure storage.
2352 Recursively copies contents of vectors and cons cells.
2353 Does not copy symbols.
2362 /************************************************************************/
2363 /* Garbage Collection */
2364 /************************************************************************/
2366 /* This will be used more extensively In The Future */
2367 static int last_lrecord_type_index_assigned;
2369 CONST struct lrecord_implementation *lrecord_implementations_table[128];
2370 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
2372 struct gcpro *gcprolist;
2374 /* 415 used Mly 29-Jun-93 */
2375 /* 1327 used slb 28-Feb-98 */
2376 /* 1328 used og 03-Oct-99 (moving slowly, heh?) */
2378 #define NSTATICS 4000
2380 #define NSTATICS 2000
2382 /* Not "static" because of linker lossage on some systems */
2383 Lisp_Object *staticvec[NSTATICS]
2384 /* Force it into data space! */
2386 static int staticidx;
2388 /* Put an entry in staticvec, pointing at the variable whose address is given
2391 staticpro (Lisp_Object *varaddress)
2393 if (staticidx >= countof (staticvec))
2394 /* #### This is now a dubious abort() since this routine may be called */
2395 /* by Lisp attempting to load a DLL. */
2397 staticvec[staticidx++] = varaddress;
2400 /* Not "static" because of linker lossage on some systems */
2401 Lisp_Object *staticvec_nodump[200]
2402 /* Force it into data space! */
2404 static int staticidx_nodump;
2406 /* Put an entry in staticvec_nodump, pointing at the variable whose address is given
2409 staticpro_nodump (Lisp_Object *varaddress)
2411 if (staticidx_nodump >= countof (staticvec_nodump))
2412 /* #### This is now a dubious abort() since this routine may be called */
2413 /* by Lisp attempting to load a DLL. */
2415 staticvec_nodump[staticidx_nodump++] = varaddress;
2418 /* Not "static" because of linker lossage on some systems */
2422 const struct struct_description *desc;
2423 } dumpstructvec[200];
2425 static int dumpstructidx;
2427 /* Put an entry in dumpstructvec, pointing at the variable whose address is given
2430 dumpstruct (void *varaddress, const struct struct_description *desc)
2432 if (dumpstructidx >= countof (dumpstructvec))
2434 dumpstructvec[dumpstructidx].data = varaddress;
2435 dumpstructvec[dumpstructidx].desc = desc;
2439 Lisp_Object *pdump_wirevec[50];
2440 static int pdump_wireidx;
2442 /* Put an entry in pdump_wirevec, pointing at the variable whose address is given
2445 pdump_wire (Lisp_Object *varaddress)
2447 if (pdump_wireidx >= countof (pdump_wirevec))
2449 pdump_wirevec[pdump_wireidx++] = varaddress;
2453 Lisp_Object *pdump_wirevec_list[50];
2454 static int pdump_wireidx_list;
2456 /* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given
2459 pdump_wire_list (Lisp_Object *varaddress)
2461 if (pdump_wireidx_list >= countof (pdump_wirevec_list))
2463 pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
2467 /* Mark reference to a Lisp_Object. If the object referred to has not been
2468 seen yet, recursively mark all the references contained in it. */
2471 mark_object (Lisp_Object obj)
2475 #ifdef ERROR_CHECK_GC
2476 assert (! (EQ (obj, Qnull_pointer)));
2478 /* Checks we used to perform */
2479 /* if (EQ (obj, Qnull_pointer)) return; */
2480 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2481 /* if (PURIFIED (XPNTR (obj))) return; */
2483 if (XTYPE (obj) == Lisp_Type_Record)
2485 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2486 #if defined (ERROR_CHECK_GC)
2487 assert (lheader->type <= last_lrecord_type_index_assigned);
2489 if (C_READONLY_RECORD_HEADER_P (lheader))
2492 if (! MARKED_RECORD_HEADER_P (lheader) &&
2493 ! UNMARKABLE_RECORD_HEADER_P (lheader))
2495 CONST struct lrecord_implementation *implementation =
2496 LHEADER_IMPLEMENTATION (lheader);
2497 MARK_RECORD_HEADER (lheader);
2498 #ifdef ERROR_CHECK_GC
2499 if (!implementation->basic_p)
2500 assert (! ((struct lcrecord_header *) lheader)->free);
2502 if (implementation->marker)
2504 obj = implementation->marker (obj);
2505 if (!NILP (obj)) goto tail_recurse;
2511 /* mark all of the conses in a list and mark the final cdr; but
2512 DO NOT mark the cars.
2514 Use only for internal lists! There should never be other pointers
2515 to the cons cells, because if so, the cars will remain unmarked
2516 even when they maybe should be marked. */
2518 mark_conses_in_list (Lisp_Object obj)
2522 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2524 if (CONS_MARKED_P (XCONS (rest)))
2526 MARK_CONS (XCONS (rest));
2533 /* Find all structures not marked, and free them. */
2535 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2536 static int gc_count_bit_vector_storage;
2537 static int gc_count_num_short_string_in_use;
2538 static int gc_count_string_total_size;
2539 static int gc_count_short_string_total_size;
2541 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2545 lrecord_type_index (CONST struct lrecord_implementation *implementation)
2547 int type_index = *(implementation->lrecord_type_index);
2548 /* Have to do this circuitous validation test because of problems
2549 dumping out initialized variables (ie can't set xxx_type_index to -1
2550 because that would make xxx_type_index read-only in a dumped emacs. */
2551 if (type_index < 0 || type_index > max_lrecord_type
2552 || lrecord_implementations_table[type_index] != implementation)
2554 assert (last_lrecord_type_index_assigned < max_lrecord_type);
2555 type_index = ++last_lrecord_type_index_assigned;
2556 lrecord_implementations_table[type_index] = implementation;
2557 *(implementation->lrecord_type_index) = type_index;
2562 /* stats on lcrecords in use - kinda kludgy */
2566 int instances_in_use;
2568 int instances_freed;
2570 int instances_on_free_list;
2571 } lcrecord_stats [countof (lrecord_implementations_table)];
2574 tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p)
2576 CONST struct lrecord_implementation *implementation =
2577 LHEADER_IMPLEMENTATION (h);
2578 int type_index = lrecord_type_index (implementation);
2580 if (((struct lcrecord_header *) h)->free)
2583 lcrecord_stats[type_index].instances_on_free_list++;
2587 size_t sz = (implementation->size_in_bytes_method
2588 ? implementation->size_in_bytes_method (h)
2589 : implementation->static_size);
2593 lcrecord_stats[type_index].instances_freed++;
2594 lcrecord_stats[type_index].bytes_freed += sz;
2598 lcrecord_stats[type_index].instances_in_use++;
2599 lcrecord_stats[type_index].bytes_in_use += sz;
2605 /* Free all unmarked records */
2607 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2609 struct lcrecord_header *header;
2611 /* int total_size = 0; */
2613 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2615 /* First go through and call all the finalize methods.
2616 Then go through and free the objects. There used to
2617 be only one loop here, with the call to the finalizer
2618 occurring directly before the xfree() below. That
2619 is marginally faster but much less safe -- if the
2620 finalize method for an object needs to reference any
2621 other objects contained within it (and many do),
2622 we could easily be screwed by having already freed that
2625 for (header = *prev; header; header = header->next)
2627 struct lrecord_header *h = &(header->lheader);
2628 if (!C_READONLY_RECORD_HEADER_P(h)
2629 && !MARKED_RECORD_HEADER_P (h)
2630 && ! (header->free))
2632 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2633 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2637 for (header = *prev; header; )
2639 struct lrecord_header *h = &(header->lheader);
2640 if (C_READONLY_RECORD_HEADER_P(h) || MARKED_RECORD_HEADER_P (h))
2642 if (MARKED_RECORD_HEADER_P (h))
2643 UNMARK_RECORD_HEADER (h);
2645 /* total_size += n->implementation->size_in_bytes (h);*/
2646 /* #### May modify header->next on a C_READONLY lcrecord */
2647 prev = &(header->next);
2649 tick_lcrecord_stats (h, 0);
2653 struct lcrecord_header *next = header->next;
2655 tick_lcrecord_stats (h, 1);
2656 /* used to call finalizer right here. */
2662 /* *total = total_size; */
2667 sweep_bit_vectors_1 (Lisp_Object *prev,
2668 int *used, int *total, int *storage)
2670 Lisp_Object bit_vector;
2673 int total_storage = 0;
2675 /* BIT_VECTORP fails because the objects are marked, which changes
2676 their implementation */
2677 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2679 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2681 if (C_READONLY_RECORD_HEADER_P(&(v->lheader)) || MARKED_RECORD_P (bit_vector))
2683 if (MARKED_RECORD_P (bit_vector))
2684 UNMARK_RECORD_HEADER (&(v->lheader));
2688 STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2689 BIT_VECTOR_LONG_STORAGE (len));
2691 /* #### May modify next on a C_READONLY bitvector */
2692 prev = &(bit_vector_next (v));
2697 Lisp_Object next = bit_vector_next (v);
2704 *total = total_size;
2705 *storage = total_storage;
2708 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2709 to make macros prettier. */
2711 #ifdef ERROR_CHECK_GC
2713 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2715 struct typename##_block *SFTB_current; \
2716 struct typename##_block **SFTB_prev; \
2718 int num_free = 0, num_used = 0; \
2720 for (SFTB_prev = ¤t_##typename##_block, \
2721 SFTB_current = current_##typename##_block, \
2722 SFTB_limit = current_##typename##_block_index; \
2728 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2730 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2732 if (FREE_STRUCT_P (SFTB_victim)) \
2736 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2740 else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2743 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2748 UNMARK_##typename (SFTB_victim); \
2751 SFTB_prev = &(SFTB_current->prev); \
2752 SFTB_current = SFTB_current->prev; \
2753 SFTB_limit = countof (current_##typename##_block->block); \
2756 gc_count_num_##typename##_in_use = num_used; \
2757 gc_count_num_##typename##_freelist = num_free; \
2760 #else /* !ERROR_CHECK_GC */
2762 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2764 struct typename##_block *SFTB_current; \
2765 struct typename##_block **SFTB_prev; \
2767 int num_free = 0, num_used = 0; \
2769 typename##_free_list = 0; \
2771 for (SFTB_prev = ¤t_##typename##_block, \
2772 SFTB_current = current_##typename##_block, \
2773 SFTB_limit = current_##typename##_block_index; \
2778 int SFTB_empty = 1; \
2779 obj_type *SFTB_old_free_list = typename##_free_list; \
2781 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2783 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2785 if (FREE_STRUCT_P (SFTB_victim)) \
2788 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2790 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2795 else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2798 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2804 UNMARK_##typename (SFTB_victim); \
2809 SFTB_prev = &(SFTB_current->prev); \
2810 SFTB_current = SFTB_current->prev; \
2812 else if (SFTB_current == current_##typename##_block \
2813 && !SFTB_current->prev) \
2815 /* No real point in freeing sole allocation block */ \
2820 struct typename##_block *SFTB_victim_block = SFTB_current; \
2821 if (SFTB_victim_block == current_##typename##_block) \
2822 current_##typename##_block_index \
2823 = countof (current_##typename##_block->block); \
2824 SFTB_current = SFTB_current->prev; \
2826 *SFTB_prev = SFTB_current; \
2827 xfree (SFTB_victim_block); \
2828 /* Restore free list to what it was before victim was swept */ \
2829 typename##_free_list = SFTB_old_free_list; \
2830 num_free -= SFTB_limit; \
2833 SFTB_limit = countof (current_##typename##_block->block); \
2836 gc_count_num_##typename##_in_use = num_used; \
2837 gc_count_num_##typename##_freelist = num_free; \
2840 #endif /* !ERROR_CHECK_GC */
2848 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2849 #define ADDITIONAL_FREE_cons(ptr)
2851 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2854 /* Explicitly free a cons cell. */
2856 free_cons (Lisp_Cons *ptr)
2858 #ifdef ERROR_CHECK_GC
2859 /* If the CAR is not an int, then it will be a pointer, which will
2860 always be four-byte aligned. If this cons cell has already been
2861 placed on the free list, however, its car will probably contain
2862 a chain pointer to the next cons on the list, which has cleverly
2863 had all its 0's and 1's inverted. This allows for a quick
2864 check to make sure we're not freeing something already freed. */
2865 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2866 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2867 #endif /* ERROR_CHECK_GC */
2869 #ifndef ALLOC_NO_POOLS
2870 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2871 #endif /* ALLOC_NO_POOLS */
2874 /* explicitly free a list. You **must make sure** that you have
2875 created all the cons cells that make up this list and that there
2876 are no pointers to any of these cons cells anywhere else. If there
2877 are, you will lose. */
2880 free_list (Lisp_Object list)
2882 Lisp_Object rest, next;
2884 for (rest = list; !NILP (rest); rest = next)
2887 free_cons (XCONS (rest));
2891 /* explicitly free an alist. You **must make sure** that you have
2892 created all the cons cells that make up this alist and that there
2893 are no pointers to any of these cons cells anywhere else. If there
2894 are, you will lose. */
2897 free_alist (Lisp_Object alist)
2899 Lisp_Object rest, next;
2901 for (rest = alist; !NILP (rest); rest = next)
2904 free_cons (XCONS (XCAR (rest)));
2905 free_cons (XCONS (rest));
2910 sweep_compiled_functions (void)
2912 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2913 #define ADDITIONAL_FREE_compiled_function(ptr)
2915 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2919 #ifdef LISP_FLOAT_TYPE
2923 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2924 #define ADDITIONAL_FREE_float(ptr)
2926 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
2928 #endif /* LISP_FLOAT_TYPE */
2931 sweep_symbols (void)
2933 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2934 #define ADDITIONAL_FREE_symbol(ptr)
2936 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
2940 sweep_extents (void)
2942 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2943 #define ADDITIONAL_FREE_extent(ptr)
2945 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2951 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2952 #define ADDITIONAL_FREE_event(ptr)
2954 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
2958 sweep_markers (void)
2960 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2961 #define ADDITIONAL_FREE_marker(ptr) \
2962 do { Lisp_Object tem; \
2963 XSETMARKER (tem, ptr); \
2964 unchain_marker (tem); \
2967 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
2970 /* Explicitly free a marker. */
2972 free_marker (Lisp_Marker *ptr)
2974 #ifdef ERROR_CHECK_GC
2975 /* Perhaps this will catch freeing an already-freed marker. */
2977 XSETMARKER (temmy, ptr);
2978 assert (MARKERP (temmy));
2979 #endif /* ERROR_CHECK_GC */
2981 #ifndef ALLOC_NO_POOLS
2982 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
2983 #endif /* ALLOC_NO_POOLS */
2987 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2990 verify_string_chars_integrity (void)
2992 struct string_chars_block *sb;
2994 /* Scan each existing string block sequentially, string by string. */
2995 for (sb = first_string_chars_block; sb; sb = sb->next)
2998 /* POS is the index of the next string in the block. */
2999 while (pos < sb->pos)
3001 struct string_chars *s_chars =
3002 (struct string_chars *) &(sb->string_chars[pos]);
3003 Lisp_String *string;
3007 /* If the string_chars struct is marked as free (i.e. the STRING
3008 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3009 storage. (See below.) */
3011 if (FREE_STRUCT_P (s_chars))
3013 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3018 string = s_chars->string;
3019 /* Must be 32-bit aligned. */
3020 assert ((((int) string) & 3) == 0);
3022 size = string_length (string);
3023 fullsize = STRING_FULLSIZE (size);
3025 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3026 assert (string_data (string) == s_chars->chars);
3029 assert (pos == sb->pos);
3033 #endif /* MULE && ERROR_CHECK_GC */
3035 /* Compactify string chars, relocating the reference to each --
3036 free any empty string_chars_block we see. */
3038 compact_string_chars (void)
3040 struct string_chars_block *to_sb = first_string_chars_block;
3042 struct string_chars_block *from_sb;
3044 /* Scan each existing string block sequentially, string by string. */
3045 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3048 /* FROM_POS is the index of the next string in the block. */
3049 while (from_pos < from_sb->pos)
3051 struct string_chars *from_s_chars =
3052 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3053 struct string_chars *to_s_chars;
3054 Lisp_String *string;
3058 /* If the string_chars struct is marked as free (i.e. the STRING
3059 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3060 storage. This happens under Mule when a string's size changes
3061 in such a way that its fullsize changes. (Strings can change
3062 size because a different-length character can be substituted
3063 for another character.) In this case, after the bogus string
3064 pointer is the "fullsize" of this entry, i.e. how many bytes
3067 if (FREE_STRUCT_P (from_s_chars))
3069 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3070 from_pos += fullsize;
3074 string = from_s_chars->string;
3075 assert (!(FREE_STRUCT_P (string)));
3077 size = string_length (string);
3078 fullsize = STRING_FULLSIZE (size);
3080 if (BIG_STRING_FULLSIZE_P (fullsize))
3083 /* Just skip it if it isn't marked. */
3084 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3086 from_pos += fullsize;
3090 /* If it won't fit in what's left of TO_SB, close TO_SB out
3091 and go on to the next string_chars_block. We know that TO_SB
3092 cannot advance past FROM_SB here since FROM_SB is large enough
3093 to currently contain this string. */
3094 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3096 to_sb->pos = to_pos;
3097 to_sb = to_sb->next;
3101 /* Compute new address of this string
3102 and update TO_POS for the space being used. */
3103 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3105 /* Copy the string_chars to the new place. */
3106 if (from_s_chars != to_s_chars)
3107 memmove (to_s_chars, from_s_chars, fullsize);
3109 /* Relocate FROM_S_CHARS's reference */
3110 set_string_data (string, &(to_s_chars->chars[0]));
3112 from_pos += fullsize;
3117 /* Set current to the last string chars block still used and
3118 free any that follow. */
3120 struct string_chars_block *victim;
3122 for (victim = to_sb->next; victim; )
3124 struct string_chars_block *next = victim->next;
3129 current_string_chars_block = to_sb;
3130 current_string_chars_block->pos = to_pos;
3131 current_string_chars_block->next = 0;
3135 #if 1 /* Hack to debug missing purecopy's */
3136 static int debug_string_purity;
3139 debug_string_purity_print (Lisp_String *p)
3142 Charcount s = string_char_length (p);
3143 putc ('\"', stderr);
3144 for (i = 0; i < s; i++)
3146 Emchar ch = string_char (p, i);
3147 if (ch < 32 || ch >= 126)
3148 stderr_out ("\\%03o", ch);
3149 else if (ch == '\\' || ch == '\"')
3150 stderr_out ("\\%c", ch);
3152 stderr_out ("%c", ch);
3154 stderr_out ("\"\n");
3160 sweep_strings (void)
3162 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3163 int debug = debug_string_purity;
3165 #define UNMARK_string(ptr) do { \
3166 Lisp_String *p = (ptr); \
3167 size_t size = string_length (p); \
3168 UNMARK_RECORD_HEADER (&(p->lheader)); \
3169 num_bytes += size; \
3170 if (!BIG_STRING_SIZE_P (size)) \
3171 { num_small_bytes += size; \
3175 debug_string_purity_print (p); \
3177 #define ADDITIONAL_FREE_string(ptr) do { \
3178 size_t size = string_length (ptr); \
3179 if (BIG_STRING_SIZE_P (size)) \
3180 xfree (ptr->data); \
3183 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3185 gc_count_num_short_string_in_use = num_small_used;
3186 gc_count_string_total_size = num_bytes;
3187 gc_count_short_string_total_size = num_small_bytes;
3191 /* I hate duplicating all this crap! */
3193 marked_p (Lisp_Object obj)
3195 #ifdef ERROR_CHECK_GC
3196 assert (! (EQ (obj, Qnull_pointer)));
3198 /* Checks we used to perform. */
3199 /* if (EQ (obj, Qnull_pointer)) return 1; */
3200 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3201 /* if (PURIFIED (XPNTR (obj))) return 1; */
3203 if (XTYPE (obj) == Lisp_Type_Record)
3205 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3206 #if defined (ERROR_CHECK_GC)
3207 assert (lheader->type <= last_lrecord_type_index_assigned);
3209 return C_READONLY_RECORD_HEADER_P (lheader) || MARKED_RECORD_HEADER_P (lheader);
3217 /* Free all unmarked records. Do this at the very beginning,
3218 before anything else, so that the finalize methods can safely
3219 examine items in the objects. sweep_lcrecords_1() makes
3220 sure to call all the finalize methods *before* freeing anything,
3221 to complete the safety. */
3224 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3227 compact_string_chars ();
3229 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3230 macros) must be *extremely* careful to make sure they're not
3231 referencing freed objects. The only two existing finalize
3232 methods (for strings and markers) pass muster -- the string
3233 finalizer doesn't look at anything but its own specially-
3234 created block, and the marker finalizer only looks at live
3235 buffers (which will never be freed) and at the markers before
3236 and after it in the chain (which, by induction, will never be
3237 freed because if so, they would have already removed themselves
3240 /* Put all unmarked strings on free list, free'ing the string chars
3241 of large unmarked strings */
3244 /* Put all unmarked conses on free list */
3247 /* Free all unmarked bit vectors */
3248 sweep_bit_vectors_1 (&all_bit_vectors,
3249 &gc_count_num_bit_vector_used,
3250 &gc_count_bit_vector_total_size,
3251 &gc_count_bit_vector_storage);
3253 /* Free all unmarked compiled-function objects */
3254 sweep_compiled_functions ();
3256 #ifdef LISP_FLOAT_TYPE
3257 /* Put all unmarked floats on free list */
3261 /* Put all unmarked symbols on free list */
3264 /* Put all unmarked extents on free list */
3267 /* Put all unmarked markers on free list.
3268 Dechain each one first from the buffer into which it points. */
3274 /* Unmark all dumped objects */
3277 char *p = pdump_rt_list;
3281 pdump_reloc_table *rt = (pdump_reloc_table *)p;
3282 p += sizeof (pdump_reloc_table);
3285 for (i=0; i<rt->count; i++)
3287 UNMARK_RECORD_HEADER ((struct lrecord_header *)(*(EMACS_INT *)p));
3288 p += sizeof (EMACS_INT);
3297 /* Clearing for disksave. */
3300 disksave_object_finalization (void)
3302 /* It's important that certain information from the environment not get
3303 dumped with the executable (pathnames, environment variables, etc.).
3304 To make it easier to tell when this has happened with strings(1) we
3305 clear some known-to-be-garbage blocks of memory, so that leftover
3306 results of old evaluation don't look like potential problems.
3307 But first we set some notable variables to nil and do one more GC,
3308 to turn those strings into garbage.
3311 /* Yeah, this list is pretty ad-hoc... */
3312 Vprocess_environment = Qnil;
3313 Vexec_directory = Qnil;
3314 Vdata_directory = Qnil;
3315 Vsite_directory = Qnil;
3316 Vdoc_directory = Qnil;
3317 Vconfigure_info_directory = Qnil;
3320 /* Vdump_load_path = Qnil; */
3321 /* Release hash tables for locate_file */
3322 Flocate_file_clear_hashing (Qt);
3323 uncache_home_directory();
3325 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3326 defined(LOADHIST_BUILTIN))
3327 Vload_history = Qnil;
3329 Vshell_file_name = Qnil;
3331 garbage_collect_1 ();
3333 /* Run the disksave finalization methods of all live objects. */
3334 disksave_object_finalization_1 ();
3336 /* Zero out the uninitialized (really, unused) part of the containers
3337 for the live strings. */
3339 struct string_chars_block *scb;
3340 for (scb = first_string_chars_block; scb; scb = scb->next)
3342 int count = sizeof (scb->string_chars) - scb->pos;
3344 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3347 /* from the block's fill ptr to the end */
3348 memset ((scb->string_chars + scb->pos), 0, count);
3353 /* There, that ought to be enough... */
3359 restore_gc_inhibit (Lisp_Object val)
3361 gc_currently_forbidden = XINT (val);
3365 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3366 static int gc_hooks_inhibited;
3370 garbage_collect_1 (void)
3372 #if MAX_SAVE_STACK > 0
3373 char stack_top_variable;
3374 extern char *stack_bottom;
3379 Lisp_Object pre_gc_cursor;
3380 struct gcpro gcpro1;
3383 || gc_currently_forbidden
3385 || preparing_for_armageddon)
3388 /* We used to call selected_frame() here.
3390 The following functions cannot be called inside GC
3391 so we move to after the above tests. */
3394 Lisp_Object device = Fselected_device (Qnil);
3395 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3397 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3399 signal_simple_error ("No frames exist on device", device);
3403 pre_gc_cursor = Qnil;
3406 GCPRO1 (pre_gc_cursor);
3408 /* Very important to prevent GC during any of the following
3409 stuff that might run Lisp code; otherwise, we'll likely
3410 have infinite GC recursion. */
3411 speccount = specpdl_depth ();
3412 record_unwind_protect (restore_gc_inhibit,
3413 make_int (gc_currently_forbidden));
3414 gc_currently_forbidden = 1;
3416 if (!gc_hooks_inhibited)
3417 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3419 /* Now show the GC cursor/message. */
3420 if (!noninteractive)
3422 if (FRAME_WIN_P (f))
3424 Lisp_Object frame = make_frame (f);
3425 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3426 FRAME_SELECTED_WINDOW (f),
3428 pre_gc_cursor = f->pointer;
3429 if (POINTER_IMAGE_INSTANCEP (cursor)
3430 /* don't change if we don't know how to change back. */
3431 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3434 Fset_frame_pointer (frame, cursor);
3438 /* Don't print messages to the stream device. */
3439 if (!cursor_changed && !FRAME_STREAM_P (f))
3441 char *msg = (STRINGP (Vgc_message)
3442 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3444 Lisp_Object args[2], whole_msg;
3445 args[0] = build_string (msg ? msg :
3446 GETTEXT ((CONST char *) gc_default_message));
3447 args[1] = build_string ("...");
3448 whole_msg = Fconcat (2, args);
3449 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3450 Qgarbage_collecting);
3454 /***** Now we actually start the garbage collection. */
3458 gc_generation_number[0]++;
3460 #if MAX_SAVE_STACK > 0
3462 /* Save a copy of the contents of the stack, for debugging. */
3465 /* Static buffer in which we save a copy of the C stack at each GC. */
3466 static char *stack_copy;
3467 static size_t stack_copy_size;
3469 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3470 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3471 if (stack_size < MAX_SAVE_STACK)
3473 if (stack_copy_size < stack_size)
3475 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3476 stack_copy_size = stack_size;
3480 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3484 #endif /* MAX_SAVE_STACK > 0 */
3486 /* Do some totally ad-hoc resource clearing. */
3487 /* #### generalize this? */
3488 clear_event_resource ();
3489 cleanup_specifiers ();
3491 /* Mark all the special slots that serve as the roots of accessibility. */
3495 for (i = 0; i < staticidx; i++)
3496 mark_object (*(staticvec[i]));
3497 for (i = 0; i < staticidx_nodump; i++)
3498 mark_object (*(staticvec_nodump[i]));
3504 for (tail = gcprolist; tail; tail = tail->next)
3505 for (i = 0; i < tail->nvars; i++)
3506 mark_object (tail->var[i]);
3510 struct specbinding *bind;
3511 for (bind = specpdl; bind != specpdl_ptr; bind++)
3513 mark_object (bind->symbol);
3514 mark_object (bind->old_value);
3519 struct catchtag *catch;
3520 for (catch = catchlist; catch; catch = catch->next)
3522 mark_object (catch->tag);
3523 mark_object (catch->val);
3528 struct backtrace *backlist;
3529 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3531 int nargs = backlist->nargs;
3534 mark_object (*backlist->function);
3535 if (nargs == UNEVALLED || nargs == MANY)
3536 mark_object (backlist->args[0]);
3538 for (i = 0; i < nargs; i++)
3539 mark_object (backlist->args[i]);
3544 mark_profiling_info ();
3546 /* OK, now do the after-mark stuff. This is for things that
3547 are only marked when something else is marked (e.g. weak hash tables).
3548 There may be complex dependencies between such objects -- e.g.
3549 a weak hash table might be unmarked, but after processing a later
3550 weak hash table, the former one might get marked. So we have to
3551 iterate until nothing more gets marked. */
3553 while (finish_marking_weak_hash_tables () > 0 ||
3554 finish_marking_weak_lists () > 0)
3557 /* And prune (this needs to be called after everything else has been
3558 marked and before we do any sweeping). */
3559 /* #### this is somewhat ad-hoc and should probably be an object
3561 prune_weak_hash_tables ();
3562 prune_weak_lists ();
3563 prune_specifiers ();
3564 prune_syntax_tables ();
3568 consing_since_gc = 0;
3569 #ifndef DEBUG_XEMACS
3570 /* Allow you to set it really fucking low if you really want ... */
3571 if (gc_cons_threshold < 10000)
3572 gc_cons_threshold = 10000;
3577 /******* End of garbage collection ********/
3579 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3581 /* Now remove the GC cursor/message */
3582 if (!noninteractive)
3585 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3586 else if (!FRAME_STREAM_P (f))
3588 char *msg = (STRINGP (Vgc_message)
3589 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3592 /* Show "...done" only if the echo area would otherwise be empty. */
3593 if (NILP (clear_echo_area (selected_frame (),
3594 Qgarbage_collecting, 0)))
3596 Lisp_Object args[2], whole_msg;
3597 args[0] = build_string (msg ? msg :
3598 GETTEXT ((CONST char *)
3599 gc_default_message));
3600 args[1] = build_string ("... done");
3601 whole_msg = Fconcat (2, args);
3602 echo_area_message (selected_frame (), (Bufbyte *) 0,
3604 Qgarbage_collecting);
3609 /* now stop inhibiting GC */
3610 unbind_to (speccount, Qnil);
3612 if (!breathing_space)
3614 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3621 /* Debugging aids. */
3624 gc_plist_hack (CONST char *name, int value, Lisp_Object tail)
3626 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3627 or portable numeric datatypes, or bit-vectors, or characters, or
3628 arrays, or exceptions, or ...) */
3629 return cons3 (intern (name), make_int (value), tail);
3632 #define HACK_O_MATIC(type, name, pl) do { \
3634 struct type##_block *x = current_##type##_block; \
3635 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3636 (pl) = gc_plist_hack ((name), s, (pl)); \
3639 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3640 Reclaim storage for Lisp objects no longer needed.
3641 Return info on amount of space in use:
3642 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3643 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3645 where `PLIST' is a list of alternating keyword/value pairs providing
3646 more detailed information.
3647 Garbage collection happens automatically if you cons more than
3648 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3652 Lisp_Object pl = Qnil;
3654 int gc_count_vector_total_size = 0;
3656 garbage_collect_1 ();
3658 for (i = 0; i <= last_lrecord_type_index_assigned; i++)
3660 if (lcrecord_stats[i].bytes_in_use != 0
3661 || lcrecord_stats[i].bytes_freed != 0
3662 || lcrecord_stats[i].instances_on_free_list != 0)
3665 CONST char *name = lrecord_implementations_table[i]->name;
3666 int len = strlen (name);
3667 /* save this for the FSFmacs-compatible part of the summary */
3668 if (i == *lrecord_vector.lrecord_type_index)
3669 gc_count_vector_total_size =
3670 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3672 sprintf (buf, "%s-storage", name);
3673 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3674 /* Okay, simple pluralization check for `symbol-value-varalias' */
3675 if (name[len-1] == 's')
3676 sprintf (buf, "%ses-freed", name);
3678 sprintf (buf, "%ss-freed", name);
3679 if (lcrecord_stats[i].instances_freed != 0)
3680 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3681 if (name[len-1] == 's')
3682 sprintf (buf, "%ses-on-free-list", name);
3684 sprintf (buf, "%ss-on-free-list", name);
3685 if (lcrecord_stats[i].instances_on_free_list != 0)
3686 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3688 if (name[len-1] == 's')
3689 sprintf (buf, "%ses-used", name);
3691 sprintf (buf, "%ss-used", name);
3692 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3696 HACK_O_MATIC (extent, "extent-storage", pl);
3697 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3698 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3699 HACK_O_MATIC (event, "event-storage", pl);
3700 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3701 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3702 HACK_O_MATIC (marker, "marker-storage", pl);
3703 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3704 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3705 #ifdef LISP_FLOAT_TYPE
3706 HACK_O_MATIC (float, "float-storage", pl);
3707 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3708 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3709 #endif /* LISP_FLOAT_TYPE */
3710 HACK_O_MATIC (string, "string-header-storage", pl);
3711 pl = gc_plist_hack ("long-strings-total-length",
3712 gc_count_string_total_size
3713 - gc_count_short_string_total_size, pl);
3714 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3715 pl = gc_plist_hack ("short-strings-total-length",
3716 gc_count_short_string_total_size, pl);
3717 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3718 pl = gc_plist_hack ("long-strings-used",
3719 gc_count_num_string_in_use
3720 - gc_count_num_short_string_in_use, pl);
3721 pl = gc_plist_hack ("short-strings-used",
3722 gc_count_num_short_string_in_use, pl);
3724 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3725 pl = gc_plist_hack ("compiled-functions-free",
3726 gc_count_num_compiled_function_freelist, pl);
3727 pl = gc_plist_hack ("compiled-functions-used",
3728 gc_count_num_compiled_function_in_use, pl);
3730 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3731 pl = gc_plist_hack ("bit-vectors-total-length",
3732 gc_count_bit_vector_total_size, pl);
3733 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3735 HACK_O_MATIC (symbol, "symbol-storage", pl);
3736 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3737 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3739 HACK_O_MATIC (cons, "cons-storage", pl);
3740 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3741 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3743 /* The things we do for backwards-compatibility */
3745 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3746 make_int (gc_count_num_cons_freelist)),
3747 Fcons (make_int (gc_count_num_symbol_in_use),
3748 make_int (gc_count_num_symbol_freelist)),
3749 Fcons (make_int (gc_count_num_marker_in_use),
3750 make_int (gc_count_num_marker_freelist)),
3751 make_int (gc_count_string_total_size),
3752 make_int (gc_count_vector_total_size),
3757 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3758 Return the number of bytes consed since the last garbage collection.
3759 \"Consed\" is a misnomer in that this actually counts allocation
3760 of all different kinds of objects, not just conses.
3762 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3766 return make_int (consing_since_gc);
3770 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
3771 Return the address of the last byte Emacs has allocated, divided by 1024.
3772 This may be helpful in debugging Emacs's memory usage.
3773 The value is divided by 1024 to make sure it will fit in a lisp integer.
3777 return make_int ((EMACS_INT) sbrk (0) / 1024);
3783 object_dead_p (Lisp_Object obj)
3785 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3786 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3787 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3788 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3789 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3790 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3791 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3794 #ifdef MEMORY_USAGE_STATS
3796 /* Attempt to determine the actual amount of space that is used for
3797 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3799 It seems that the following holds:
3801 1. When using the old allocator (malloc.c):
3803 -- blocks are always allocated in chunks of powers of two. For
3804 each block, there is an overhead of 8 bytes if rcheck is not
3805 defined, 20 bytes if it is defined. In other words, a
3806 one-byte allocation needs 8 bytes of overhead for a total of
3807 9 bytes, and needs to have 16 bytes of memory chunked out for
3810 2. When using the new allocator (gmalloc.c):
3812 -- blocks are always allocated in chunks of powers of two up
3813 to 4096 bytes. Larger blocks are allocated in chunks of
3814 an integral multiple of 4096 bytes. The minimum block
3815 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3816 is defined. There is no per-block overhead, but there
3817 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3820 3. When using the system malloc, anything goes, but they are
3821 generally slower and more space-efficient than the GNU
3822 allocators. One possibly reasonable assumption to make
3823 for want of better data is that sizeof (void *), or maybe
3824 2 * sizeof (void *), is required as overhead and that
3825 blocks are allocated in the minimum required size except
3826 that some minimum block size is imposed (e.g. 16 bytes). */
3829 malloced_storage_size (void *ptr, size_t claimed_size,
3830 struct overhead_stats *stats)
3832 size_t orig_claimed_size = claimed_size;
3836 if (claimed_size < 2 * sizeof (void *))
3837 claimed_size = 2 * sizeof (void *);
3838 # ifdef SUNOS_LOCALTIME_BUG
3839 if (claimed_size < 16)
3842 if (claimed_size < 4096)
3846 /* compute the log base two, more or less, then use it to compute
3847 the block size needed. */
3849 /* It's big, it's heavy, it's wood! */
3850 while ((claimed_size /= 2) != 0)
3853 /* It's better than bad, it's good! */
3859 /* We have to come up with some average about the amount of
3861 if ((size_t) (rand () & 4095) < claimed_size)
3862 claimed_size += 3 * sizeof (void *);
3866 claimed_size += 4095;
3867 claimed_size &= ~4095;
3868 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3871 #elif defined (SYSTEM_MALLOC)
3873 if (claimed_size < 16)
3875 claimed_size += 2 * sizeof (void *);
3877 #else /* old GNU allocator */
3879 # ifdef rcheck /* #### may not be defined here */
3887 /* compute the log base two, more or less, then use it to compute
3888 the block size needed. */
3890 /* It's big, it's heavy, it's wood! */
3891 while ((claimed_size /= 2) != 0)
3894 /* It's better than bad, it's good! */
3902 #endif /* old GNU allocator */
3906 stats->was_requested += orig_claimed_size;
3907 stats->malloc_overhead += claimed_size - orig_claimed_size;
3909 return claimed_size;
3913 fixed_type_block_overhead (size_t size)
3915 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3916 size_t overhead = 0;
3917 size_t storage_size = malloced_storage_size (0, per_block, 0);
3918 while (size >= per_block)
3921 overhead += sizeof (void *) + per_block - storage_size;
3923 if (rand () % per_block < size)
3924 overhead += sizeof (void *) + per_block - storage_size;
3928 #endif /* MEMORY_USAGE_STATS */
3931 /* Initialization */
3933 reinit_alloc_once_early (void)
3935 gc_generation_number[0] = 0;
3936 breathing_space = 0;
3937 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3938 XSETINT (Vgc_message, 0);
3940 ignore_malloc_warnings = 1;
3941 #ifdef DOUG_LEA_MALLOC
3942 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3943 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3944 #if 0 /* Moved to emacs.c */
3945 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3948 init_string_alloc ();
3949 init_string_chars_alloc ();
3951 init_symbol_alloc ();
3952 init_compiled_function_alloc ();
3953 #ifdef LISP_FLOAT_TYPE
3954 init_float_alloc ();
3955 #endif /* LISP_FLOAT_TYPE */
3956 init_marker_alloc ();
3957 init_extent_alloc ();
3958 init_event_alloc ();
3960 ignore_malloc_warnings = 0;
3962 staticidx_nodump = 0;
3966 consing_since_gc = 0;
3968 gc_cons_threshold = 500000; /* XEmacs change */
3970 gc_cons_threshold = 15000; /* debugging */
3972 #ifdef VIRT_ADDR_VARIES
3973 malloc_sbrk_unused = 1<<22; /* A large number */
3974 malloc_sbrk_used = 100000; /* as reasonable as any number */
3975 #endif /* VIRT_ADDR_VARIES */
3976 lrecord_uid_counter = 259;
3977 debug_string_purity = 0;
3980 gc_currently_forbidden = 0;
3981 gc_hooks_inhibited = 0;
3983 #ifdef ERROR_CHECK_TYPECHECK
3984 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3987 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3989 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3991 #endif /* ERROR_CHECK_TYPECHECK */
3995 init_alloc_once_early (void)
3999 reinit_alloc_once_early ();
4001 last_lrecord_type_index_assigned = -1;
4002 for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
4004 lrecord_implementations_table[iii] = 0;
4009 * defined subr lrecords were initialized with lheader->type == 0.
4010 * See subr_lheader_initializer in lisp.h. Force type index 0 to be
4011 * assigned to lrecord_subr so that those predefined indexes match
4014 lrecord_type_index (&lrecord_subr);
4015 assert (*(lrecord_subr.lrecord_type_index) == 0);
4017 * The same is true for symbol_value_forward objects, except the
4020 lrecord_type_index (&lrecord_symbol_value_forward);
4021 assert (*(lrecord_symbol_value_forward.lrecord_type_index) == 1);
4026 int pure_bytes_used = 0;
4035 syms_of_alloc (void)
4037 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
4038 defsymbol (&Qpost_gc_hook, "post-gc-hook");
4039 defsymbol (&Qgarbage_collecting, "garbage-collecting");
4044 DEFSUBR (Fbit_vector);
4045 DEFSUBR (Fmake_byte_code);
4046 DEFSUBR (Fmake_list);
4047 DEFSUBR (Fmake_vector);
4048 DEFSUBR (Fmake_bit_vector);
4049 DEFSUBR (Fmake_string);
4051 DEFSUBR (Fmake_symbol);
4052 DEFSUBR (Fmake_marker);
4053 DEFSUBR (Fpurecopy);
4054 DEFSUBR (Fgarbage_collect);
4056 DEFSUBR (Fmemory_limit);
4058 DEFSUBR (Fconsing_since_gc);
4062 vars_of_alloc (void)
4064 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
4065 *Number of bytes of consing between garbage collections.
4066 \"Consing\" is a misnomer in that this actually counts allocation
4067 of all different kinds of objects, not just conses.
4068 Garbage collection can happen automatically once this many bytes have been
4069 allocated since the last garbage collection. All data types count.
4071 Garbage collection happens automatically when `eval' or `funcall' are
4072 called. (Note that `funcall' is called implicitly as part of evaluation.)
4073 By binding this temporarily to a large number, you can effectively
4074 prevent garbage collection during a part of the program.
4076 See also `consing-since-gc'.
4079 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
4080 Number of bytes of sharable Lisp data allocated so far.
4084 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
4085 Number of bytes of unshared memory allocated in this session.
4088 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
4089 Number of bytes of unshared memory remaining available in this session.
4094 DEFVAR_INT ("debug-allocation", &debug_allocation /*
4095 If non-zero, print out information to stderr about all objects allocated.
4096 See also `debug-allocation-backtrace-length'.
4098 debug_allocation = 0;
4100 DEFVAR_INT ("debug-allocation-backtrace-length",
4101 &debug_allocation_backtrace_length /*
4102 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4104 debug_allocation_backtrace_length = 2;
4107 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4108 Non-nil means loading Lisp code in order to dump an executable.
4109 This means that certain objects should be allocated in readonly space.
4112 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4113 Function or functions to be run just before each garbage collection.
4114 Interrupts, garbage collection, and errors are inhibited while this hook
4115 runs, so be extremely careful in what you add here. In particular, avoid
4116 consing, and do not interact with the user.
4118 Vpre_gc_hook = Qnil;
4120 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4121 Function or functions to be run just after each garbage collection.
4122 Interrupts, garbage collection, and errors are inhibited while this hook
4123 runs, so be extremely careful in what you add here. In particular, avoid
4124 consing, and do not interact with the user.
4126 Vpost_gc_hook = Qnil;
4128 DEFVAR_LISP ("gc-message", &Vgc_message /*
4129 String to print to indicate that a garbage collection is in progress.
4130 This is printed in the echo area. If the selected frame is on a
4131 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4132 image instance) in the domain of the selected frame, the mouse pointer
4133 will change instead of this message being printed.
4135 Vgc_message = build_string (gc_default_message);
4137 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4138 Pointer glyph used to indicate that a garbage collection is in progress.
4139 If the selected window is on a window system and this glyph specifies a
4140 value (i.e. a pointer image instance) in the domain of the selected
4141 window, the pointer will be changed as specified during garbage collection.
4142 Otherwise, a message will be printed in the echo area, as controlled
4148 complex_vars_of_alloc (void)
4150 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
4156 /* The structure of the file
4159 * 256 - dumped objects
4160 * stab_offset - nb_staticpro*(Lisp_Object *) from staticvec
4161 * - nb_staticpro*(relocated Lisp_Object) pointed to by staticpro
4162 * - nb_structdmp*pair(void *, adr) for pointers to structures
4163 * - lrecord_implementations_table[]
4164 * - relocation table
4165 * - wired variable address/value couples with the count preceding the list
4170 EMACS_UINT stab_offset;
4171 EMACS_UINT reloc_address;
4177 char *pdump_start, *pdump_end;
4179 static const unsigned char align_table[256] =
4181 8, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4182 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4183 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4184 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4185 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4186 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4187 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4188 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4189 7, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4190 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4191 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4192 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4193 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4194 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4195 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4196 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0
4199 typedef struct pdump_entry_list_elmt
4201 struct pdump_entry_list_elmt *next;
4206 EMACS_INT save_offset;
4207 } pdump_entry_list_elmt;
4211 pdump_entry_list_elmt *first;
4216 typedef struct pdump_struct_list_elmt
4218 pdump_entry_list list;
4219 const struct struct_description *sdesc;
4220 } pdump_struct_list_elmt;
4224 pdump_struct_list_elmt *list;
4227 } pdump_struct_list;
4229 static pdump_entry_list pdump_object_table[256];
4230 static pdump_entry_list pdump_opaque_data_list;
4231 static pdump_struct_list pdump_struct_table;
4232 static pdump_entry_list_elmt *pdump_qnil;
4234 static int pdump_alert_undump_object[256];
4236 static unsigned long cur_offset;
4237 static size_t max_size;
4238 static int pdump_fd;
4239 static void *pdump_buf;
4241 #define PDUMP_HASHSIZE 200001
4243 static pdump_entry_list_elmt **pdump_hash;
4245 /* Since most pointers are eight bytes aligned, the >>3 allows for a better hash */
4247 pdump_make_hash (const void *obj)
4249 return ((unsigned long)(obj)>>3) % PDUMP_HASHSIZE;
4252 static pdump_entry_list_elmt *
4253 pdump_get_entry (const void *obj)
4255 int pos = pdump_make_hash (obj);
4256 pdump_entry_list_elmt *e;
4260 while ((e = pdump_hash[pos]) != 0)
4266 if (pos == PDUMP_HASHSIZE)
4273 pdump_add_entry (pdump_entry_list *list, const void *obj, size_t size, int count, int is_lrecord)
4275 pdump_entry_list_elmt *e;
4277 int pos = pdump_make_hash (obj);
4279 while ((e = pdump_hash[pos]) != 0)
4285 if (pos == PDUMP_HASHSIZE)
4289 e = xnew (pdump_entry_list_elmt);
4291 e->next = list->first;
4295 e->is_lrecord = is_lrecord;
4298 list->count += count;
4299 pdump_hash[pos] = e;
4301 align = align_table[size & 255];
4302 if (align < 2 && is_lrecord)
4305 if (align < list->align)
4306 list->align = align;
4309 static pdump_entry_list *
4310 pdump_get_entry_list (const struct struct_description *sdesc)
4313 for (i=0; i<pdump_struct_table.count; i++)
4314 if (pdump_struct_table.list[i].sdesc == sdesc)
4315 return &pdump_struct_table.list[i].list;
4317 if (pdump_struct_table.size <= pdump_struct_table.count)
4319 if (pdump_struct_table.size == -1)
4320 pdump_struct_table.size = 10;
4322 pdump_struct_table.size = pdump_struct_table.size * 2;
4323 pdump_struct_table.list = (pdump_struct_list_elmt *)
4324 xrealloc (pdump_struct_table.list,
4325 pdump_struct_table.size * sizeof (pdump_struct_list_elmt));
4327 pdump_struct_table.list[pdump_struct_table.count].list.first = 0;
4328 pdump_struct_table.list[pdump_struct_table.count].list.align = 8;
4329 pdump_struct_table.list[pdump_struct_table.count].list.count = 0;
4330 pdump_struct_table.list[pdump_struct_table.count].sdesc = sdesc;
4332 return &pdump_struct_table.list[pdump_struct_table.count++].list;
4337 struct lrecord_header *obj;
4344 static void pdump_backtrace (void)
4347 fprintf (stderr, "pdump backtrace :\n");
4348 for (i=0;i<depth;i++)
4350 if (!backtrace[i].obj)
4351 fprintf (stderr, " - ind. (%d, %d)\n", backtrace[i].position, backtrace[i].offset);
4354 fprintf (stderr, " - %s (%d, %d)\n",
4355 LHEADER_IMPLEMENTATION (backtrace[i].obj)->name,
4356 backtrace[i].position,
4357 backtrace[i].offset);
4362 static void pdump_register_object (Lisp_Object obj);
4363 static void pdump_register_struct (const void *data, const struct struct_description *sdesc, int count);
4366 pdump_get_indirect_count (EMACS_INT code, const struct lrecord_description *idesc, const void *idata)
4371 int line = XD_INDIRECT_VAL (code);
4372 int delta = XD_INDIRECT_DELTA (code);
4374 irdata = ((char *)idata) + idesc[line].offset;
4375 switch (idesc[line].type)
4378 count = *(size_t *)irdata;
4381 count = *(int *)irdata;
4384 count = *(long *)irdata;
4387 count = *(Bytecount *)irdata;
4390 fprintf (stderr, "Unsupported count type : %d (line = %d, code=%ld)\n", idesc[line].type, line, (long)code);
4399 pdump_register_sub (const void *data, const struct lrecord_description *desc, int me)
4404 for (pos = 0; desc[pos].type != XD_END; pos++)
4406 const void *rdata = (const char *)data + desc[pos].offset;
4408 backtrace[me].position = pos;
4409 backtrace[me].offset = desc[pos].offset;
4411 switch (desc[pos].type)
4413 case XD_SPECIFIER_END:
4415 desc = ((const Lisp_Specifier *)data)->methods->extra_description;
4421 case XD_LO_RESET_NIL:
4425 case XD_OPAQUE_DATA_PTR:
4427 EMACS_INT count = desc[pos].data1;
4428 if (XD_IS_INDIRECT (count))
4429 count = pdump_get_indirect_count (count, desc, data);
4431 pdump_add_entry (&pdump_opaque_data_list,
4440 const char *str = *(const char **)rdata;
4442 pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
4447 const char *str = *(const char **)rdata;
4448 if ((EMACS_INT)str > 0)
4449 pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
4452 case XD_LISP_OBJECT:
4454 const Lisp_Object *pobj = (const Lisp_Object *)rdata;
4456 assert (desc[pos].data1 == 0);
4458 backtrace[me].offset = (const char *)pobj - (const char *)data;
4459 pdump_register_object (*pobj);
4462 case XD_LISP_OBJECT_ARRAY:
4465 EMACS_INT count = desc[pos].data1;
4466 if (XD_IS_INDIRECT (count))
4467 count = pdump_get_indirect_count (count, desc, data);
4469 for (i = 0; i < count; i++)
4471 const Lisp_Object *pobj = ((const Lisp_Object *)rdata) + i;
4472 Lisp_Object dobj = *pobj;
4474 backtrace[me].offset = (const char *)pobj - (const char *)data;
4475 pdump_register_object (dobj);
4481 EMACS_INT count = desc[pos].data1;
4482 const struct struct_description *sdesc = desc[pos].data2;
4483 const char *dobj = *(const char **)rdata;
4486 if (XD_IS_INDIRECT (count))
4487 count = pdump_get_indirect_count (count, desc, data);
4489 pdump_register_struct (dobj, sdesc, count);
4494 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4502 pdump_register_object (Lisp_Object obj)
4504 struct lrecord_header *objh;
4506 if (!POINTER_TYPE_P (XTYPE (obj)))
4509 objh = XRECORD_LHEADER (obj);
4513 if (pdump_get_entry (objh))
4516 if (LHEADER_IMPLEMENTATION (objh)->description)
4521 fprintf (stderr, "Backtrace overflow, loop ?\n");
4524 backtrace[me].obj = objh;
4525 backtrace[me].position = 0;
4526 backtrace[me].offset = 0;
4528 pdump_add_entry (pdump_object_table + objh->type,
4530 LHEADER_IMPLEMENTATION (objh)->static_size ?
4531 LHEADER_IMPLEMENTATION (objh)->static_size :
4532 LHEADER_IMPLEMENTATION (objh)->size_in_bytes_method (objh),
4535 pdump_register_sub (objh,
4536 LHEADER_IMPLEMENTATION (objh)->description,
4542 pdump_alert_undump_object[objh->type]++;
4543 fprintf (stderr, "Undumpable object type : %s\n", LHEADER_IMPLEMENTATION (objh)->name);
4549 pdump_register_struct (const void *data, const struct struct_description *sdesc, int count)
4551 if (data && !pdump_get_entry (data))
4557 fprintf (stderr, "Backtrace overflow, loop ?\n");
4560 backtrace[me].obj = 0;
4561 backtrace[me].position = 0;
4562 backtrace[me].offset = 0;
4564 pdump_add_entry (pdump_get_entry_list (sdesc),
4569 for (i=0; i<count; i++)
4571 pdump_register_sub (((char *)data) + sdesc->size*i,
4580 pdump_dump_data (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
4582 size_t size = elmt->size;
4583 int count = elmt->count;
4587 memcpy (pdump_buf, elmt->obj, size*count);
4589 for (i=0; i<count; i++)
4591 char *cur = ((char *)pdump_buf) + i*size;
4593 for (pos = 0; desc[pos].type != XD_END; pos++)
4595 void *rdata = cur + desc[pos].offset;
4596 switch (desc[pos].type)
4598 case XD_SPECIFIER_END:
4599 desc = ((const Lisp_Specifier *)(elmt->obj))->methods->extra_description;
4606 case XD_LO_RESET_NIL:
4608 EMACS_INT count = desc[pos].data1;
4610 if (XD_IS_INDIRECT (count))
4611 count = pdump_get_indirect_count (count, desc, elmt->obj);
4612 for (i=0; i<count; i++)
4613 ((EMACS_INT *)rdata)[i] = pdump_qnil->save_offset;
4618 EMACS_INT val = desc[pos].data1;
4619 if (XD_IS_INDIRECT (val))
4620 val = pdump_get_indirect_count (val, desc, elmt->obj);
4621 *(int *)rdata = val;
4624 case XD_OPAQUE_DATA_PTR:
4628 void *ptr = *(void **)rdata;
4630 *(EMACS_INT *)rdata = pdump_get_entry (ptr)->save_offset;
4635 Lisp_Object obj = *(Lisp_Object *)rdata;
4636 pdump_entry_list_elmt *elmt1;
4639 elmt1 = pdump_get_entry (XRECORD_LHEADER (obj));
4642 obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
4644 *(EMACS_INT *)rdata = elmt1->save_offset;
4647 case XD_LISP_OBJECT:
4649 Lisp_Object *pobj = (Lisp_Object *) rdata;
4651 assert (desc[pos].data1 == 0);
4653 if (POINTER_TYPE_P (XTYPE (*pobj)) && XRECORD_LHEADER (*pobj))
4654 *(EMACS_INT *)pobj =
4655 pdump_get_entry (XRECORD_LHEADER (*pobj))->save_offset;
4658 case XD_LISP_OBJECT_ARRAY:
4660 EMACS_INT count = desc[pos].data1;
4662 if (XD_IS_INDIRECT (count))
4663 count = pdump_get_indirect_count (count, desc, elmt->obj);
4665 for (i=0; i<count; i++)
4667 Lisp_Object *pobj = ((Lisp_Object *)rdata) + i;
4668 if (POINTER_TYPE_P (XTYPE (*pobj)) && XRECORD_LHEADER (*pobj))
4669 *(EMACS_INT *)pobj =
4670 pdump_get_entry (XRECORD_LHEADER (*pobj))->save_offset;
4676 EMACS_INT str = *(EMACS_INT *)rdata;
4678 *(EMACS_INT *)rdata = pdump_get_entry ((void *)str)->save_offset;
4682 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4688 write (pdump_fd, desc ? pdump_buf : elmt->obj, size*count);
4689 if (elmt->is_lrecord && ((size*count) & 3))
4690 write (pdump_fd, "\0\0\0", 4-((size*count) & 3));
4694 pdump_reloc_one (void *data, EMACS_INT delta, const struct lrecord_description *desc)
4699 for (pos = 0; desc[pos].type != XD_END; pos++)
4701 void *rdata = (char *)data + desc[pos].offset;
4702 switch (desc[pos].type)
4704 case XD_SPECIFIER_END:
4706 desc = ((const Lisp_Specifier *)data)->methods->extra_description;
4714 case XD_OPAQUE_DATA_PTR:
4719 EMACS_INT ptr = *(EMACS_INT *)rdata;
4721 *(EMACS_INT *)rdata = ptr+delta;
4724 case XD_LISP_OBJECT:
4726 Lisp_Object *pobj = (Lisp_Object *) rdata;
4728 assert (desc[pos].data1 == 0);
4730 if (POINTER_TYPE_P (XTYPE (*pobj))
4731 && ! EQ (*pobj, Qnull_pointer))
4732 XSETOBJ (*pobj, XTYPE (*pobj), (char *) XPNTR (*pobj) + delta);
4736 case XD_LISP_OBJECT_ARRAY:
4737 case XD_LO_RESET_NIL:
4739 EMACS_INT count = desc[pos].data1;
4741 if (XD_IS_INDIRECT (count))
4742 count = pdump_get_indirect_count (count, desc, data);
4744 for (i=0; i<count; i++)
4746 Lisp_Object *pobj = (Lisp_Object *) rdata + i;
4748 if (POINTER_TYPE_P (XTYPE (*pobj))
4749 && ! EQ (*pobj, Qnull_pointer))
4750 XSETOBJ (*pobj, XTYPE (*pobj), (char *) XPNTR (*pobj) + delta);
4756 EMACS_INT str = *(EMACS_INT *)rdata;
4758 *(EMACS_INT *)rdata = str + delta;
4762 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4769 pdump_allocate_offset (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
4771 size_t size = (elmt->is_lrecord ? (elmt->size + 3) & ~3 : elmt->size)*elmt->count;
4772 elmt->save_offset = cur_offset;
4779 pdump_scan_by_alignment (void (*f)(pdump_entry_list_elmt *, const struct lrecord_description *))
4782 const struct lrecord_description *idesc;
4783 pdump_entry_list_elmt *elmt;
4784 for (align=8; align>=0; align--)
4786 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4787 if (pdump_object_table[i].align == align)
4789 elmt = pdump_object_table[i].first;
4792 idesc = lrecord_implementations_table[i]->description;
4800 for (i=0; i<pdump_struct_table.count; i++)
4801 if (pdump_struct_table.list[i].list.align == align)
4803 elmt = pdump_struct_table.list[i].list.first;
4804 idesc = pdump_struct_table.list[i].sdesc->description;
4812 elmt = pdump_opaque_data_list.first;
4815 if (align_table[elmt->size & 255] == align)
4823 pdump_dump_staticvec (void)
4825 EMACS_INT *reloc = xnew_array (EMACS_INT, staticidx);
4827 write (pdump_fd, staticvec, staticidx*sizeof (Lisp_Object *));
4829 for (i=0; i<staticidx; i++)
4831 Lisp_Object obj = *staticvec[i];
4832 if (POINTER_TYPE_P (XTYPE (obj)))
4833 reloc[i] = pdump_get_entry (XRECORD_LHEADER (obj))->save_offset;
4835 reloc[i] = *(EMACS_INT *)(staticvec[i]);
4837 write (pdump_fd, reloc, staticidx*sizeof (Lisp_Object));
4842 pdump_dump_structvec (void)
4845 for (i=0; i<dumpstructidx; i++)
4848 write (pdump_fd, &(dumpstructvec[i].data), sizeof (void *));
4849 adr = pdump_get_entry (*(void **)(dumpstructvec[i].data))->save_offset;
4850 write (pdump_fd, &adr, sizeof (adr));
4855 pdump_dump_itable (void)
4857 write (pdump_fd, lrecord_implementations_table, sizeof (lrecord_implementations_table));
4861 pdump_dump_rtables (void)
4864 pdump_entry_list_elmt *elmt;
4865 pdump_reloc_table rt;
4867 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4869 elmt = pdump_object_table[i].first;
4872 rt.desc = lrecord_implementations_table[i]->description;
4873 rt.count = pdump_object_table[i].count;
4874 write (pdump_fd, &rt, sizeof (rt));
4877 EMACS_INT rdata = pdump_get_entry (elmt->obj)->save_offset;
4878 write (pdump_fd, &rdata, sizeof (rdata));
4885 write (pdump_fd, &rt, sizeof (rt));
4887 for (i=0; i<pdump_struct_table.count; i++)
4889 elmt = pdump_struct_table.list[i].list.first;
4890 rt.desc = pdump_struct_table.list[i].sdesc->description;
4891 rt.count = pdump_struct_table.list[i].list.count;
4892 write (pdump_fd, &rt, sizeof (rt));
4895 EMACS_INT rdata = pdump_get_entry (elmt->obj)->save_offset;
4896 for (j=0; j<elmt->count; j++)
4898 write (pdump_fd, &rdata, sizeof (rdata));
4899 rdata += elmt->size;
4906 write (pdump_fd, &rt, sizeof (rt));
4910 pdump_dump_wired (void)
4912 EMACS_INT count = pdump_wireidx + pdump_wireidx_list;
4915 write (pdump_fd, &count, sizeof (count));
4917 for (i=0; i<pdump_wireidx; i++)
4919 EMACS_INT obj = pdump_get_entry (XRECORD_LHEADER (*(pdump_wirevec[i])))->save_offset;
4920 write (pdump_fd, &pdump_wirevec[i], sizeof (pdump_wirevec[i]));
4921 write (pdump_fd, &obj, sizeof (obj));
4924 for (i=0; i<pdump_wireidx_list; i++)
4926 Lisp_Object obj = *(pdump_wirevec_list[i]);
4927 pdump_entry_list_elmt *elmt;
4932 const struct lrecord_description *desc;
4934 elmt = pdump_get_entry (XRECORD_LHEADER (obj));
4937 desc = XRECORD_LHEADER_IMPLEMENTATION (obj)->description;
4938 for (pos = 0; desc[pos].type != XD_LO_LINK; pos++)
4939 if (desc[pos].type == XD_END)
4942 obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
4944 res = elmt->save_offset;
4946 write (pdump_fd, &pdump_wirevec_list[i], sizeof (pdump_wirevec_list[i]));
4947 write (pdump_fd, &res, sizeof (res));
4955 Lisp_Object t_console, t_device, t_frame;
4959 /* These appear in a DEFVAR_LISP, which does a staticpro() */
4960 t_console = Vterminal_console;
4961 t_frame = Vterminal_frame;
4962 t_device = Vterminal_device;
4964 Vterminal_console = Qnil;
4965 Vterminal_frame = Qnil;
4966 Vterminal_device = Qnil;
4968 pdump_hash = xnew_array_and_zero (pdump_entry_list_elmt *, PDUMP_HASHSIZE);
4970 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4972 pdump_object_table[i].first = 0;
4973 pdump_object_table[i].align = 8;
4974 pdump_object_table[i].count = 0;
4975 pdump_alert_undump_object[i] = 0;
4977 pdump_struct_table.count = 0;
4978 pdump_struct_table.size = -1;
4980 pdump_opaque_data_list.first = 0;
4981 pdump_opaque_data_list.align = 8;
4982 pdump_opaque_data_list.count = 0;
4985 for (i=0; i<staticidx; i++)
4986 pdump_register_object (*staticvec[i]);
4987 for (i=0; i<pdump_wireidx; i++)
4988 pdump_register_object (*pdump_wirevec[i]);
4991 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4992 if (pdump_alert_undump_object[i])
4995 printf ("Undumpable types list :\n");
4997 printf (" - %s (%d)\n", lrecord_implementations_table[i]->name, pdump_alert_undump_object[i]);
5002 for (i=0; i<dumpstructidx; i++)
5003 pdump_register_struct (*(void **)(dumpstructvec[i].data), dumpstructvec[i].desc, 1);
5005 memcpy (hd.signature, "XEmacsDP", 8);
5006 hd.reloc_address = 0;
5007 hd.nb_staticpro = staticidx;
5008 hd.nb_structdmp = dumpstructidx;
5009 hd.last_type = last_lrecord_type_index_assigned;
5014 pdump_scan_by_alignment (pdump_allocate_offset);
5015 pdump_qnil = pdump_get_entry (XRECORD_LHEADER (Qnil));
5017 pdump_buf = xmalloc (max_size);
5018 /* Avoid use of the `open' macro. We want the real function. */
5020 pdump_fd = open ("xemacs.dmp",
5021 O_WRONLY | O_CREAT | O_TRUNC | OPEN_BINARY, 0666);
5022 hd.stab_offset = (cur_offset + 3) & ~3;
5024 write (pdump_fd, &hd, sizeof (hd));
5025 lseek (pdump_fd, 256, SEEK_SET);
5027 pdump_scan_by_alignment (pdump_dump_data);
5029 lseek (pdump_fd, hd.stab_offset, SEEK_SET);
5031 pdump_dump_staticvec ();
5032 pdump_dump_structvec ();
5033 pdump_dump_itable ();
5034 pdump_dump_rtables ();
5035 pdump_dump_wired ();
5042 Vterminal_console = t_console;
5043 Vterminal_frame = t_frame;
5044 Vterminal_device = t_device;
5056 #define PDUMP_READ(p, type) (p = (char*) (((type *) p) + 1), *((type *) p - 1))
5058 pdump_start = pdump_end = 0;
5060 pdump_fd = open ("xemacs.dmp", O_RDONLY | OPEN_BINARY);
5064 length = lseek (pdump_fd, 0, SEEK_END);
5065 lseek (pdump_fd, 0, SEEK_SET);
5068 pdump_start = (char *) mmap (0, length, PROT_READ|PROT_WRITE, MAP_PRIVATE, pdump_fd, 0);
5069 if (pdump_start == MAP_FAILED)
5075 pdump_start = (char *)((((unsigned long)(xmalloc(length+255))) + 255) & ~255);
5076 read (pdump_fd, pdump_start, length);
5081 pdump_end = pdump_start + length;
5083 staticidx = ((dump_header *)(pdump_start))->nb_staticpro;
5084 last_lrecord_type_index_assigned = ((dump_header *)pdump_start)->last_type;
5085 delta = ((EMACS_INT)pdump_start) - ((dump_header *)pdump_start)->reloc_address;
5086 p = pdump_start + ((dump_header *)pdump_start)->stab_offset;
5088 /* Put back the staticvec in place */
5089 memcpy (staticvec, p, staticidx*sizeof (Lisp_Object *));
5090 p += staticidx*sizeof (Lisp_Object *);
5091 for (i=0; i<staticidx; i++)
5093 Lisp_Object obj = PDUMP_READ (p, Lisp_Object);
5094 if (POINTER_TYPE_P (XTYPE (obj)))
5095 XSETOBJ (obj, XTYPE (obj), (char *) XPNTR (obj) + delta);
5096 *staticvec[i] = obj;
5099 /* Put back the dumpstructs */
5100 for (i=0; i<((dump_header *)pdump_start)->nb_structdmp; i++)
5102 void **adr = PDUMP_READ (p, void **);
5103 *adr = (void *) (PDUMP_READ (p, char *) + delta);
5106 /* Put back the lrecord_implementations_table */
5107 memcpy (lrecord_implementations_table, p, sizeof (lrecord_implementations_table));
5108 p += sizeof (lrecord_implementations_table);
5110 /* Give back their numbers to the lrecord implementations */
5111 for (i = 0; i < countof (lrecord_implementations_table); i++)
5112 if (lrecord_implementations_table[i])
5114 *(lrecord_implementations_table[i]->lrecord_type_index) = i;
5115 last_lrecord_type_index_assigned = i;
5118 /* Do the relocations */
5123 pdump_reloc_table rt = PDUMP_READ (p, pdump_reloc_table);
5126 for (i=0; i < rt.count; i++)
5128 char *adr = delta + *(char **)p;
5130 pdump_reloc_one (adr, delta, rt.desc);
5131 p += sizeof (char *);
5138 /* Put the pdump_wire variables in place */
5139 count = PDUMP_READ (p, EMACS_INT);
5141 for (i=0; i<count; i++)
5143 Lisp_Object *var = PDUMP_READ (p, Lisp_Object *);
5144 Lisp_Object obj = PDUMP_READ (p, Lisp_Object);
5146 if (POINTER_TYPE_P (XTYPE (obj)))
5147 XSETOBJ (obj, XTYPE (obj), (char *) XPNTR (obj) + delta);
5152 /* Final cleanups */
5153 /* reorganize hash tables */
5157 pdump_reloc_table rt = PDUMP_READ (p, pdump_reloc_table);
5160 if (rt.desc == hash_table_description)
5162 for (i=0; i < rt.count; i++)
5163 pdump_reorganize_hash_table (PDUMP_READ (p, Lisp_Object));
5166 p += sizeof (Lisp_Object) * rt.count;