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. */
278 xmalloc (size_t size)
280 void *val = malloc (size);
282 if (!val && (size != 0)) memory_full ();
291 xcalloc (size_t nelem, size_t elsize)
293 void *val = calloc (nelem, elsize);
295 if (!val && (nelem != 0)) memory_full ();
300 xmalloc_and_zero (size_t size)
302 return xcalloc (size, sizeof (char));
310 xrealloc (void *block, size_t size)
312 /* We must call malloc explicitly when BLOCK is 0, since some
313 reallocs don't do this. */
314 void *val = block ? realloc (block, size) : malloc (size);
316 if (!val && (size != 0)) memory_full ();
321 #ifdef ERROR_CHECK_MALLOC
322 xfree_1 (void *block)
327 #ifdef ERROR_CHECK_MALLOC
328 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
329 error until much later on for many system mallocs, such as
330 the one that comes with Solaris 2.3. FMH!! */
331 assert (block != (void *) 0xDEADBEEF);
333 #endif /* ERROR_CHECK_MALLOC */
337 #ifdef ERROR_CHECK_GC
340 typedef unsigned int four_byte_t;
341 #elif SIZEOF_LONG == 4
342 typedef unsigned long four_byte_t;
343 #elif SIZEOF_SHORT == 4
344 typedef unsigned short four_byte_t;
346 What kind of strange-ass system are we running on?
350 deadbeef_memory (void *ptr, size_t size)
352 four_byte_t *ptr4 = (four_byte_t *) ptr;
353 size_t beefs = size >> 2;
355 /* In practice, size will always be a multiple of four. */
357 (*ptr4++) = 0xDEADBEEF;
360 #else /* !ERROR_CHECK_GC */
363 #define deadbeef_memory(ptr, size)
365 #endif /* !ERROR_CHECK_GC */
372 xstrdup (CONST char *str)
374 int len = strlen (str) + 1; /* for stupid terminating 0 */
376 void *val = xmalloc (len);
377 if (val == 0) return 0;
378 return (char *) memcpy (val, str, len);
383 strdup (CONST char *s)
387 #endif /* NEED_STRDUP */
391 allocate_lisp_storage (size_t size)
393 return xmalloc (size);
397 /* lrecords are chained together through their "next.v" field.
398 * After doing the mark phase, the GC will walk this linked
399 * list and free any record which hasn't been marked.
401 static struct lcrecord_header *all_lcrecords;
404 alloc_lcrecord (size_t size, CONST struct lrecord_implementation *implementation)
406 struct lcrecord_header *lcheader;
408 #ifdef ERROR_CHECK_GC
409 if (implementation->static_size == 0)
410 assert (implementation->size_in_bytes_method);
412 assert (implementation->static_size == size);
415 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
416 set_lheader_implementation (&(lcheader->lheader), implementation);
417 lcheader->next = all_lcrecords;
418 #if 1 /* mly prefers to see small ID numbers */
419 lcheader->uid = lrecord_uid_counter++;
420 #else /* jwz prefers to see real addrs */
421 lcheader->uid = (int) &lcheader;
424 all_lcrecords = lcheader;
425 INCREMENT_CONS_COUNTER (size, implementation->name);
429 #if 0 /* Presently unused */
430 /* Very, very poor man's EGC?
431 * This may be slow and thrash pages all over the place.
432 * Only call it if you really feel you must (and if the
433 * lrecord was fairly recently allocated).
434 * Otherwise, just let the GC do its job -- that's what it's there for
437 free_lcrecord (struct lcrecord_header *lcrecord)
439 if (all_lcrecords == lcrecord)
441 all_lcrecords = lcrecord->next;
445 struct lrecord_header *header = all_lcrecords;
448 struct lrecord_header *next = header->next;
449 if (next == lcrecord)
451 header->next = lrecord->next;
460 if (lrecord->implementation->finalizer)
461 lrecord->implementation->finalizer (lrecord, 0);
469 disksave_object_finalization_1 (void)
471 struct lcrecord_header *header;
473 for (header = all_lcrecords; header; header = header->next)
475 if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
477 ((LHEADER_IMPLEMENTATION(&header->lheader)->finalizer)
482 /* Semi-kludge -- lrecord_symbol_value_forward objects get stuck
483 in CONST space and you get SEGV's if you attempt to mark them.
484 This sits in lheader->implementation->marker. */
487 this_one_is_unmarkable (Lisp_Object obj)
494 /************************************************************************/
495 /* Debugger support */
496 /************************************************************************/
497 /* Give gdb/dbx enough information to decode Lisp Objects. We make
498 sure certain symbols are always defined, so gdb doesn't complain
499 about expressions in src/gdbinit. See src/gdbinit or src/dbxrc to
500 see how this is used. */
502 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
503 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
505 #ifdef USE_UNION_TYPE
506 unsigned char dbg_USE_UNION_TYPE = 1;
508 unsigned char dbg_USE_UNION_TYPE = 0;
511 unsigned char Lisp_Type_Int = 100;
512 unsigned char Lisp_Type_Cons = 101;
513 unsigned char Lisp_Type_String = 102;
514 unsigned char Lisp_Type_Vector = 103;
515 unsigned char Lisp_Type_Symbol = 104;
518 unsigned char lrecord_char_table_entry;
519 unsigned char lrecord_charset;
521 unsigned char lrecord_coding_system;
525 #ifndef HAVE_TOOLBARS
526 unsigned char lrecord_toolbar_button;
530 unsigned char lrecord_tooltalk_message;
531 unsigned char lrecord_tooltalk_pattern;
534 #ifndef HAVE_DATABASE
535 unsigned char lrecord_database;
538 unsigned char dbg_valbits = VALBITS;
539 unsigned char dbg_gctypebits = GCTYPEBITS;
541 /* Macros turned into functions for ease of debugging.
542 Debuggers don't know about macros! */
543 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
545 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
547 return EQ (obj1, obj2);
551 /************************************************************************/
552 /* Fixed-size type macros */
553 /************************************************************************/
555 /* For fixed-size types that are commonly used, we malloc() large blocks
556 of memory at a time and subdivide them into chunks of the correct
557 size for an object of that type. This is more efficient than
558 malloc()ing each object separately because we save on malloc() time
559 and overhead due to the fewer number of malloc()ed blocks, and
560 also because we don't need any extra pointers within each object
561 to keep them threaded together for GC purposes. For less common
562 (and frequently large-size) types, we use lcrecords, which are
563 malloc()ed individually and chained together through a pointer
564 in the lcrecord header. lcrecords do not need to be fixed-size
565 (i.e. two objects of the same type need not have the same size;
566 however, the size of a particular object cannot vary dynamically).
567 It is also much easier to create a new lcrecord type because no
568 additional code needs to be added to alloc.c. Finally, lcrecords
569 may be more efficient when there are only a small number of them.
571 The types that are stored in these large blocks (or "frob blocks")
572 are cons, float, compiled-function, symbol, marker, extent, event,
575 Note that strings are special in that they are actually stored in
576 two parts: a structure containing information about the string, and
577 the actual data associated with the string. The former structure
578 (a struct Lisp_String) is a fixed-size structure and is managed the
579 same way as all the other such types. This structure contains a
580 pointer to the actual string data, which is stored in structures of
581 type struct string_chars_block. Each string_chars_block consists
582 of a pointer to a struct Lisp_String, followed by the data for that
583 string, followed by another pointer to a struct Lisp_String,
584 followed by the data for that string, etc. At GC time, the data in
585 these blocks is compacted by searching sequentially through all the
586 blocks and compressing out any holes created by unmarked strings.
587 Strings that are more than a certain size (bigger than the size of
588 a string_chars_block, although something like half as big might
589 make more sense) are malloc()ed separately and not stored in
590 string_chars_blocks. Furthermore, no one string stretches across
591 two string_chars_blocks.
593 Vectors are each malloc()ed separately, similar to lcrecords.
595 In the following discussion, we use conses, but it applies equally
596 well to the other fixed-size types.
598 We store cons cells inside of cons_blocks, allocating a new
599 cons_block with malloc() whenever necessary. Cons cells reclaimed
600 by GC are put on a free list to be reallocated before allocating
601 any new cons cells from the latest cons_block. Each cons_block is
602 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
603 the versions in malloc.c and gmalloc.c) really allocates in units
604 of powers of two and uses 4 bytes for its own overhead.
606 What GC actually does is to search through all the cons_blocks,
607 from the most recently allocated to the oldest, and put all
608 cons cells that are not marked (whether or not they're already
609 free) on a cons_free_list. The cons_free_list is a stack, and
610 so the cons cells in the oldest-allocated cons_block end up
611 at the head of the stack and are the first to be reallocated.
612 If any cons_block is entirely free, it is freed with free()
613 and its cons cells removed from the cons_free_list. Because
614 the cons_free_list ends up basically in memory order, we have
615 a high locality of reference (assuming a reasonable turnover
616 of allocating and freeing) and have a reasonable probability
617 of entirely freeing up cons_blocks that have been more recently
618 allocated. This stage is called the "sweep stage" of GC, and
619 is executed after the "mark stage", which involves starting
620 from all places that are known to point to in-use Lisp objects
621 (e.g. the obarray, where are all symbols are stored; the
622 current catches and condition-cases; the backtrace list of
623 currently executing functions; the gcpro list; etc.) and
624 recursively marking all objects that are accessible.
626 At the beginning of the sweep stage, the conses in the cons
627 blocks are in one of three states: in use and marked, in use
628 but not marked, and not in use (already freed). Any conses
629 that are marked have been marked in the mark stage just
630 executed, because as part of the sweep stage we unmark any
631 marked objects. The way we tell whether or not a cons cell
632 is in use is through the FREE_STRUCT_P macro. This basically
633 looks at the first 4 bytes (or however many bytes a pointer
634 fits in) to see if all the bits in those bytes are 1. The
635 resulting value (0xFFFFFFFF) is not a valid pointer and is
636 not a valid Lisp_Object. All current fixed-size types have
637 a pointer or Lisp_Object as their first element with the
638 exception of strings; they have a size value, which can
639 never be less than zero, and so 0xFFFFFFFF is invalid for
640 strings as well. Now assuming that a cons cell is in use,
641 the way we tell whether or not it is marked is to look at
642 the mark bit of its car (each Lisp_Object has one bit
643 reserved as a mark bit, in case it's needed). Note that
644 different types of objects use different fields to indicate
645 whether the object is marked, but the principle is the same.
647 Conses on the free_cons_list are threaded through a pointer
648 stored in the bytes directly after the bytes that are set
649 to 0xFFFFFFFF (we cannot overwrite these because the cons
650 is still in a cons_block and needs to remain marked as
651 not in use for the next time that GC happens). This
652 implies that all fixed-size types must be at least big
653 enough to store two pointers, which is indeed the case
654 for all current fixed-size types.
656 Some types of objects need additional "finalization" done
657 when an object is converted from in use to not in use;
658 this is the purpose of the ADDITIONAL_FREE_type macro.
659 For example, markers need to be removed from the chain
660 of markers that is kept in each buffer. This is because
661 markers in a buffer automatically disappear if the marker
662 is no longer referenced anywhere (the same does not
663 apply to extents, however).
665 WARNING: Things are in an extremely bizarre state when
666 the ADDITIONAL_FREE_type macros are called, so beware!
668 When ERROR_CHECK_GC is defined, we do things differently
669 so as to maximize our chances of catching places where
670 there is insufficient GCPROing. The thing we want to
671 avoid is having an object that we're using but didn't
672 GCPRO get freed by GC and then reallocated while we're
673 in the process of using it -- this will result in something
674 seemingly unrelated getting trashed, and is extremely
675 difficult to track down. If the object gets freed but
676 not reallocated, we can usually catch this because we
677 set all bytes of a freed object to 0xDEADBEEF. (The
678 first four bytes, however, are 0xFFFFFFFF, and the next
679 four are a pointer used to chain freed objects together;
680 we play some tricks with this pointer to make it more
681 bogus, so crashes are more likely to occur right away.)
683 We want freed objects to stay free as long as possible,
684 so instead of doing what we do above, we maintain the
685 free objects in a first-in first-out queue. We also
686 don't recompute the free list each GC, unlike above;
687 this ensures that the queue ordering is preserved.
688 [This means that we are likely to have worse locality
689 of reference, and that we can never free a frob block
690 once it's allocated. (Even if we know that all cells
691 in it are free, there's no easy way to remove all those
692 cells from the free list because the objects on the
693 free list are unlikely to be in memory order.)]
694 Furthermore, we never take objects off the free list
695 unless there's a large number (usually 1000, but
696 varies depending on type) of them already on the list.
697 This way, we ensure that an object that gets freed will
698 remain free for the next 1000 (or whatever) times that
699 an object of that type is allocated.
702 #ifndef MALLOC_OVERHEAD
704 #define MALLOC_OVERHEAD 0
705 #elif defined (rcheck)
706 #define MALLOC_OVERHEAD 20
708 #define MALLOC_OVERHEAD 8
710 #endif /* MALLOC_OVERHEAD */
712 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
713 /* If we released our reserve (due to running out of memory),
714 and we have a fair amount free once again,
715 try to set aside another reserve in case we run out once more.
717 This is called when a relocatable block is freed in ralloc.c. */
718 void refill_memory_reserve (void);
720 refill_memory_reserve ()
722 if (breathing_space == 0)
723 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
727 #ifdef ALLOC_NO_POOLS
728 # define TYPE_ALLOC_SIZE(type, structtype) 1
730 # define TYPE_ALLOC_SIZE(type, structtype) \
731 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
732 / sizeof (structtype))
733 #endif /* ALLOC_NO_POOLS */
735 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
737 struct type##_block \
739 struct type##_block *prev; \
740 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
743 static struct type##_block *current_##type##_block; \
744 static int current_##type##_block_index; \
746 static structtype *type##_free_list; \
747 static structtype *type##_free_list_tail; \
750 init_##type##_alloc (void) \
752 current_##type##_block = 0; \
753 current_##type##_block_index = \
754 countof (current_##type##_block->block); \
755 type##_free_list = 0; \
756 type##_free_list_tail = 0; \
759 static int gc_count_num_##type##_in_use; \
760 static int gc_count_num_##type##_freelist
762 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
763 if (current_##type##_block_index \
764 == countof (current_##type##_block->block)) \
766 struct type##_block *AFTFB_new = (struct type##_block *) \
767 allocate_lisp_storage (sizeof (struct type##_block)); \
768 AFTFB_new->prev = current_##type##_block; \
769 current_##type##_block = AFTFB_new; \
770 current_##type##_block_index = 0; \
773 &(current_##type##_block->block[current_##type##_block_index++]); \
776 /* Allocate an instance of a type that is stored in blocks.
777 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
780 #ifdef ERROR_CHECK_GC
782 /* Note: if you get crashes in this function, suspect incorrect calls
783 to free_cons() and friends. This happened once because the cons
784 cell was not GC-protected and was getting collected before
785 free_cons() was called. */
787 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
790 if (gc_count_num_##type##_freelist > \
791 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
793 result = type##_free_list; \
794 /* Before actually using the chain pointer, we complement all its \
795 bits; see FREE_FIXED_TYPE(). */ \
797 (structtype *) ~(unsigned long) \
798 (* (structtype **) ((char *) result + sizeof (void *))); \
799 gc_count_num_##type##_freelist--; \
802 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
803 MARK_STRUCT_AS_NOT_FREE (result); \
806 #else /* !ERROR_CHECK_GC */
808 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
811 if (type##_free_list) \
813 result = type##_free_list; \
815 * (structtype **) ((char *) result + sizeof (void *)); \
818 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
819 MARK_STRUCT_AS_NOT_FREE (result); \
822 #endif /* !ERROR_CHECK_GC */
824 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
827 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
828 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
831 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
834 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
835 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
838 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
839 to a Lisp object and invalid as an actual Lisp_Object value. We have
840 to make sure that this value cannot be an integer in Lisp_Object form.
841 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
842 On a 32-bit system, the type bits will be non-zero, making the value
843 be a pointer, and the pointer will be misaligned.
845 Even if Emacs is run on some weirdo system that allows and allocates
846 byte-aligned pointers, this pointer is at the very top of the address
847 space and so it's almost inconceivable that it could ever be valid. */
850 # define INVALID_POINTER_VALUE 0xFFFFFFFF
852 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
854 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
856 You have some weird system and need to supply a reasonable value here.
859 #define FREE_STRUCT_P(ptr) \
860 (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
861 #define MARK_STRUCT_AS_FREE(ptr) \
862 (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
863 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
864 (* (void **) ptr = 0)
866 #ifdef ERROR_CHECK_GC
868 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
869 do { if (type##_free_list_tail) \
871 /* When we store the chain pointer, we complement all \
872 its bits; this should significantly increase its \
873 bogosity in case someone tries to use the value, and \
874 should make us dump faster if someone stores something \
875 over the pointer because when it gets un-complemented in \
876 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
877 extremely bogus. */ \
879 ((char *) type##_free_list_tail + sizeof (void *)) = \
880 (structtype *) ~(unsigned long) ptr; \
883 type##_free_list = ptr; \
884 type##_free_list_tail = ptr; \
887 #else /* !ERROR_CHECK_GC */
889 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
890 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
892 type##_free_list = (ptr); \
895 #endif /* !ERROR_CHECK_GC */
897 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
899 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
900 structtype *FFT_ptr = (ptr); \
901 ADDITIONAL_FREE_##type (FFT_ptr); \
902 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
903 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
904 MARK_STRUCT_AS_FREE (FFT_ptr); \
907 /* Like FREE_FIXED_TYPE() but used when we are explicitly
908 freeing a structure through free_cons(), free_marker(), etc.
909 rather than through the normal process of sweeping.
910 We attempt to undo the changes made to the allocation counters
911 as a result of this structure being allocated. This is not
912 completely necessary but helps keep things saner: e.g. this way,
913 repeatedly allocating and freeing a cons will not result in
914 the consing-since-gc counter advancing, which would cause a GC
915 and somewhat defeat the purpose of explicitly freeing. */
917 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
918 do { FREE_FIXED_TYPE (type, structtype, ptr); \
919 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
920 gc_count_num_##type##_freelist++; \
925 /************************************************************************/
926 /* Cons allocation */
927 /************************************************************************/
929 DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons);
930 /* conses are used and freed so often that we set this really high */
931 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
932 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
935 mark_cons (Lisp_Object obj)
937 if (NILP (XCDR (obj)))
940 mark_object (XCAR (obj));
945 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
947 while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1))
951 if (! CONSP (ob1) || ! CONSP (ob2))
952 return internal_equal (ob1, ob2, depth + 1);
957 static const struct lrecord_description cons_description[] = {
958 { XD_LISP_OBJECT, offsetof(struct Lisp_Cons, car), 2 },
962 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
963 mark_cons, print_cons, 0,
966 * No `hash' method needed.
967 * internal_hash knows how to
974 DEFUN ("cons", Fcons, 2, 2, 0, /*
975 Create a new cons, give it CAR and CDR as components, and return it.
979 /* This cannot GC. */
983 ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
984 set_lheader_implementation (&(c->lheader), &lrecord_cons);
991 /* This is identical to Fcons() but it used for conses that we're
992 going to free later, and is useful when trying to track down
995 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
1000 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1001 set_lheader_implementation (&(c->lheader), &lrecord_cons);
1008 DEFUN ("list", Flist, 0, MANY, 0, /*
1009 Return a newly created list with specified arguments as elements.
1010 Any number of arguments, even zero arguments, are allowed.
1012 (int nargs, Lisp_Object *args))
1014 Lisp_Object val = Qnil;
1015 Lisp_Object *argp = args + nargs;
1018 val = Fcons (*--argp, val);
1023 list1 (Lisp_Object obj0)
1025 /* This cannot GC. */
1026 return Fcons (obj0, Qnil);
1030 list2 (Lisp_Object obj0, Lisp_Object obj1)
1032 /* This cannot GC. */
1033 return Fcons (obj0, Fcons (obj1, Qnil));
1037 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1039 /* This cannot GC. */
1040 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1044 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1046 /* This cannot GC. */
1047 return Fcons (obj0, Fcons (obj1, obj2));
1051 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1053 return Fcons (Fcons (key, value), alist);
1057 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1059 /* This cannot GC. */
1060 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1064 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1067 /* This cannot GC. */
1068 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1072 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1073 Lisp_Object obj4, Lisp_Object obj5)
1075 /* This cannot GC. */
1076 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1079 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1080 Return a new list of length LENGTH, with each element being INIT.
1084 CHECK_NATNUM (length);
1087 Lisp_Object val = Qnil;
1088 size_t size = XINT (length);
1091 val = Fcons (init, val);
1097 /************************************************************************/
1098 /* Float allocation */
1099 /************************************************************************/
1101 #ifdef LISP_FLOAT_TYPE
1103 DECLARE_FIXED_TYPE_ALLOC (float, struct Lisp_Float);
1104 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1107 make_float (double float_value)
1110 struct Lisp_Float *f;
1112 ALLOCATE_FIXED_TYPE (float, struct Lisp_Float, f);
1113 set_lheader_implementation (&(f->lheader), &lrecord_float);
1114 float_data (f) = float_value;
1119 #endif /* LISP_FLOAT_TYPE */
1122 /************************************************************************/
1123 /* Vector allocation */
1124 /************************************************************************/
1127 mark_vector (Lisp_Object obj)
1129 Lisp_Vector *ptr = XVECTOR (obj);
1130 int len = vector_length (ptr);
1133 for (i = 0; i < len - 1; i++)
1134 mark_object (ptr->contents[i]);
1135 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1139 size_vector (CONST void *lheader)
1141 return STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents,
1142 ((Lisp_Vector *) lheader)->size);
1146 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1148 int len = XVECTOR_LENGTH (obj1);
1149 if (len != XVECTOR_LENGTH (obj2))
1153 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1154 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1156 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1162 static const struct lrecord_description vector_description[] = {
1163 { XD_LONG, offsetof(struct Lisp_Vector, size) },
1164 { XD_LISP_OBJECT, offsetof(struct Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1168 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1169 mark_vector, print_vector, 0,
1172 * No `hash' method needed for
1173 * vectors. internal_hash
1174 * knows how to handle vectors.
1178 size_vector, Lisp_Vector);
1180 /* #### should allocate `small' vectors from a frob-block */
1181 static Lisp_Vector *
1182 make_vector_internal (size_t sizei)
1184 /* no vector_next */
1185 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1186 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1193 make_vector (size_t length, Lisp_Object init)
1195 Lisp_Vector *vecp = make_vector_internal (length);
1196 Lisp_Object *p = vector_data (vecp);
1203 XSETVECTOR (vector, vecp);
1208 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1209 Return a new vector of length LENGTH, with each element being INIT.
1210 See also the function `vector'.
1214 CONCHECK_NATNUM (length);
1215 return make_vector (XINT (length), init);
1218 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1219 Return a newly created vector with specified arguments as elements.
1220 Any number of arguments, even zero arguments, are allowed.
1222 (int nargs, Lisp_Object *args))
1224 Lisp_Vector *vecp = make_vector_internal (nargs);
1225 Lisp_Object *p = vector_data (vecp);
1232 XSETVECTOR (vector, vecp);
1238 vector1 (Lisp_Object obj0)
1240 return Fvector (1, &obj0);
1244 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1246 Lisp_Object args[2];
1249 return Fvector (2, args);
1253 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1255 Lisp_Object args[3];
1259 return Fvector (3, args);
1262 #if 0 /* currently unused */
1265 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1268 Lisp_Object args[4];
1273 return Fvector (4, args);
1277 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1278 Lisp_Object obj3, Lisp_Object obj4)
1280 Lisp_Object args[5];
1286 return Fvector (5, args);
1290 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1291 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1293 Lisp_Object args[6];
1300 return Fvector (6, args);
1304 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1305 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1308 Lisp_Object args[7];
1316 return Fvector (7, args);
1320 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1321 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1322 Lisp_Object obj6, Lisp_Object obj7)
1324 Lisp_Object args[8];
1333 return Fvector (8, args);
1337 /************************************************************************/
1338 /* Bit Vector allocation */
1339 /************************************************************************/
1341 static Lisp_Object all_bit_vectors;
1343 /* #### should allocate `small' bit vectors from a frob-block */
1344 static struct Lisp_Bit_Vector *
1345 make_bit_vector_internal (size_t sizei)
1347 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1348 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1349 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1350 set_lheader_implementation (&(p->lheader), &lrecord_bit_vector);
1352 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1354 bit_vector_length (p) = sizei;
1355 bit_vector_next (p) = all_bit_vectors;
1356 /* make sure the extra bits in the last long are 0; the calling
1357 functions might not set them. */
1358 p->bits[num_longs - 1] = 0;
1359 XSETBIT_VECTOR (all_bit_vectors, p);
1364 make_bit_vector (size_t length, Lisp_Object init)
1366 struct Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1367 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1372 memset (p->bits, 0, num_longs * sizeof (long));
1375 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1376 memset (p->bits, ~0, num_longs * sizeof (long));
1377 /* But we have to make sure that the unused bits in the
1378 last long are 0, so that equal/hash is easy. */
1380 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1384 Lisp_Object bit_vector;
1385 XSETBIT_VECTOR (bit_vector, p);
1391 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1394 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1396 for (i = 0; i < length; i++)
1397 set_bit_vector_bit (p, i, bytevec[i]);
1400 Lisp_Object bit_vector;
1401 XSETBIT_VECTOR (bit_vector, p);
1406 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1407 Return a new bit vector of length LENGTH. with each bit being INIT.
1408 Each element is set to INIT. See also the function `bit-vector'.
1412 CONCHECK_NATNUM (length);
1414 return make_bit_vector (XINT (length), init);
1417 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1418 Return a newly created bit vector with specified arguments as elements.
1419 Any number of arguments, even zero arguments, are allowed.
1421 (int nargs, Lisp_Object *args))
1424 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1426 for (i = 0; i < nargs; i++)
1428 CHECK_BIT (args[i]);
1429 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1433 Lisp_Object bit_vector;
1434 XSETBIT_VECTOR (bit_vector, p);
1440 /************************************************************************/
1441 /* Compiled-function allocation */
1442 /************************************************************************/
1444 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1445 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1448 make_compiled_function (void)
1450 Lisp_Compiled_Function *f;
1453 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1454 set_lheader_implementation (&(f->lheader), &lrecord_compiled_function);
1457 f->specpdl_depth = 0;
1458 f->flags.documentationp = 0;
1459 f->flags.interactivep = 0;
1460 f->flags.domainp = 0; /* I18N3 */
1461 f->instructions = Qzero;
1462 f->constants = Qzero;
1464 f->doc_and_interactive = Qnil;
1465 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1466 f->annotated = Qnil;
1468 XSETCOMPILED_FUNCTION (fun, f);
1472 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1473 Return a new compiled-function object.
1474 Usage: (arglist instructions constants stack-depth
1475 &optional doc-string interactive)
1476 Note that, unlike all other emacs-lisp functions, calling this with five
1477 arguments is NOT the same as calling it with six arguments, the last of
1478 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1479 that this function was defined with `(interactive)'. If the arg is not
1480 specified, then that means the function is not interactive.
1481 This is terrible behavior which is retained for compatibility with old
1482 `.elc' files which expect these semantics.
1484 (int nargs, Lisp_Object *args))
1486 /* In a non-insane world this function would have this arglist...
1487 (arglist instructions constants stack_depth &optional doc_string interactive)
1489 Lisp_Object fun = make_compiled_function ();
1490 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1492 Lisp_Object arglist = args[0];
1493 Lisp_Object instructions = args[1];
1494 Lisp_Object constants = args[2];
1495 Lisp_Object stack_depth = args[3];
1496 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1497 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1499 if (nargs < 4 || nargs > 6)
1500 return Fsignal (Qwrong_number_of_arguments,
1501 list2 (intern ("make-byte-code"), make_int (nargs)));
1503 /* Check for valid formal parameter list now, to allow us to use
1504 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1506 Lisp_Object symbol, tail;
1507 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1509 CHECK_SYMBOL (symbol);
1510 if (EQ (symbol, Qt) ||
1511 EQ (symbol, Qnil) ||
1512 SYMBOL_IS_KEYWORD (symbol))
1513 signal_simple_error_2
1514 ("Invalid constant symbol in formal parameter list",
1518 f->arglist = arglist;
1520 /* `instructions' is a string or a cons (string . int) for a
1521 lazy-loaded function. */
1522 if (CONSP (instructions))
1524 CHECK_STRING (XCAR (instructions));
1525 CHECK_INT (XCDR (instructions));
1529 CHECK_STRING (instructions);
1531 f->instructions = instructions;
1533 if (!NILP (constants))
1534 CHECK_VECTOR (constants);
1535 f->constants = constants;
1537 CHECK_NATNUM (stack_depth);
1538 f->stack_depth = XINT (stack_depth);
1540 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1541 if (!NILP (Vcurrent_compiled_function_annotation))
1542 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1543 else if (!NILP (Vload_file_name_internal_the_purecopy))
1544 f->annotated = Vload_file_name_internal_the_purecopy;
1545 else if (!NILP (Vload_file_name_internal))
1547 struct gcpro gcpro1;
1548 GCPRO1 (fun); /* don't let fun get reaped */
1549 Vload_file_name_internal_the_purecopy =
1550 Ffile_name_nondirectory (Vload_file_name_internal);
1551 f->annotated = Vload_file_name_internal_the_purecopy;
1554 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1556 /* doc_string may be nil, string, int, or a cons (string . int).
1557 interactive may be list or string (or unbound). */
1558 f->doc_and_interactive = Qunbound;
1560 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1561 f->doc_and_interactive = Vfile_domain;
1563 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1565 f->doc_and_interactive
1566 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1567 Fcons (interactive, f->doc_and_interactive));
1569 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1571 f->doc_and_interactive
1572 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1573 Fcons (doc_string, f->doc_and_interactive));
1575 if (UNBOUNDP (f->doc_and_interactive))
1576 f->doc_and_interactive = Qnil;
1582 /************************************************************************/
1583 /* Symbol allocation */
1584 /************************************************************************/
1586 DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol);
1587 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1589 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1590 Return a newly allocated uninterned symbol whose name is NAME.
1591 Its value and function definition are void, and its property list is nil.
1596 struct Lisp_Symbol *p;
1598 CHECK_STRING (name);
1600 ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p);
1601 set_lheader_implementation (&(p->lheader), &lrecord_symbol);
1602 p->name = XSTRING (name);
1604 p->value = Qunbound;
1605 p->function = Qunbound;
1606 symbol_next (p) = 0;
1607 XSETSYMBOL (val, p);
1612 /************************************************************************/
1613 /* Extent allocation */
1614 /************************************************************************/
1616 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1617 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1620 allocate_extent (void)
1624 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1625 set_lheader_implementation (&(e->lheader), &lrecord_extent);
1626 extent_object (e) = Qnil;
1627 set_extent_start (e, -1);
1628 set_extent_end (e, -1);
1633 extent_face (e) = Qnil;
1634 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1635 e->flags.detachable = 1;
1641 /************************************************************************/
1642 /* Event allocation */
1643 /************************************************************************/
1645 DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event);
1646 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1649 allocate_event (void)
1652 struct Lisp_Event *e;
1654 ALLOCATE_FIXED_TYPE (event, struct Lisp_Event, e);
1655 set_lheader_implementation (&(e->lheader), &lrecord_event);
1662 /************************************************************************/
1663 /* Marker allocation */
1664 /************************************************************************/
1666 DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker);
1667 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1669 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1670 Return a new marker which does not point at any place.
1675 struct Lisp_Marker *p;
1677 ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1678 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1681 marker_next (p) = 0;
1682 marker_prev (p) = 0;
1683 p->insertion_type = 0;
1684 XSETMARKER (val, p);
1689 noseeum_make_marker (void)
1692 struct Lisp_Marker *p;
1694 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1695 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1698 marker_next (p) = 0;
1699 marker_prev (p) = 0;
1700 p->insertion_type = 0;
1701 XSETMARKER (val, p);
1706 /************************************************************************/
1707 /* String allocation */
1708 /************************************************************************/
1710 /* The data for "short" strings generally resides inside of structs of type
1711 string_chars_block. The Lisp_String structure is allocated just like any
1712 other Lisp object (except for vectors), and these are freelisted when
1713 they get garbage collected. The data for short strings get compacted,
1714 but the data for large strings do not.
1716 Previously Lisp_String structures were relocated, but this caused a lot
1717 of bus-errors because the C code didn't include enough GCPRO's for
1718 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1719 that the reference would get relocated).
1721 This new method makes things somewhat bigger, but it is MUCH safer. */
1723 DECLARE_FIXED_TYPE_ALLOC (string, struct Lisp_String);
1724 /* strings are used and freed quite often */
1725 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1726 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1729 mark_string (Lisp_Object obj)
1731 struct Lisp_String *ptr = XSTRING (obj);
1733 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1734 flush_cached_extent_info (XCAR (ptr->plist));
1739 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1742 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1743 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1746 static const struct lrecord_description string_description[] = {
1747 { XD_BYTECOUNT, offsetof(Lisp_String, size) },
1748 { XD_OPAQUE_DATA_PTR, offsetof(Lisp_String, data), XD_INDIRECT(0, 1) },
1749 { XD_LISP_OBJECT, offsetof(Lisp_String, plist), 1 },
1753 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
1754 mark_string, print_string,
1756 * No `finalize', or `hash' methods.
1757 * internal_hash already knows how
1758 * to hash strings and finalization
1760 * ADDITIONAL_FREE_string macro,
1761 * which is the standard way to do
1762 * finalization when using
1763 * SWEEP_FIXED_TYPE_BLOCK().
1767 struct Lisp_String);
1769 /* String blocks contain this many useful bytes. */
1770 #define STRING_CHARS_BLOCK_SIZE \
1771 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1772 ((2 * sizeof (struct string_chars_block *)) \
1773 + sizeof (EMACS_INT))))
1774 /* Block header for small strings. */
1775 struct string_chars_block
1778 struct string_chars_block *next;
1779 struct string_chars_block *prev;
1780 /* Contents of string_chars_block->string_chars are interleaved
1781 string_chars structures (see below) and the actual string data */
1782 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1785 static struct string_chars_block *first_string_chars_block;
1786 static struct string_chars_block *current_string_chars_block;
1788 /* If SIZE is the length of a string, this returns how many bytes
1789 * the string occupies in string_chars_block->string_chars
1790 * (including alignment padding).
1792 #define STRING_FULLSIZE(s) \
1793 ALIGN_SIZE (((s) + 1 + sizeof (struct Lisp_String *)),\
1794 ALIGNOF (struct Lisp_String *))
1796 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1797 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1799 #define CHARS_TO_STRING_CHAR(x) \
1800 ((struct string_chars *) \
1801 (((char *) (x)) - (slot_offset (struct string_chars, chars[0]))))
1806 struct Lisp_String *string;
1807 unsigned char chars[1];
1810 struct unused_string_chars
1812 struct Lisp_String *string;
1817 init_string_chars_alloc (void)
1819 first_string_chars_block = xnew (struct string_chars_block);
1820 first_string_chars_block->prev = 0;
1821 first_string_chars_block->next = 0;
1822 first_string_chars_block->pos = 0;
1823 current_string_chars_block = first_string_chars_block;
1826 static struct string_chars *
1827 allocate_string_chars_struct (struct Lisp_String *string_it_goes_with,
1830 struct string_chars *s_chars;
1832 /* Allocate the string's actual data */
1833 if (BIG_STRING_FULLSIZE_P (fullsize))
1835 s_chars = (struct string_chars *) xmalloc (fullsize);
1837 else if (fullsize <=
1838 (countof (current_string_chars_block->string_chars)
1839 - current_string_chars_block->pos))
1841 /* This string can fit in the current string chars block */
1842 s_chars = (struct string_chars *)
1843 (current_string_chars_block->string_chars
1844 + current_string_chars_block->pos);
1845 current_string_chars_block->pos += fullsize;
1849 /* Make a new current string chars block */
1850 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1852 current_string_chars_block->next = new_scb;
1853 new_scb->prev = current_string_chars_block;
1855 current_string_chars_block = new_scb;
1856 new_scb->pos = fullsize;
1857 s_chars = (struct string_chars *)
1858 current_string_chars_block->string_chars;
1861 s_chars->string = string_it_goes_with;
1863 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1869 make_uninit_string (Bytecount length)
1871 struct Lisp_String *s;
1872 struct string_chars *s_chars;
1873 EMACS_INT fullsize = STRING_FULLSIZE (length);
1876 if ((length < 0) || (fullsize <= 0))
1879 /* Allocate the string header */
1880 ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
1881 set_lheader_implementation (&(s->lheader), &lrecord_string);
1883 s_chars = allocate_string_chars_struct (s, fullsize);
1885 set_string_data (s, &(s_chars->chars[0]));
1886 set_string_length (s, length);
1889 set_string_byte (s, length, 0);
1891 XSETSTRING (val, s);
1895 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1896 static void verify_string_chars_integrity (void);
1899 /* Resize the string S so that DELTA bytes can be inserted starting
1900 at POS. If DELTA < 0, it means deletion starting at POS. If
1901 POS < 0, resize the string but don't copy any characters. Use
1902 this if you're planning on completely overwriting the string.
1906 resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta)
1908 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1909 verify_string_chars_integrity ();
1912 #ifdef ERROR_CHECK_BUFPOS
1915 assert (pos <= string_length (s));
1917 assert (pos + (-delta) <= string_length (s));
1922 assert ((-delta) <= string_length (s));
1924 #endif /* ERROR_CHECK_BUFPOS */
1926 if (pos >= 0 && delta < 0)
1927 /* If DELTA < 0, the functions below will delete the characters
1928 before POS. We want to delete characters *after* POS, however,
1929 so convert this to the appropriate form. */
1933 /* simplest case: no size change. */
1937 Bytecount oldfullsize = STRING_FULLSIZE (string_length (s));
1938 Bytecount newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1940 if (oldfullsize == newfullsize)
1942 /* next simplest case; size change but the necessary
1943 allocation size won't change (up or down; code somewhere
1944 depends on there not being any unused allocation space,
1945 modulo any alignment constraints). */
1948 Bufbyte *addroff = pos + string_data (s);
1950 memmove (addroff + delta, addroff,
1951 /* +1 due to zero-termination. */
1952 string_length (s) + 1 - pos);
1955 else if (BIG_STRING_FULLSIZE_P (oldfullsize) &&
1956 BIG_STRING_FULLSIZE_P (newfullsize))
1958 /* next simplest case; the string is big enough to be malloc()ed
1959 itself, so we just realloc.
1961 It's important not to let the string get below the threshold
1962 for making big strings and still remain malloc()ed; if that
1963 were the case, repeated calls to this function on the same
1964 string could result in memory leakage. */
1965 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1969 Bufbyte *addroff = pos + string_data (s);
1971 memmove (addroff + delta, addroff,
1972 /* +1 due to zero-termination. */
1973 string_length (s) + 1 - pos);
1978 /* worst case. We make a new string_chars struct and copy
1979 the string's data into it, inserting/deleting the delta
1980 in the process. The old string data will either get
1981 freed by us (if it was malloc()ed) or will be reclaimed
1982 in the normal course of garbage collection. */
1983 struct string_chars *s_chars =
1984 allocate_string_chars_struct (s, newfullsize);
1985 Bufbyte *new_addr = &(s_chars->chars[0]);
1986 Bufbyte *old_addr = string_data (s);
1989 memcpy (new_addr, old_addr, pos);
1990 memcpy (new_addr + pos + delta, old_addr + pos,
1991 string_length (s) + 1 - pos);
1993 set_string_data (s, new_addr);
1994 if (BIG_STRING_FULLSIZE_P (oldfullsize))
1998 /* We need to mark this chunk of the string_chars_block
1999 as unused so that compact_string_chars() doesn't
2001 struct string_chars *old_s_chars =
2002 (struct string_chars *) ((char *) old_addr -
2003 sizeof (struct Lisp_String *));
2004 /* Sanity check to make sure we aren't hosed by strange
2005 alignment/padding. */
2006 assert (old_s_chars->string == s);
2007 MARK_STRUCT_AS_FREE (old_s_chars);
2008 ((struct unused_string_chars *) old_s_chars)->fullsize =
2013 set_string_length (s, string_length (s) + delta);
2014 /* If pos < 0, the string won't be zero-terminated.
2015 Terminate now just to make sure. */
2016 string_data (s)[string_length (s)] = '\0';
2022 XSETSTRING (string, s);
2023 /* We also have to adjust all of the extent indices after the
2024 place we did the change. We say "pos - 1" because
2025 adjust_extents() is exclusive of the starting position
2027 adjust_extents (string, pos - 1, string_length (s),
2032 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2033 verify_string_chars_integrity ();
2040 set_string_char (struct Lisp_String *s, Charcount i, Emchar c)
2042 Bufbyte newstr[MAX_EMCHAR_LEN];
2043 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2044 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2045 Bytecount newlen = set_charptr_emchar (newstr, c);
2047 if (oldlen != newlen)
2048 resize_string (s, bytoff, newlen - oldlen);
2049 /* Remember, string_data (s) might have changed so we can't cache it. */
2050 memcpy (string_data (s) + bytoff, newstr, newlen);
2055 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2056 Return a new string of length LENGTH, with each character being INIT.
2057 LENGTH must be an integer and INIT must be a character.
2061 CHECK_NATNUM (length);
2062 CHECK_CHAR_COERCE_INT (init);
2064 Bufbyte init_str[MAX_EMCHAR_LEN];
2065 int len = set_charptr_emchar (init_str, XCHAR (init));
2066 Lisp_Object val = make_uninit_string (len * XINT (length));
2069 /* Optimize the single-byte case */
2070 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2074 Bufbyte *ptr = XSTRING_DATA (val);
2076 for (i = XINT (length); i; i--)
2078 Bufbyte *init_ptr = init_str;
2082 case 6: *ptr++ = *init_ptr++;
2083 case 5: *ptr++ = *init_ptr++;
2085 case 4: *ptr++ = *init_ptr++;
2086 case 3: *ptr++ = *init_ptr++;
2087 case 2: *ptr++ = *init_ptr++;
2088 case 1: *ptr++ = *init_ptr++;
2096 DEFUN ("string", Fstring, 0, MANY, 0, /*
2097 Concatenate all the argument characters and make the result a string.
2099 (int nargs, Lisp_Object *args))
2101 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2102 Bufbyte *p = storage;
2104 for (; nargs; nargs--, args++)
2106 Lisp_Object lisp_char = *args;
2107 CHECK_CHAR_COERCE_INT (lisp_char);
2108 p += set_charptr_emchar (p, XCHAR (lisp_char));
2110 return make_string (storage, p - storage);
2114 /* Take some raw memory, which MUST already be in internal format,
2115 and package it up into a Lisp string. */
2117 make_string (CONST Bufbyte *contents, Bytecount length)
2121 /* Make sure we find out about bad make_string's when they happen */
2122 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2123 bytecount_to_charcount (contents, length); /* Just for the assertions */
2126 val = make_uninit_string (length);
2127 memcpy (XSTRING_DATA (val), contents, length);
2131 /* Take some raw memory, encoded in some external data format,
2132 and convert it into a Lisp string. */
2134 make_ext_string (CONST Extbyte *contents, EMACS_INT length,
2135 enum external_data_format fmt)
2140 GET_CHARPTR_INT_DATA_ALLOCA (contents, length, fmt, intstr, intlen);
2141 return make_string (intstr, intlen);
2145 build_string (CONST char *str)
2147 /* Some strlen's crash and burn if passed null. */
2148 return make_string ((CONST Bufbyte *) str, (str ? strlen(str) : 0));
2152 build_ext_string (CONST char *str, enum external_data_format fmt)
2154 /* Some strlen's crash and burn if passed null. */
2155 return make_ext_string ((CONST Extbyte *) str, (str ? strlen(str) : 0), fmt);
2159 build_translated_string (CONST char *str)
2161 return build_string (GETTEXT (str));
2165 make_string_nocopy (CONST Bufbyte *contents, Bytecount length)
2167 struct Lisp_String *s;
2170 /* Make sure we find out about bad make_string_nocopy's when they happen */
2171 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2172 bytecount_to_charcount (contents, length); /* Just for the assertions */
2175 /* Allocate the string header */
2176 ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
2177 set_lheader_implementation (&(s->lheader), &lrecord_string);
2178 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2180 set_string_data (s, (Bufbyte *)contents);
2181 set_string_length (s, length);
2183 XSETSTRING (val, s);
2188 /************************************************************************/
2189 /* lcrecord lists */
2190 /************************************************************************/
2192 /* Lcrecord lists are used to manage the allocation of particular
2193 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2194 malloc() and garbage-collection junk) as much as possible.
2195 It is similar to the Blocktype class.
2199 1) Create an lcrecord-list object using make_lcrecord_list().
2200 This is often done at initialization. Remember to staticpro_nodump
2201 this object! The arguments to make_lcrecord_list() are the
2202 same as would be passed to alloc_lcrecord().
2203 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2204 and pass the lcrecord-list earlier created.
2205 3) When done with the lcrecord, call free_managed_lcrecord().
2206 The standard freeing caveats apply: ** make sure there are no
2207 pointers to the object anywhere! **
2208 4) Calling free_managed_lcrecord() is just like kissing the
2209 lcrecord goodbye as if it were garbage-collected. This means:
2210 -- the contents of the freed lcrecord are undefined, and the
2211 contents of something produced by allocate_managed_lcrecord()
2212 are undefined, just like for alloc_lcrecord().
2213 -- the mark method for the lcrecord's type will *NEVER* be called
2215 -- the finalize method for the lcrecord's type will be called
2216 at the time that free_managed_lcrecord() is called.
2221 mark_lcrecord_list (Lisp_Object obj)
2223 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2224 Lisp_Object chain = list->free;
2226 while (!NILP (chain))
2228 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2229 struct free_lcrecord_header *free_header =
2230 (struct free_lcrecord_header *) lheader;
2232 #ifdef ERROR_CHECK_GC
2233 CONST struct lrecord_implementation *implementation
2234 = LHEADER_IMPLEMENTATION(lheader);
2236 /* There should be no other pointers to the free list. */
2237 assert (!MARKED_RECORD_HEADER_P (lheader));
2238 /* Only lcrecords should be here. */
2239 assert (!implementation->basic_p);
2240 /* Only free lcrecords should be here. */
2241 assert (free_header->lcheader.free);
2242 /* The type of the lcrecord must be right. */
2243 assert (implementation == list->implementation);
2244 /* So must the size. */
2245 assert (implementation->static_size == 0
2246 || implementation->static_size == list->size);
2247 #endif /* ERROR_CHECK_GC */
2249 MARK_RECORD_HEADER (lheader);
2250 chain = free_header->chain;
2256 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2257 mark_lcrecord_list, internal_object_printer,
2258 0, 0, 0, 0, struct lcrecord_list);
2260 make_lcrecord_list (size_t size,
2261 CONST struct lrecord_implementation *implementation)
2263 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2264 &lrecord_lcrecord_list);
2267 p->implementation = implementation;
2270 XSETLCRECORD_LIST (val, p);
2275 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2277 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2278 if (!NILP (list->free))
2280 Lisp_Object val = list->free;
2281 struct free_lcrecord_header *free_header =
2282 (struct free_lcrecord_header *) XPNTR (val);
2284 #ifdef ERROR_CHECK_GC
2285 struct lrecord_header *lheader =
2286 (struct lrecord_header *) free_header;
2287 CONST struct lrecord_implementation *implementation
2288 = LHEADER_IMPLEMENTATION (lheader);
2290 /* There should be no other pointers to the free list. */
2291 assert (!MARKED_RECORD_HEADER_P (lheader));
2292 /* Only lcrecords should be here. */
2293 assert (!implementation->basic_p);
2294 /* Only free lcrecords should be here. */
2295 assert (free_header->lcheader.free);
2296 /* The type of the lcrecord must be right. */
2297 assert (implementation == list->implementation);
2298 /* So must the size. */
2299 assert (implementation->static_size == 0
2300 || implementation->static_size == list->size);
2301 #endif /* ERROR_CHECK_GC */
2302 list->free = free_header->chain;
2303 free_header->lcheader.free = 0;
2310 XSETOBJ (val, Lisp_Type_Record,
2311 alloc_lcrecord (list->size, list->implementation));
2317 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2319 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2320 struct free_lcrecord_header *free_header =
2321 (struct free_lcrecord_header *) XPNTR (lcrecord);
2322 struct lrecord_header *lheader =
2323 (struct lrecord_header *) free_header;
2324 CONST struct lrecord_implementation *implementation
2325 = LHEADER_IMPLEMENTATION (lheader);
2327 #ifdef ERROR_CHECK_GC
2328 /* Make sure the size is correct. This will catch, for example,
2329 putting a window configuration on the wrong free list. */
2330 if (implementation->size_in_bytes_method)
2331 assert (implementation->size_in_bytes_method (lheader) == list->size);
2333 assert (implementation->static_size == list->size);
2334 #endif /* ERROR_CHECK_GC */
2336 if (implementation->finalizer)
2337 implementation->finalizer (lheader, 0);
2338 free_header->chain = list->free;
2339 free_header->lcheader.free = 1;
2340 list->free = lcrecord;
2346 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2347 Kept for compatibility, returns its argument.
2349 Make a copy of OBJECT in pure storage.
2350 Recursively copies contents of vectors and cons cells.
2351 Does not copy symbols.
2360 /************************************************************************/
2361 /* Garbage Collection */
2362 /************************************************************************/
2364 /* This will be used more extensively In The Future */
2365 static int last_lrecord_type_index_assigned;
2367 CONST struct lrecord_implementation *lrecord_implementations_table[128];
2368 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
2370 struct gcpro *gcprolist;
2372 /* 415 used Mly 29-Jun-93 */
2373 /* 1327 used slb 28-Feb-98 */
2374 /* 1328 used og 03-Oct-99 (moving slowly, heh?) */
2376 #define NSTATICS 4000
2378 #define NSTATICS 2000
2380 /* Not "static" because of linker lossage on some systems */
2381 Lisp_Object *staticvec[NSTATICS]
2382 /* Force it into data space! */
2384 static int staticidx;
2386 /* Put an entry in staticvec, pointing at the variable whose address is given
2389 staticpro (Lisp_Object *varaddress)
2391 if (staticidx >= countof (staticvec))
2392 /* #### This is now a dubious abort() since this routine may be called */
2393 /* by Lisp attempting to load a DLL. */
2395 staticvec[staticidx++] = varaddress;
2398 /* Not "static" because of linker lossage on some systems */
2399 Lisp_Object *staticvec_nodump[200]
2400 /* Force it into data space! */
2402 static int staticidx_nodump;
2404 /* Put an entry in staticvec_nodump, pointing at the variable whose address is given
2407 staticpro_nodump (Lisp_Object *varaddress)
2409 if (staticidx_nodump >= countof (staticvec_nodump))
2410 /* #### This is now a dubious abort() since this routine may be called */
2411 /* by Lisp attempting to load a DLL. */
2413 staticvec_nodump[staticidx_nodump++] = varaddress;
2416 /* Not "static" because of linker lossage on some systems */
2419 const struct struct_description *desc;
2420 } dumpstructvec[200];
2422 static int dumpstructidx;
2424 /* Put an entry in dumpstructvec, pointing at the variable whose address is given
2427 dumpstruct (void *varaddress, const struct struct_description *desc)
2429 if (dumpstructidx >= countof (dumpstructvec))
2431 dumpstructvec[dumpstructidx].data = varaddress;
2432 dumpstructvec[dumpstructidx].desc = desc;
2436 Lisp_Object *pdump_wirevec[50];
2437 static int pdump_wireidx;
2439 /* Put an entry in pdump_wirevec, pointing at the variable whose address is given
2442 pdump_wire (Lisp_Object *varaddress)
2444 if (pdump_wireidx >= countof (pdump_wirevec))
2446 pdump_wirevec[pdump_wireidx++] = varaddress;
2450 Lisp_Object *pdump_wirevec_list[50];
2451 static int pdump_wireidx_list;
2453 /* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given
2456 pdump_wire_list (Lisp_Object *varaddress)
2458 if (pdump_wireidx_list >= countof (pdump_wirevec_list))
2460 pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
2464 /* Mark reference to a Lisp_Object. If the object referred to has not been
2465 seen yet, recursively mark all the references contained in it. */
2468 mark_object (Lisp_Object obj)
2472 #ifdef ERROR_CHECK_GC
2473 assert (! (EQ (obj, Qnull_pointer)));
2475 /* Checks we used to perform */
2476 /* if (EQ (obj, Qnull_pointer)) return; */
2477 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2478 /* if (PURIFIED (XPNTR (obj))) return; */
2480 if (XTYPE (obj) == Lisp_Type_Record)
2482 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2483 #if defined (ERROR_CHECK_GC)
2484 assert (lheader->type <= last_lrecord_type_index_assigned);
2486 if (C_READONLY_RECORD_HEADER_P (lheader))
2489 if (! MARKED_RECORD_HEADER_P (lheader) &&
2490 ! UNMARKABLE_RECORD_HEADER_P (lheader))
2492 CONST struct lrecord_implementation *implementation =
2493 LHEADER_IMPLEMENTATION (lheader);
2494 MARK_RECORD_HEADER (lheader);
2495 #ifdef ERROR_CHECK_GC
2496 if (!implementation->basic_p)
2497 assert (! ((struct lcrecord_header *) lheader)->free);
2499 if (implementation->marker)
2501 obj = implementation->marker (obj);
2502 if (!NILP (obj)) goto tail_recurse;
2508 /* mark all of the conses in a list and mark the final cdr; but
2509 DO NOT mark the cars.
2511 Use only for internal lists! There should never be other pointers
2512 to the cons cells, because if so, the cars will remain unmarked
2513 even when they maybe should be marked. */
2515 mark_conses_in_list (Lisp_Object obj)
2519 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2521 if (CONS_MARKED_P (XCONS (rest)))
2523 MARK_CONS (XCONS (rest));
2530 /* Find all structures not marked, and free them. */
2532 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2533 static int gc_count_bit_vector_storage;
2534 static int gc_count_num_short_string_in_use;
2535 static int gc_count_string_total_size;
2536 static int gc_count_short_string_total_size;
2538 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2542 lrecord_type_index (CONST struct lrecord_implementation *implementation)
2544 int type_index = *(implementation->lrecord_type_index);
2545 /* Have to do this circuitous validation test because of problems
2546 dumping out initialized variables (ie can't set xxx_type_index to -1
2547 because that would make xxx_type_index read-only in a dumped emacs. */
2548 if (type_index < 0 || type_index > max_lrecord_type
2549 || lrecord_implementations_table[type_index] != implementation)
2551 assert (last_lrecord_type_index_assigned < max_lrecord_type);
2552 type_index = ++last_lrecord_type_index_assigned;
2553 lrecord_implementations_table[type_index] = implementation;
2554 *(implementation->lrecord_type_index) = type_index;
2559 /* stats on lcrecords in use - kinda kludgy */
2563 int instances_in_use;
2565 int instances_freed;
2567 int instances_on_free_list;
2568 } lcrecord_stats [countof (lrecord_implementations_table)];
2571 tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p)
2573 CONST struct lrecord_implementation *implementation =
2574 LHEADER_IMPLEMENTATION (h);
2575 int type_index = lrecord_type_index (implementation);
2577 if (((struct lcrecord_header *) h)->free)
2580 lcrecord_stats[type_index].instances_on_free_list++;
2584 size_t sz = (implementation->size_in_bytes_method
2585 ? implementation->size_in_bytes_method (h)
2586 : implementation->static_size);
2590 lcrecord_stats[type_index].instances_freed++;
2591 lcrecord_stats[type_index].bytes_freed += sz;
2595 lcrecord_stats[type_index].instances_in_use++;
2596 lcrecord_stats[type_index].bytes_in_use += sz;
2602 /* Free all unmarked records */
2604 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2606 struct lcrecord_header *header;
2608 /* int total_size = 0; */
2610 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2612 /* First go through and call all the finalize methods.
2613 Then go through and free the objects. There used to
2614 be only one loop here, with the call to the finalizer
2615 occurring directly before the xfree() below. That
2616 is marginally faster but much less safe -- if the
2617 finalize method for an object needs to reference any
2618 other objects contained within it (and many do),
2619 we could easily be screwed by having already freed that
2622 for (header = *prev; header; header = header->next)
2624 struct lrecord_header *h = &(header->lheader);
2625 if (!C_READONLY_RECORD_HEADER_P(h)
2626 && !MARKED_RECORD_HEADER_P (h)
2627 && ! (header->free))
2629 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2630 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2634 for (header = *prev; header; )
2636 struct lrecord_header *h = &(header->lheader);
2637 if (C_READONLY_RECORD_HEADER_P(h) || MARKED_RECORD_HEADER_P (h))
2639 if (MARKED_RECORD_HEADER_P (h))
2640 UNMARK_RECORD_HEADER (h);
2642 /* total_size += n->implementation->size_in_bytes (h);*/
2643 /* ### May modify header->next on a C_READONLY lcrecord */
2644 prev = &(header->next);
2646 tick_lcrecord_stats (h, 0);
2650 struct lcrecord_header *next = header->next;
2652 tick_lcrecord_stats (h, 1);
2653 /* used to call finalizer right here. */
2659 /* *total = total_size; */
2664 sweep_bit_vectors_1 (Lisp_Object *prev,
2665 int *used, int *total, int *storage)
2667 Lisp_Object bit_vector;
2670 int total_storage = 0;
2672 /* BIT_VECTORP fails because the objects are marked, which changes
2673 their implementation */
2674 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2676 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2678 if (C_READONLY_RECORD_HEADER_P(&(v->lheader)) || MARKED_RECORD_P (bit_vector))
2680 if (MARKED_RECORD_P (bit_vector))
2681 UNMARK_RECORD_HEADER (&(v->lheader));
2685 STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2686 BIT_VECTOR_LONG_STORAGE (len));
2688 /* ### May modify next on a C_READONLY bitvector */
2689 prev = &(bit_vector_next (v));
2694 Lisp_Object next = bit_vector_next (v);
2701 *total = total_size;
2702 *storage = total_storage;
2705 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2706 to make macros prettier. */
2708 #ifdef ERROR_CHECK_GC
2710 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2712 struct typename##_block *SFTB_current; \
2713 struct typename##_block **SFTB_prev; \
2715 int num_free = 0, num_used = 0; \
2717 for (SFTB_prev = ¤t_##typename##_block, \
2718 SFTB_current = current_##typename##_block, \
2719 SFTB_limit = current_##typename##_block_index; \
2725 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2727 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2729 if (FREE_STRUCT_P (SFTB_victim)) \
2733 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2737 else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2740 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2745 UNMARK_##typename (SFTB_victim); \
2748 SFTB_prev = &(SFTB_current->prev); \
2749 SFTB_current = SFTB_current->prev; \
2750 SFTB_limit = countof (current_##typename##_block->block); \
2753 gc_count_num_##typename##_in_use = num_used; \
2754 gc_count_num_##typename##_freelist = num_free; \
2757 #else /* !ERROR_CHECK_GC */
2759 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2761 struct typename##_block *SFTB_current; \
2762 struct typename##_block **SFTB_prev; \
2764 int num_free = 0, num_used = 0; \
2766 typename##_free_list = 0; \
2768 for (SFTB_prev = ¤t_##typename##_block, \
2769 SFTB_current = current_##typename##_block, \
2770 SFTB_limit = current_##typename##_block_index; \
2775 int SFTB_empty = 1; \
2776 obj_type *SFTB_old_free_list = typename##_free_list; \
2778 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2780 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2782 if (FREE_STRUCT_P (SFTB_victim)) \
2785 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2787 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2792 else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2795 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2801 UNMARK_##typename (SFTB_victim); \
2806 SFTB_prev = &(SFTB_current->prev); \
2807 SFTB_current = SFTB_current->prev; \
2809 else if (SFTB_current == current_##typename##_block \
2810 && !SFTB_current->prev) \
2812 /* No real point in freeing sole allocation block */ \
2817 struct typename##_block *SFTB_victim_block = SFTB_current; \
2818 if (SFTB_victim_block == current_##typename##_block) \
2819 current_##typename##_block_index \
2820 = countof (current_##typename##_block->block); \
2821 SFTB_current = SFTB_current->prev; \
2823 *SFTB_prev = SFTB_current; \
2824 xfree (SFTB_victim_block); \
2825 /* Restore free list to what it was before victim was swept */ \
2826 typename##_free_list = SFTB_old_free_list; \
2827 num_free -= SFTB_limit; \
2830 SFTB_limit = countof (current_##typename##_block->block); \
2833 gc_count_num_##typename##_in_use = num_used; \
2834 gc_count_num_##typename##_freelist = num_free; \
2837 #endif /* !ERROR_CHECK_GC */
2845 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2846 #define ADDITIONAL_FREE_cons(ptr)
2848 SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons);
2851 /* Explicitly free a cons cell. */
2853 free_cons (struct Lisp_Cons *ptr)
2855 #ifdef ERROR_CHECK_GC
2856 /* If the CAR is not an int, then it will be a pointer, which will
2857 always be four-byte aligned. If this cons cell has already been
2858 placed on the free list, however, its car will probably contain
2859 a chain pointer to the next cons on the list, which has cleverly
2860 had all its 0's and 1's inverted. This allows for a quick
2861 check to make sure we're not freeing something already freed. */
2862 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2863 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2864 #endif /* ERROR_CHECK_GC */
2866 #ifndef ALLOC_NO_POOLS
2867 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, struct Lisp_Cons, ptr);
2868 #endif /* ALLOC_NO_POOLS */
2871 /* explicitly free a list. You **must make sure** that you have
2872 created all the cons cells that make up this list and that there
2873 are no pointers to any of these cons cells anywhere else. If there
2874 are, you will lose. */
2877 free_list (Lisp_Object list)
2879 Lisp_Object rest, next;
2881 for (rest = list; !NILP (rest); rest = next)
2884 free_cons (XCONS (rest));
2888 /* explicitly free an alist. You **must make sure** that you have
2889 created all the cons cells that make up this alist and that there
2890 are no pointers to any of these cons cells anywhere else. If there
2891 are, you will lose. */
2894 free_alist (Lisp_Object alist)
2896 Lisp_Object rest, next;
2898 for (rest = alist; !NILP (rest); rest = next)
2901 free_cons (XCONS (XCAR (rest)));
2902 free_cons (XCONS (rest));
2907 sweep_compiled_functions (void)
2909 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2910 #define ADDITIONAL_FREE_compiled_function(ptr)
2912 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2916 #ifdef LISP_FLOAT_TYPE
2920 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2921 #define ADDITIONAL_FREE_float(ptr)
2923 SWEEP_FIXED_TYPE_BLOCK (float, struct Lisp_Float);
2925 #endif /* LISP_FLOAT_TYPE */
2928 sweep_symbols (void)
2930 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2931 #define ADDITIONAL_FREE_symbol(ptr)
2933 SWEEP_FIXED_TYPE_BLOCK (symbol, struct Lisp_Symbol);
2937 sweep_extents (void)
2939 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2940 #define ADDITIONAL_FREE_extent(ptr)
2942 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2948 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2949 #define ADDITIONAL_FREE_event(ptr)
2951 SWEEP_FIXED_TYPE_BLOCK (event, struct Lisp_Event);
2955 sweep_markers (void)
2957 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2958 #define ADDITIONAL_FREE_marker(ptr) \
2959 do { Lisp_Object tem; \
2960 XSETMARKER (tem, ptr); \
2961 unchain_marker (tem); \
2964 SWEEP_FIXED_TYPE_BLOCK (marker, struct Lisp_Marker);
2967 /* Explicitly free a marker. */
2969 free_marker (struct Lisp_Marker *ptr)
2971 #ifdef ERROR_CHECK_GC
2972 /* Perhaps this will catch freeing an already-freed marker. */
2974 XSETMARKER (temmy, ptr);
2975 assert (MARKERP (temmy));
2976 #endif /* ERROR_CHECK_GC */
2978 #ifndef ALLOC_NO_POOLS
2979 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr);
2980 #endif /* ALLOC_NO_POOLS */
2984 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2987 verify_string_chars_integrity (void)
2989 struct string_chars_block *sb;
2991 /* Scan each existing string block sequentially, string by string. */
2992 for (sb = first_string_chars_block; sb; sb = sb->next)
2995 /* POS is the index of the next string in the block. */
2996 while (pos < sb->pos)
2998 struct string_chars *s_chars =
2999 (struct string_chars *) &(sb->string_chars[pos]);
3000 struct Lisp_String *string;
3004 /* If the string_chars struct is marked as free (i.e. the STRING
3005 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3006 storage. (See below.) */
3008 if (FREE_STRUCT_P (s_chars))
3010 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3015 string = s_chars->string;
3016 /* Must be 32-bit aligned. */
3017 assert ((((int) string) & 3) == 0);
3019 size = string_length (string);
3020 fullsize = STRING_FULLSIZE (size);
3022 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3023 assert (string_data (string) == s_chars->chars);
3026 assert (pos == sb->pos);
3030 #endif /* MULE && ERROR_CHECK_GC */
3032 /* Compactify string chars, relocating the reference to each --
3033 free any empty string_chars_block we see. */
3035 compact_string_chars (void)
3037 struct string_chars_block *to_sb = first_string_chars_block;
3039 struct string_chars_block *from_sb;
3041 /* Scan each existing string block sequentially, string by string. */
3042 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3045 /* FROM_POS is the index of the next string in the block. */
3046 while (from_pos < from_sb->pos)
3048 struct string_chars *from_s_chars =
3049 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3050 struct string_chars *to_s_chars;
3051 struct Lisp_String *string;
3055 /* If the string_chars struct is marked as free (i.e. the STRING
3056 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3057 storage. This happens under Mule when a string's size changes
3058 in such a way that its fullsize changes. (Strings can change
3059 size because a different-length character can be substituted
3060 for another character.) In this case, after the bogus string
3061 pointer is the "fullsize" of this entry, i.e. how many bytes
3064 if (FREE_STRUCT_P (from_s_chars))
3066 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3067 from_pos += fullsize;
3071 string = from_s_chars->string;
3072 assert (!(FREE_STRUCT_P (string)));
3074 size = string_length (string);
3075 fullsize = STRING_FULLSIZE (size);
3077 if (BIG_STRING_FULLSIZE_P (fullsize))
3080 /* Just skip it if it isn't marked. */
3081 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3083 from_pos += fullsize;
3087 /* If it won't fit in what's left of TO_SB, close TO_SB out
3088 and go on to the next string_chars_block. We know that TO_SB
3089 cannot advance past FROM_SB here since FROM_SB is large enough
3090 to currently contain this string. */
3091 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3093 to_sb->pos = to_pos;
3094 to_sb = to_sb->next;
3098 /* Compute new address of this string
3099 and update TO_POS for the space being used. */
3100 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3102 /* Copy the string_chars to the new place. */
3103 if (from_s_chars != to_s_chars)
3104 memmove (to_s_chars, from_s_chars, fullsize);
3106 /* Relocate FROM_S_CHARS's reference */
3107 set_string_data (string, &(to_s_chars->chars[0]));
3109 from_pos += fullsize;
3114 /* Set current to the last string chars block still used and
3115 free any that follow. */
3117 struct string_chars_block *victim;
3119 for (victim = to_sb->next; victim; )
3121 struct string_chars_block *next = victim->next;
3126 current_string_chars_block = to_sb;
3127 current_string_chars_block->pos = to_pos;
3128 current_string_chars_block->next = 0;
3132 #if 1 /* Hack to debug missing purecopy's */
3133 static int debug_string_purity;
3136 debug_string_purity_print (struct Lisp_String *p)
3139 Charcount s = string_char_length (p);
3140 putc ('\"', stderr);
3141 for (i = 0; i < s; i++)
3143 Emchar ch = string_char (p, i);
3144 if (ch < 32 || ch >= 126)
3145 stderr_out ("\\%03o", ch);
3146 else if (ch == '\\' || ch == '\"')
3147 stderr_out ("\\%c", ch);
3149 stderr_out ("%c", ch);
3151 stderr_out ("\"\n");
3157 sweep_strings (void)
3159 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3160 int debug = debug_string_purity;
3162 #define UNMARK_string(ptr) \
3163 do { struct Lisp_String *p = (ptr); \
3164 int size = string_length (p); \
3165 UNMARK_RECORD_HEADER (&(p->lheader)); \
3166 num_bytes += size; \
3167 if (!BIG_STRING_SIZE_P (size)) \
3168 { num_small_bytes += size; \
3171 if (debug) debug_string_purity_print (p); \
3173 #define ADDITIONAL_FREE_string(p) \
3174 do { int size = string_length (p); \
3175 if (BIG_STRING_SIZE_P (size)) \
3176 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
3179 SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String);
3181 gc_count_num_short_string_in_use = num_small_used;
3182 gc_count_string_total_size = num_bytes;
3183 gc_count_short_string_total_size = num_small_bytes;
3187 /* I hate duplicating all this crap! */
3189 marked_p (Lisp_Object obj)
3191 #ifdef ERROR_CHECK_GC
3192 assert (! (EQ (obj, Qnull_pointer)));
3194 /* Checks we used to perform. */
3195 /* if (EQ (obj, Qnull_pointer)) return 1; */
3196 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3197 /* if (PURIFIED (XPNTR (obj))) return 1; */
3199 if (XTYPE (obj) == Lisp_Type_Record)
3201 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3202 #if defined (ERROR_CHECK_GC)
3203 assert (lheader->type <= last_lrecord_type_index_assigned);
3205 return C_READONLY_RECORD_HEADER_P (lheader) || MARKED_RECORD_HEADER_P (lheader);
3213 /* Free all unmarked records. Do this at the very beginning,
3214 before anything else, so that the finalize methods can safely
3215 examine items in the objects. sweep_lcrecords_1() makes
3216 sure to call all the finalize methods *before* freeing anything,
3217 to complete the safety. */
3220 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3223 compact_string_chars ();
3225 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3226 macros) must be *extremely* careful to make sure they're not
3227 referencing freed objects. The only two existing finalize
3228 methods (for strings and markers) pass muster -- the string
3229 finalizer doesn't look at anything but its own specially-
3230 created block, and the marker finalizer only looks at live
3231 buffers (which will never be freed) and at the markers before
3232 and after it in the chain (which, by induction, will never be
3233 freed because if so, they would have already removed themselves
3236 /* Put all unmarked strings on free list, free'ing the string chars
3237 of large unmarked strings */
3240 /* Put all unmarked conses on free list */
3243 /* Free all unmarked bit vectors */
3244 sweep_bit_vectors_1 (&all_bit_vectors,
3245 &gc_count_num_bit_vector_used,
3246 &gc_count_bit_vector_total_size,
3247 &gc_count_bit_vector_storage);
3249 /* Free all unmarked compiled-function objects */
3250 sweep_compiled_functions ();
3252 #ifdef LISP_FLOAT_TYPE
3253 /* Put all unmarked floats on free list */
3257 /* Put all unmarked symbols on free list */
3260 /* Put all unmarked extents on free list */
3263 /* Put all unmarked markers on free list.
3264 Dechain each one first from the buffer into which it points. */
3270 /* Unmark all dumped objects */
3273 char *p = pdump_rt_list;
3277 pdump_reloc_table *rt = (pdump_reloc_table *)p;
3278 p += sizeof (pdump_reloc_table);
3280 for (i=0; i<rt->count; i++)
3282 UNMARK_RECORD_HEADER ((struct lrecord_header *)(*(EMACS_INT *)p));
3283 p += sizeof (EMACS_INT);
3292 /* Clearing for disksave. */
3295 disksave_object_finalization (void)
3297 /* It's important that certain information from the environment not get
3298 dumped with the executable (pathnames, environment variables, etc.).
3299 To make it easier to tell when this has happened with strings(1) we
3300 clear some known-to-be-garbage blocks of memory, so that leftover
3301 results of old evaluation don't look like potential problems.
3302 But first we set some notable variables to nil and do one more GC,
3303 to turn those strings into garbage.
3306 /* Yeah, this list is pretty ad-hoc... */
3307 Vprocess_environment = Qnil;
3308 Vexec_directory = Qnil;
3309 Vdata_directory = Qnil;
3310 Vsite_directory = Qnil;
3311 Vdoc_directory = Qnil;
3312 Vconfigure_info_directory = Qnil;
3315 /* Vdump_load_path = Qnil; */
3316 /* Release hash tables for locate_file */
3317 Flocate_file_clear_hashing (Qt);
3318 uncache_home_directory();
3320 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3321 defined(LOADHIST_BUILTIN))
3322 Vload_history = Qnil;
3324 Vshell_file_name = Qnil;
3326 garbage_collect_1 ();
3328 /* Run the disksave finalization methods of all live objects. */
3329 disksave_object_finalization_1 ();
3331 /* Zero out the uninitialized (really, unused) part of the containers
3332 for the live strings. */
3334 struct string_chars_block *scb;
3335 for (scb = first_string_chars_block; scb; scb = scb->next)
3337 int count = sizeof (scb->string_chars) - scb->pos;
3339 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3341 /* from the block's fill ptr to the end */
3342 memset ((scb->string_chars + scb->pos), 0, count);
3347 /* There, that ought to be enough... */
3353 restore_gc_inhibit (Lisp_Object val)
3355 gc_currently_forbidden = XINT (val);
3359 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3360 static int gc_hooks_inhibited;
3364 garbage_collect_1 (void)
3366 #if MAX_SAVE_STACK > 0
3367 char stack_top_variable;
3368 extern char *stack_bottom;
3373 Lisp_Object pre_gc_cursor;
3374 struct gcpro gcpro1;
3377 || gc_currently_forbidden
3379 || preparing_for_armageddon)
3382 /* We used to call selected_frame() here.
3384 The following functions cannot be called inside GC
3385 so we move to after the above tests. */
3388 Lisp_Object device = Fselected_device (Qnil);
3389 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3391 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3393 signal_simple_error ("No frames exist on device", device);
3397 pre_gc_cursor = Qnil;
3400 GCPRO1 (pre_gc_cursor);
3402 /* Very important to prevent GC during any of the following
3403 stuff that might run Lisp code; otherwise, we'll likely
3404 have infinite GC recursion. */
3405 speccount = specpdl_depth ();
3406 record_unwind_protect (restore_gc_inhibit,
3407 make_int (gc_currently_forbidden));
3408 gc_currently_forbidden = 1;
3410 if (!gc_hooks_inhibited)
3411 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3413 /* Now show the GC cursor/message. */
3414 if (!noninteractive)
3416 if (FRAME_WIN_P (f))
3418 Lisp_Object frame = make_frame (f);
3419 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3420 FRAME_SELECTED_WINDOW (f),
3422 pre_gc_cursor = f->pointer;
3423 if (POINTER_IMAGE_INSTANCEP (cursor)
3424 /* don't change if we don't know how to change back. */
3425 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3428 Fset_frame_pointer (frame, cursor);
3432 /* Don't print messages to the stream device. */
3433 if (!cursor_changed && !FRAME_STREAM_P (f))
3435 char *msg = (STRINGP (Vgc_message)
3436 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3438 Lisp_Object args[2], whole_msg;
3439 args[0] = build_string (msg ? msg :
3440 GETTEXT ((CONST char *) gc_default_message));
3441 args[1] = build_string ("...");
3442 whole_msg = Fconcat (2, args);
3443 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3444 Qgarbage_collecting);
3448 /***** Now we actually start the garbage collection. */
3452 gc_generation_number[0]++;
3454 #if MAX_SAVE_STACK > 0
3456 /* Save a copy of the contents of the stack, for debugging. */
3459 /* Static buffer in which we save a copy of the C stack at each GC. */
3460 static char *stack_copy;
3461 static size_t stack_copy_size;
3463 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3464 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3465 if (stack_size < MAX_SAVE_STACK)
3467 if (stack_copy_size < stack_size)
3469 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3470 stack_copy_size = stack_size;
3474 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3478 #endif /* MAX_SAVE_STACK > 0 */
3480 /* Do some totally ad-hoc resource clearing. */
3481 /* #### generalize this? */
3482 clear_event_resource ();
3483 cleanup_specifiers ();
3485 /* Mark all the special slots that serve as the roots of accessibility. */
3489 for (i = 0; i < staticidx; i++)
3490 mark_object (*(staticvec[i]));
3491 for (i = 0; i < staticidx_nodump; i++)
3492 mark_object (*(staticvec_nodump[i]));
3498 for (tail = gcprolist; tail; tail = tail->next)
3499 for (i = 0; i < tail->nvars; i++)
3500 mark_object (tail->var[i]);
3504 struct specbinding *bind;
3505 for (bind = specpdl; bind != specpdl_ptr; bind++)
3507 mark_object (bind->symbol);
3508 mark_object (bind->old_value);
3513 struct catchtag *catch;
3514 for (catch = catchlist; catch; catch = catch->next)
3516 mark_object (catch->tag);
3517 mark_object (catch->val);
3522 struct backtrace *backlist;
3523 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3525 int nargs = backlist->nargs;
3528 mark_object (*backlist->function);
3529 if (nargs == UNEVALLED || nargs == MANY)
3530 mark_object (backlist->args[0]);
3532 for (i = 0; i < nargs; i++)
3533 mark_object (backlist->args[i]);
3538 mark_profiling_info ();
3540 /* OK, now do the after-mark stuff. This is for things that
3541 are only marked when something else is marked (e.g. weak hash tables).
3542 There may be complex dependencies between such objects -- e.g.
3543 a weak hash table might be unmarked, but after processing a later
3544 weak hash table, the former one might get marked. So we have to
3545 iterate until nothing more gets marked. */
3547 while (finish_marking_weak_hash_tables () > 0 ||
3548 finish_marking_weak_lists () > 0)
3551 /* And prune (this needs to be called after everything else has been
3552 marked and before we do any sweeping). */
3553 /* #### this is somewhat ad-hoc and should probably be an object
3555 prune_weak_hash_tables ();
3556 prune_weak_lists ();
3557 prune_specifiers ();
3558 prune_syntax_tables ();
3562 consing_since_gc = 0;
3563 #ifndef DEBUG_XEMACS
3564 /* Allow you to set it really fucking low if you really want ... */
3565 if (gc_cons_threshold < 10000)
3566 gc_cons_threshold = 10000;
3571 /******* End of garbage collection ********/
3573 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3575 /* Now remove the GC cursor/message */
3576 if (!noninteractive)
3579 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3580 else if (!FRAME_STREAM_P (f))
3582 char *msg = (STRINGP (Vgc_message)
3583 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3586 /* Show "...done" only if the echo area would otherwise be empty. */
3587 if (NILP (clear_echo_area (selected_frame (),
3588 Qgarbage_collecting, 0)))
3590 Lisp_Object args[2], whole_msg;
3591 args[0] = build_string (msg ? msg :
3592 GETTEXT ((CONST char *)
3593 gc_default_message));
3594 args[1] = build_string ("... done");
3595 whole_msg = Fconcat (2, args);
3596 echo_area_message (selected_frame (), (Bufbyte *) 0,
3598 Qgarbage_collecting);
3603 /* now stop inhibiting GC */
3604 unbind_to (speccount, Qnil);
3606 if (!breathing_space)
3608 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3615 /* Debugging aids. */
3618 gc_plist_hack (CONST char *name, int value, Lisp_Object tail)
3620 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3621 or portable numeric datatypes, or bit-vectors, or characters, or
3622 arrays, or exceptions, or ...) */
3623 return cons3 (intern (name), make_int (value), tail);
3626 #define HACK_O_MATIC(type, name, pl) do { \
3628 struct type##_block *x = current_##type##_block; \
3629 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3630 (pl) = gc_plist_hack ((name), s, (pl)); \
3633 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3634 Reclaim storage for Lisp objects no longer needed.
3635 Return info on amount of space in use:
3636 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3637 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3639 where `PLIST' is a list of alternating keyword/value pairs providing
3640 more detailed information.
3641 Garbage collection happens automatically if you cons more than
3642 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3646 Lisp_Object pl = Qnil;
3648 int gc_count_vector_total_size = 0;
3650 garbage_collect_1 ();
3652 for (i = 0; i <= last_lrecord_type_index_assigned; i++)
3654 if (lcrecord_stats[i].bytes_in_use != 0
3655 || lcrecord_stats[i].bytes_freed != 0
3656 || lcrecord_stats[i].instances_on_free_list != 0)
3659 CONST char *name = lrecord_implementations_table[i]->name;
3660 int len = strlen (name);
3661 /* save this for the FSFmacs-compatible part of the summary */
3662 if (i == *lrecord_vector.lrecord_type_index)
3663 gc_count_vector_total_size =
3664 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3666 sprintf (buf, "%s-storage", name);
3667 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3668 /* Okay, simple pluralization check for `symbol-value-varalias' */
3669 if (name[len-1] == 's')
3670 sprintf (buf, "%ses-freed", name);
3672 sprintf (buf, "%ss-freed", name);
3673 if (lcrecord_stats[i].instances_freed != 0)
3674 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3675 if (name[len-1] == 's')
3676 sprintf (buf, "%ses-on-free-list", name);
3678 sprintf (buf, "%ss-on-free-list", name);
3679 if (lcrecord_stats[i].instances_on_free_list != 0)
3680 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3682 if (name[len-1] == 's')
3683 sprintf (buf, "%ses-used", name);
3685 sprintf (buf, "%ss-used", name);
3686 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3690 HACK_O_MATIC (extent, "extent-storage", pl);
3691 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3692 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3693 HACK_O_MATIC (event, "event-storage", pl);
3694 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3695 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3696 HACK_O_MATIC (marker, "marker-storage", pl);
3697 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3698 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3699 #ifdef LISP_FLOAT_TYPE
3700 HACK_O_MATIC (float, "float-storage", pl);
3701 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3702 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3703 #endif /* LISP_FLOAT_TYPE */
3704 HACK_O_MATIC (string, "string-header-storage", pl);
3705 pl = gc_plist_hack ("long-strings-total-length",
3706 gc_count_string_total_size
3707 - gc_count_short_string_total_size, pl);
3708 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3709 pl = gc_plist_hack ("short-strings-total-length",
3710 gc_count_short_string_total_size, pl);
3711 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3712 pl = gc_plist_hack ("long-strings-used",
3713 gc_count_num_string_in_use
3714 - gc_count_num_short_string_in_use, pl);
3715 pl = gc_plist_hack ("short-strings-used",
3716 gc_count_num_short_string_in_use, pl);
3718 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3719 pl = gc_plist_hack ("compiled-functions-free",
3720 gc_count_num_compiled_function_freelist, pl);
3721 pl = gc_plist_hack ("compiled-functions-used",
3722 gc_count_num_compiled_function_in_use, pl);
3724 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3725 pl = gc_plist_hack ("bit-vectors-total-length",
3726 gc_count_bit_vector_total_size, pl);
3727 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3729 HACK_O_MATIC (symbol, "symbol-storage", pl);
3730 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3731 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3733 HACK_O_MATIC (cons, "cons-storage", pl);
3734 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3735 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3737 /* The things we do for backwards-compatibility */
3739 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3740 make_int (gc_count_num_cons_freelist)),
3741 Fcons (make_int (gc_count_num_symbol_in_use),
3742 make_int (gc_count_num_symbol_freelist)),
3743 Fcons (make_int (gc_count_num_marker_in_use),
3744 make_int (gc_count_num_marker_freelist)),
3745 make_int (gc_count_string_total_size),
3746 make_int (gc_count_vector_total_size),
3751 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3752 Return the number of bytes consed since the last garbage collection.
3753 \"Consed\" is a misnomer in that this actually counts allocation
3754 of all different kinds of objects, not just conses.
3756 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3760 return make_int (consing_since_gc);
3763 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
3764 Return the address of the last byte Emacs has allocated, divided by 1024.
3765 This may be helpful in debugging Emacs's memory usage.
3766 The value is divided by 1024 to make sure it will fit in a lisp integer.
3770 return make_int ((EMACS_INT) sbrk (0) / 1024);
3776 object_dead_p (Lisp_Object obj)
3778 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3779 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3780 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3781 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3782 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3783 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3784 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3787 #ifdef MEMORY_USAGE_STATS
3789 /* Attempt to determine the actual amount of space that is used for
3790 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3792 It seems that the following holds:
3794 1. When using the old allocator (malloc.c):
3796 -- blocks are always allocated in chunks of powers of two. For
3797 each block, there is an overhead of 8 bytes if rcheck is not
3798 defined, 20 bytes if it is defined. In other words, a
3799 one-byte allocation needs 8 bytes of overhead for a total of
3800 9 bytes, and needs to have 16 bytes of memory chunked out for
3803 2. When using the new allocator (gmalloc.c):
3805 -- blocks are always allocated in chunks of powers of two up
3806 to 4096 bytes. Larger blocks are allocated in chunks of
3807 an integral multiple of 4096 bytes. The minimum block
3808 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3809 is defined. There is no per-block overhead, but there
3810 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3813 3. When using the system malloc, anything goes, but they are
3814 generally slower and more space-efficient than the GNU
3815 allocators. One possibly reasonable assumption to make
3816 for want of better data is that sizeof (void *), or maybe
3817 2 * sizeof (void *), is required as overhead and that
3818 blocks are allocated in the minimum required size except
3819 that some minimum block size is imposed (e.g. 16 bytes). */
3822 malloced_storage_size (void *ptr, size_t claimed_size,
3823 struct overhead_stats *stats)
3825 size_t orig_claimed_size = claimed_size;
3829 if (claimed_size < 2 * sizeof (void *))
3830 claimed_size = 2 * sizeof (void *);
3831 # ifdef SUNOS_LOCALTIME_BUG
3832 if (claimed_size < 16)
3835 if (claimed_size < 4096)
3839 /* compute the log base two, more or less, then use it to compute
3840 the block size needed. */
3842 /* It's big, it's heavy, it's wood! */
3843 while ((claimed_size /= 2) != 0)
3846 /* It's better than bad, it's good! */
3852 /* We have to come up with some average about the amount of
3854 if ((size_t) (rand () & 4095) < claimed_size)
3855 claimed_size += 3 * sizeof (void *);
3859 claimed_size += 4095;
3860 claimed_size &= ~4095;
3861 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3864 #elif defined (SYSTEM_MALLOC)
3866 if (claimed_size < 16)
3868 claimed_size += 2 * sizeof (void *);
3870 #else /* old GNU allocator */
3872 # ifdef rcheck /* #### may not be defined here */
3880 /* compute the log base two, more or less, then use it to compute
3881 the block size needed. */
3883 /* It's big, it's heavy, it's wood! */
3884 while ((claimed_size /= 2) != 0)
3887 /* It's better than bad, it's good! */
3895 #endif /* old GNU allocator */
3899 stats->was_requested += orig_claimed_size;
3900 stats->malloc_overhead += claimed_size - orig_claimed_size;
3902 return claimed_size;
3906 fixed_type_block_overhead (size_t size)
3908 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3909 size_t overhead = 0;
3910 size_t storage_size = malloced_storage_size (0, per_block, 0);
3911 while (size >= per_block)
3914 overhead += sizeof (void *) + per_block - storage_size;
3916 if (rand () % per_block < size)
3917 overhead += sizeof (void *) + per_block - storage_size;
3921 #endif /* MEMORY_USAGE_STATS */
3924 /* Initialization */
3926 reinit_alloc_once_early (void)
3928 gc_generation_number[0] = 0;
3929 breathing_space = 0;
3930 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3931 XSETINT (Vgc_message, 0);
3933 ignore_malloc_warnings = 1;
3934 #ifdef DOUG_LEA_MALLOC
3935 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3936 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3937 #if 0 /* Moved to emacs.c */
3938 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3941 init_string_alloc ();
3942 init_string_chars_alloc ();
3944 init_symbol_alloc ();
3945 init_compiled_function_alloc ();
3946 #ifdef LISP_FLOAT_TYPE
3947 init_float_alloc ();
3948 #endif /* LISP_FLOAT_TYPE */
3949 init_marker_alloc ();
3950 init_extent_alloc ();
3951 init_event_alloc ();
3953 ignore_malloc_warnings = 0;
3955 staticidx_nodump = 0;
3959 consing_since_gc = 0;
3961 gc_cons_threshold = 500000; /* XEmacs change */
3963 gc_cons_threshold = 15000; /* debugging */
3965 #ifdef VIRT_ADDR_VARIES
3966 malloc_sbrk_unused = 1<<22; /* A large number */
3967 malloc_sbrk_used = 100000; /* as reasonable as any number */
3968 #endif /* VIRT_ADDR_VARIES */
3969 lrecord_uid_counter = 259;
3970 debug_string_purity = 0;
3973 gc_currently_forbidden = 0;
3974 gc_hooks_inhibited = 0;
3976 #ifdef ERROR_CHECK_TYPECHECK
3977 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3980 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3982 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3984 #endif /* ERROR_CHECK_TYPECHECK */
3988 init_alloc_once_early (void)
3992 reinit_alloc_once_early ();
3994 last_lrecord_type_index_assigned = -1;
3995 for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
3997 lrecord_implementations_table[iii] = 0;
4002 * defined subr lrecords were initialized with lheader->type == 0.
4003 * See subr_lheader_initializer in lisp.h. Force type index 0 to be
4004 * assigned to lrecord_subr so that those predefined indexes match
4007 lrecord_type_index (&lrecord_subr);
4008 assert (*(lrecord_subr.lrecord_type_index) == 0);
4010 * The same is true for symbol_value_forward objects, except the
4013 lrecord_type_index (&lrecord_symbol_value_forward);
4014 assert (*(lrecord_symbol_value_forward.lrecord_type_index) == 1);
4019 int pure_bytes_used = 0;
4028 syms_of_alloc (void)
4030 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
4031 defsymbol (&Qpost_gc_hook, "post-gc-hook");
4032 defsymbol (&Qgarbage_collecting, "garbage-collecting");
4037 DEFSUBR (Fbit_vector);
4038 DEFSUBR (Fmake_byte_code);
4039 DEFSUBR (Fmake_list);
4040 DEFSUBR (Fmake_vector);
4041 DEFSUBR (Fmake_bit_vector);
4042 DEFSUBR (Fmake_string);
4044 DEFSUBR (Fmake_symbol);
4045 DEFSUBR (Fmake_marker);
4046 DEFSUBR (Fpurecopy);
4047 DEFSUBR (Fgarbage_collect);
4048 DEFSUBR (Fmemory_limit);
4049 DEFSUBR (Fconsing_since_gc);
4053 vars_of_alloc (void)
4055 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
4056 *Number of bytes of consing between garbage collections.
4057 \"Consing\" is a misnomer in that this actually counts allocation
4058 of all different kinds of objects, not just conses.
4059 Garbage collection can happen automatically once this many bytes have been
4060 allocated since the last garbage collection. All data types count.
4062 Garbage collection happens automatically when `eval' or `funcall' are
4063 called. (Note that `funcall' is called implicitly as part of evaluation.)
4064 By binding this temporarily to a large number, you can effectively
4065 prevent garbage collection during a part of the program.
4067 See also `consing-since-gc'.
4070 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
4071 Number of bytes of sharable Lisp data allocated so far.
4075 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
4076 Number of bytes of unshared memory allocated in this session.
4079 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
4080 Number of bytes of unshared memory remaining available in this session.
4085 DEFVAR_INT ("debug-allocation", &debug_allocation /*
4086 If non-zero, print out information to stderr about all objects allocated.
4087 See also `debug-allocation-backtrace-length'.
4089 debug_allocation = 0;
4091 DEFVAR_INT ("debug-allocation-backtrace-length",
4092 &debug_allocation_backtrace_length /*
4093 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4095 debug_allocation_backtrace_length = 2;
4098 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4099 Non-nil means loading Lisp code in order to dump an executable.
4100 This means that certain objects should be allocated in readonly space.
4103 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4104 Function or functions to be run just before each garbage collection.
4105 Interrupts, garbage collection, and errors are inhibited while this hook
4106 runs, so be extremely careful in what you add here. In particular, avoid
4107 consing, and do not interact with the user.
4109 Vpre_gc_hook = Qnil;
4111 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4112 Function or functions to be run just after each garbage collection.
4113 Interrupts, garbage collection, and errors are inhibited while this hook
4114 runs, so be extremely careful in what you add here. In particular, avoid
4115 consing, and do not interact with the user.
4117 Vpost_gc_hook = Qnil;
4119 DEFVAR_LISP ("gc-message", &Vgc_message /*
4120 String to print to indicate that a garbage collection is in progress.
4121 This is printed in the echo area. If the selected frame is on a
4122 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4123 image instance) in the domain of the selected frame, the mouse pointer
4124 will change instead of this message being printed.
4126 Vgc_message = build_string (gc_default_message);
4128 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4129 Pointer glyph used to indicate that a garbage collection is in progress.
4130 If the selected window is on a window system and this glyph specifies a
4131 value (i.e. a pointer image instance) in the domain of the selected
4132 window, the pointer will be changed as specified during garbage collection.
4133 Otherwise, a message will be printed in the echo area, as controlled
4139 complex_vars_of_alloc (void)
4141 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
4147 /* The structure of the file
4150 * 256 - dumped objects
4151 * stab_offset - nb_staticpro*(Lisp_Object *) from staticvec
4152 * - nb_staticpro*(relocated Lisp_Object) pointed to by staticpro
4153 * - nb_structdmp*pair(void *, adr) for pointers to structures
4154 * - lrecord_implementations_table[]
4155 * - relocation table
4156 * - wired variable address/value couples with the count preceding the list
4161 EMACS_UINT stab_offset;
4162 EMACS_UINT reloc_address;
4168 char *pdump_start, *pdump_end;
4170 static const unsigned char align_table[256] =
4172 8, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4173 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4174 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4175 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4176 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4177 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4178 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4179 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4180 7, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4181 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4182 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4183 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4184 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4185 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4186 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4187 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0
4190 typedef struct pdump_entry_list_elmt
4192 struct pdump_entry_list_elmt *next;
4197 EMACS_INT save_offset;
4198 } pdump_entry_list_elmt;
4202 pdump_entry_list_elmt *first;
4207 typedef struct pdump_struct_list_elmt
4209 pdump_entry_list list;
4210 const struct struct_description *sdesc;
4211 } pdump_struct_list_elmt;
4215 pdump_struct_list_elmt *list;
4218 } pdump_struct_list;
4220 static pdump_entry_list pdump_object_table[256];
4221 static pdump_entry_list pdump_opaque_data_list;
4222 static pdump_struct_list pdump_struct_table;
4223 static pdump_entry_list_elmt *pdump_qnil;
4225 static int pdump_alert_undump_object[256];
4227 static unsigned long cur_offset;
4228 static size_t max_size;
4229 static int pdump_fd;
4230 static void *pdump_buf;
4232 #define PDUMP_HASHSIZE 200001
4234 static pdump_entry_list_elmt **pdump_hash;
4236 /* Since most pointers are eight bytes aligned, the >>3 allows for a better hash */
4238 pdump_make_hash (const void *obj)
4240 return ((unsigned long)(obj)>>3) % PDUMP_HASHSIZE;
4243 static pdump_entry_list_elmt *
4244 pdump_get_entry (const void *obj)
4246 int pos = pdump_make_hash(obj);
4247 pdump_entry_list_elmt *e;
4248 while ((e = pdump_hash[pos]) != 0)
4254 if (pos == PDUMP_HASHSIZE)
4261 pdump_add_entry (pdump_entry_list *list, const void *obj, size_t size, int count, int is_lrecord)
4263 pdump_entry_list_elmt *e;
4265 int pos = pdump_make_hash (obj);
4267 while ((e = pdump_hash[pos]) != 0)
4273 if (pos == PDUMP_HASHSIZE)
4277 e = malloc (sizeof (pdump_entry_list_elmt));
4279 e->next = list->first;
4283 e->is_lrecord = is_lrecord;
4286 list->count += count;
4287 pdump_hash[pos] = e;
4289 align = align_table[size & 255];
4290 if (align<2 && is_lrecord)
4293 if(align < list->align)
4294 list->align = align;
4297 static pdump_entry_list *
4298 pdump_get_entry_list(const struct struct_description *sdesc)
4301 for(i=0; i<pdump_struct_table.count; i++)
4302 if (pdump_struct_table.list[i].sdesc == sdesc)
4303 return &pdump_struct_table.list[i].list;
4305 if (pdump_struct_table.size <= pdump_struct_table.count)
4307 if (pdump_struct_table.size == -1)
4308 pdump_struct_table.size = 10;
4310 pdump_struct_table.size = pdump_struct_table.size * 2;
4311 pdump_struct_table.list = xrealloc (pdump_struct_table.list,
4312 pdump_struct_table.size*sizeof (pdump_struct_list_elmt));
4314 pdump_struct_table.list[pdump_struct_table.count].list.first = 0;
4315 pdump_struct_table.list[pdump_struct_table.count].list.align = 8;
4316 pdump_struct_table.list[pdump_struct_table.count].list.count = 0;
4317 pdump_struct_table.list[pdump_struct_table.count].sdesc = sdesc;
4319 return &pdump_struct_table.list[pdump_struct_table.count++].list;
4330 static void pdump_backtrace (void)
4333 fprintf (stderr, "pdump backtrace :\n");
4334 for (i=0;i<depth;i++)
4336 if (!backtrace[i].obj)
4337 fprintf (stderr, " - ind. (%d, %d)\n", backtrace[i].position, backtrace[i].offset);
4340 fprintf (stderr, " - %s (%d, %d)\n",
4341 XRECORD_LHEADER_IMPLEMENTATION (backtrace[i].obj)->name,
4342 backtrace[i].position,
4343 backtrace[i].offset);
4348 static void pdump_register_object (Lisp_Object obj);
4349 static void pdump_register_struct (const void *data, const struct struct_description *sdesc, int count);
4352 pdump_get_indirect_count (EMACS_INT code, const struct lrecord_description *idesc, const void *idata)
4357 int line = XD_INDIRECT_VAL (code);
4358 int delta = XD_INDIRECT_DELTA (code);
4360 irdata = ((char *)idata) + idesc[line].offset;
4361 switch (idesc[line].type) {
4363 count = *(size_t *)irdata;
4366 count = *(int *)irdata;
4369 count = *(long *)irdata;
4372 count = *(Bytecount *)irdata;
4375 fprintf (stderr, "Unsupported count type : %d (line = %d, code=%ld)\n", idesc[line].type, line, (long)code);
4384 pdump_register_sub (const void *data, const struct lrecord_description *desc, int me)
4390 for (pos = 0; desc[pos].type != XD_END; pos++)
4392 backtrace[me].position = pos;
4393 backtrace[me].offset = desc[pos].offset;
4395 rdata = ((const char *)data) + desc[pos].offset;
4396 switch(desc[pos].type)
4398 case XD_SPECIFIER_END:
4400 desc = ((const struct Lisp_Specifier *)data)->methods->extra_description;
4406 case XD_LO_RESET_NIL:
4410 case XD_OPAQUE_DATA_PTR:
4412 EMACS_INT count = desc[pos].data1;
4413 if (XD_IS_INDIRECT(count))
4414 count = pdump_get_indirect_count (count, desc, data);
4416 pdump_add_entry (&pdump_opaque_data_list,
4425 const char *str = *(const char **)rdata;
4427 pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
4432 const char *str = *(const char **)rdata;
4433 if ((EMACS_INT)str > 0)
4434 pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
4437 case XD_LISP_OBJECT:
4439 EMACS_INT count = desc[pos].data1;
4441 if (XD_IS_INDIRECT (count))
4442 count = pdump_get_indirect_count (count, desc, data);
4444 for(i=0;i<count;i++) {
4445 const Lisp_Object *pobj = ((const Lisp_Object *)rdata) + i;
4446 Lisp_Object dobj = *pobj;
4448 backtrace[me].offset = (const char *)pobj - (const char *)data;
4449 pdump_register_object (dobj);
4455 EMACS_INT count = desc[pos].data1;
4456 const struct struct_description *sdesc = desc[pos].data2;
4457 const char *dobj = *(const char **)rdata;
4459 if (XD_IS_INDIRECT (count))
4460 count = pdump_get_indirect_count (count, desc, data);
4462 pdump_register_struct (dobj, sdesc, count);
4467 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4475 pdump_register_object (Lisp_Object obj)
4478 !POINTER_TYPE_P (XTYPE (obj)) ||
4479 pdump_get_entry (XRECORD_LHEADER (obj)))
4482 if (XRECORD_LHEADER_IMPLEMENTATION (obj)->description)
4487 fprintf (stderr, "Backtrace overflow, loop ?\n");
4490 backtrace[me].obj = obj;
4491 backtrace[me].position = 0;
4492 backtrace[me].offset = 0;
4494 pdump_add_entry (pdump_object_table + XRECORD_LHEADER (obj)->type,
4495 XRECORD_LHEADER (obj),
4496 XRECORD_LHEADER_IMPLEMENTATION (obj)->static_size ?
4497 XRECORD_LHEADER_IMPLEMENTATION (obj)->static_size :
4498 XRECORD_LHEADER_IMPLEMENTATION (obj)->size_in_bytes_method (XRECORD_LHEADER (obj)),
4501 pdump_register_sub (XRECORD_LHEADER (obj),
4502 XRECORD_LHEADER_IMPLEMENTATION (obj)->description,
4508 pdump_alert_undump_object[XRECORD_LHEADER (obj)->type]++;
4509 fprintf (stderr, "Undumpable object type : %s\n", XRECORD_LHEADER_IMPLEMENTATION (obj)->name);
4515 pdump_register_struct (const void *data, const struct struct_description *sdesc, int count)
4517 if (data && !pdump_get_entry (data))
4523 fprintf (stderr, "Backtrace overflow, loop ?\n");
4526 backtrace[me].obj = 0;
4527 backtrace[me].position = 0;
4528 backtrace[me].offset = 0;
4530 pdump_add_entry (pdump_get_entry_list (sdesc),
4535 for (i=0; i<count; i++)
4537 pdump_register_sub (((char *)data) + sdesc->size*i,
4546 pdump_dump_data (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
4548 size_t size = elmt->size;
4549 int count = elmt->count;
4554 memcpy (pdump_buf, elmt->obj, size*count);
4556 for (i=0; i<count; i++)
4558 char *cur = ((char *)pdump_buf) + i*size;
4560 for (pos = 0; desc[pos].type != XD_END; pos++)
4562 rdata = cur + desc[pos].offset;
4563 switch (desc[pos].type)
4565 case XD_SPECIFIER_END:
4567 desc = ((const struct Lisp_Specifier *)(elmt->obj))->methods->extra_description;
4574 case XD_LO_RESET_NIL:
4576 EMACS_INT count = desc[pos].data1;
4578 if (XD_IS_INDIRECT (count))
4579 count = pdump_get_indirect_count (count, desc, elmt->obj);
4580 for (i=0; i<count; i++)
4581 ((EMACS_INT *)rdata)[i] = pdump_qnil->save_offset;
4586 EMACS_INT val = desc[pos].data1;
4587 if (XD_IS_INDIRECT (val))
4588 val = pdump_get_indirect_count (val, desc, elmt->obj);
4589 *(int *)rdata = val;
4592 case XD_OPAQUE_DATA_PTR:
4596 void *ptr = *(void **)rdata;
4598 *(EMACS_INT *)rdata = pdump_get_entry (ptr)->save_offset;
4603 Lisp_Object obj = *(Lisp_Object *)rdata;
4604 pdump_entry_list_elmt *elmt1;
4607 elmt1 = pdump_get_entry (XRECORD_LHEADER(obj));
4610 obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
4612 *(EMACS_INT *)rdata = elmt1->save_offset;
4615 case XD_LISP_OBJECT:
4617 EMACS_INT count = desc[pos].data1;
4619 if (XD_IS_INDIRECT (count))
4620 count = pdump_get_indirect_count (count, desc, elmt->obj);
4622 for(i=0; i<count; i++)
4624 Lisp_Object *pobj = ((Lisp_Object *)rdata) + i;
4625 Lisp_Object dobj = *pobj;
4626 if (dobj && POINTER_TYPE_P (XTYPE (dobj)))
4627 *pobj = pdump_get_entry (XRECORD_LHEADER (dobj))->save_offset;
4633 EMACS_INT str = *(EMACS_INT *)rdata;
4635 *(EMACS_INT *)rdata = pdump_get_entry ((void *)str)->save_offset;
4639 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4645 write (pdump_fd, desc ? pdump_buf : elmt->obj, size*count);
4646 if (elmt->is_lrecord && ((size*count) & 3))
4647 write (pdump_fd, "\0\0\0", 4-((size*count) & 3));
4651 pdump_reloc_one (void *data, EMACS_INT delta, const struct lrecord_description *desc)
4657 for (pos = 0; desc[pos].type != XD_END; pos++)
4659 rdata = ((char *)data) + desc[pos].offset;
4660 switch (desc[pos].type) {
4661 case XD_SPECIFIER_END:
4663 desc = ((const struct Lisp_Specifier *)data)->methods->extra_description;
4671 case XD_OPAQUE_DATA_PTR:
4676 EMACS_INT ptr = *(EMACS_INT *)rdata;
4678 *(EMACS_INT *)rdata = ptr+delta;
4681 case XD_LISP_OBJECT:
4682 case XD_LO_RESET_NIL:
4684 EMACS_INT count = desc[pos].data1;
4686 if (XD_IS_INDIRECT (count))
4687 count = pdump_get_indirect_count (count, desc, data);
4689 for (i=0; i<count; i++)
4691 Lisp_Object *pobj = ((Lisp_Object *)rdata) + i;
4692 Lisp_Object dobj = *pobj;
4693 if (dobj && POINTER_TYPE_P (XTYPE (dobj)))
4694 *pobj = dobj + delta;
4700 EMACS_INT str = *(EMACS_INT *)rdata;
4702 *(EMACS_INT *)rdata = str + delta;
4706 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4713 pdump_allocate_offset (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
4715 size_t size = (elmt->is_lrecord ? (elmt->size + 3) & ~3 : elmt->size)*elmt->count;
4716 elmt->save_offset = cur_offset;
4723 pdump_scan_by_alignement (void (*f)(pdump_entry_list_elmt *, const struct lrecord_description *))
4726 const struct lrecord_description *idesc;
4727 pdump_entry_list_elmt *elmt;
4728 for (align=8; align>=0; align--)
4730 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4731 if (pdump_object_table[i].align == align)
4733 elmt = pdump_object_table[i].first;
4736 idesc = lrecord_implementations_table[i]->description;
4744 for (i=0; i<pdump_struct_table.count; i++)
4745 if (pdump_struct_table.list[i].list.align == align) {
4746 elmt = pdump_struct_table.list[i].list.first;
4747 idesc = pdump_struct_table.list[i].sdesc->description;
4755 elmt = pdump_opaque_data_list.first;
4758 if (align_table[elmt->size & 255] == align)
4766 pdump_dump_staticvec (void)
4768 Lisp_Object *reloc = malloc (staticidx*sizeof (Lisp_Object));
4770 write (pdump_fd, staticvec, staticidx*sizeof (Lisp_Object *));
4772 for(i=0; i<staticidx; i++)
4774 Lisp_Object obj = *staticvec[i];
4775 if (obj && POINTER_TYPE_P (XTYPE (obj)))
4776 reloc[i] = pdump_get_entry (XRECORD_LHEADER (obj))->save_offset;
4780 write (pdump_fd, reloc, staticidx*sizeof (Lisp_Object));
4785 pdump_dump_structvec (void)
4788 for (i=0; i<dumpstructidx; i++)
4791 write (pdump_fd, &(dumpstructvec[i].data), sizeof (void *));
4792 adr = pdump_get_entry (*(void **)(dumpstructvec[i].data))->save_offset;
4793 write (pdump_fd, &adr, sizeof (adr));
4798 pdump_dump_itable (void)
4800 write (pdump_fd, lrecord_implementations_table, sizeof (lrecord_implementations_table));
4804 pdump_dump_rtables (void)
4807 pdump_entry_list_elmt *elmt;
4808 pdump_reloc_table rt;
4810 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4812 elmt = pdump_object_table[i].first;
4815 rt.desc = lrecord_implementations_table[i]->description;
4816 rt.count = pdump_object_table[i].count;
4817 write (pdump_fd, &rt, sizeof (rt));
4820 EMACS_INT rdata = pdump_get_entry (XRECORD_LHEADER (elmt->obj))->save_offset;
4821 write (pdump_fd, &rdata, sizeof (rdata));
4828 write (pdump_fd, &rt, sizeof (rt));
4830 for (i=0; i<pdump_struct_table.count; i++)
4832 elmt = pdump_struct_table.list[i].list.first;
4833 rt.desc = pdump_struct_table.list[i].sdesc->description;
4834 rt.count = pdump_struct_table.list[i].list.count;
4835 write (pdump_fd, &rt, sizeof (rt));
4838 EMACS_INT rdata = pdump_get_entry (XRECORD_LHEADER (elmt->obj))->save_offset;
4839 for (j=0; j<elmt->count; j++) {
4840 write (pdump_fd, &rdata, sizeof (rdata));
4841 rdata += elmt->size;
4848 write (pdump_fd, &rt, sizeof (rt));
4852 pdump_dump_wired (void)
4854 EMACS_INT count = pdump_wireidx + pdump_wireidx_list;
4857 write (pdump_fd, &count, sizeof (count));
4859 for (i=0; i<pdump_wireidx; i++)
4861 Lisp_Object obj = pdump_get_entry (XRECORD_LHEADER (*(pdump_wirevec[i])))->save_offset;
4862 write (pdump_fd, &pdump_wirevec[i], sizeof (pdump_wirevec[i]));
4863 write (pdump_fd, &obj, sizeof (obj));
4866 for (i=0; i<pdump_wireidx_list; i++)
4868 Lisp_Object obj = *(pdump_wirevec_list[i]);
4869 pdump_entry_list_elmt *elmt;
4874 const struct lrecord_description *desc;
4876 elmt = pdump_get_entry (XRECORD_LHEADER (obj));
4879 desc = XRECORD_LHEADER_IMPLEMENTATION (obj)->description;
4880 for (pos = 0; desc[pos].type != XD_LO_LINK; pos++)
4881 if (desc[pos].type == XD_END)
4884 obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
4886 res = elmt->save_offset;
4888 write (pdump_fd, &pdump_wirevec_list[i], sizeof (pdump_wirevec_list[i]));
4889 write (pdump_fd, &res, sizeof (res));
4897 Lisp_Object t_console, t_device, t_frame;
4901 /* These appear in a DEFVAR_LISP, which does a staticpro() */
4902 t_console = Vterminal_console;
4903 t_frame = Vterminal_frame;
4904 t_device = Vterminal_device;
4906 Vterminal_console = Qnil;
4907 Vterminal_frame = Qnil;
4908 Vterminal_device = Qnil;
4910 pdump_hash = malloc (PDUMP_HASHSIZE*sizeof (pdump_entry_list_elmt *));
4911 memset (pdump_hash, 0, PDUMP_HASHSIZE*sizeof (pdump_entry_list_elmt *));
4913 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4915 pdump_object_table[i].first = 0;
4916 pdump_object_table[i].align = 8;
4917 pdump_object_table[i].count = 0;
4918 pdump_alert_undump_object[i] = 0;
4920 pdump_struct_table.count = 0;
4921 pdump_struct_table.size = -1;
4923 pdump_opaque_data_list.first = 0;
4924 pdump_opaque_data_list.align = 8;
4925 pdump_opaque_data_list.count = 0;
4928 for (i=0; i<staticidx; i++)
4929 pdump_register_object (*staticvec[i]);
4930 for (i=0; i<pdump_wireidx; i++)
4931 pdump_register_object (*pdump_wirevec[i]);
4934 for(i=0;i<=last_lrecord_type_index_assigned;i++)
4935 if (pdump_alert_undump_object[i])
4938 printf ("Undumpable types list :\n");
4940 printf (" - %s (%d)\n", lrecord_implementations_table[i]->name, pdump_alert_undump_object[i]);
4945 for (i=0; i<dumpstructidx; i++)
4946 pdump_register_struct (*(void **)(dumpstructvec[i].data), dumpstructvec[i].desc, 1);
4948 memcpy (hd.signature, "XEmacsDP", 8);
4949 hd.reloc_address = 0;
4950 hd.nb_staticpro = staticidx;
4951 hd.nb_structdmp = dumpstructidx;
4952 hd.last_type = last_lrecord_type_index_assigned;
4957 pdump_scan_by_alignement (pdump_allocate_offset);
4958 pdump_qnil = pdump_get_entry (XRECORD_LHEADER (Qnil));
4960 pdump_buf = malloc (max_size);
4961 pdump_fd = open ("xemacs.dmp", O_WRONLY|O_CREAT|O_TRUNC, 0666);
4962 hd.stab_offset = (cur_offset + 3) & ~3;
4964 write (pdump_fd, &hd, sizeof (hd));
4965 lseek (pdump_fd, 256, SEEK_SET);
4967 pdump_scan_by_alignement (pdump_dump_data);
4969 lseek (pdump_fd, hd.stab_offset, SEEK_SET);
4971 pdump_dump_staticvec ();
4972 pdump_dump_structvec ();
4973 pdump_dump_itable ();
4974 pdump_dump_rtables ();
4975 pdump_dump_wired ();
4982 Vterminal_console = t_console;
4983 Vterminal_frame = t_frame;
4984 Vterminal_device = t_device;
4996 pdump_start = pdump_end = 0;
4998 pdump_fd = open ("xemacs.dmp", O_RDONLY);
5002 length = lseek (pdump_fd, 0, SEEK_END);
5003 lseek (pdump_fd, 0, SEEK_SET);
5006 pdump_start = mmap (0, length, PROT_READ|PROT_WRITE, MAP_PRIVATE, pdump_fd, 0);
5007 if (pdump_start == MAP_FAILED)
5013 pdump_start = (void *)((((unsigned long)(malloc(length+255))) + 255) & ~255);
5014 read(pdump_fd, pdump_start, length);
5019 pdump_end = pdump_start + length;
5021 staticidx = ((dump_header *)(pdump_start))->nb_staticpro;
5022 last_lrecord_type_index_assigned = ((dump_header *)(pdump_start))->last_type;
5023 delta = ((EMACS_INT)pdump_start) - ((dump_header *)pdump_start)->reloc_address;
5024 p = pdump_start + ((dump_header *)pdump_start)->stab_offset;
5026 /* Put back the staticvec in place */
5027 memcpy (staticvec, p, staticidx*sizeof (Lisp_Object *));
5028 p += staticidx*sizeof (Lisp_Object *);
5029 for (i=0; i<staticidx; i++)
5031 Lisp_Object obj = *(Lisp_Object *)p;
5032 p += sizeof (Lisp_Object);
5033 if (obj && POINTER_TYPE_P (XTYPE (obj)))
5035 *staticvec[i] = obj;
5038 /* Put back the dumpstructs */
5039 for (i=0; i<((dump_header *)pdump_start)->nb_structdmp; i++)
5041 void **adr = *(void **)p;
5042 p += sizeof (void *);
5043 *adr = (void *)((*(EMACS_INT *)p) + delta);
5044 p += sizeof (EMACS_INT);
5047 /* Put back the lrecord_implementations_table */
5048 memcpy (lrecord_implementations_table, p, sizeof (lrecord_implementations_table));
5049 p += sizeof (lrecord_implementations_table);
5051 /* Give back their numbers to the lrecord implementations */
5052 for (i=0; i<sizeof(lrecord_implementations_table)/sizeof(lrecord_implementations_table[0]); i++)
5053 if (lrecord_implementations_table[i])
5055 *(lrecord_implementations_table[i]->lrecord_type_index) = i;
5056 last_lrecord_type_index_assigned = i;
5059 /* Do the relocations */
5064 pdump_reloc_table *rt = (pdump_reloc_table *)p;
5065 p += sizeof (pdump_reloc_table);
5067 for (i=0; i<rt->count; i++)
5069 EMACS_INT adr = delta + *(EMACS_INT *)p;
5070 *(EMACS_INT *)p = adr;
5071 pdump_reloc_one ((void *)adr, delta, rt->desc);
5072 p += sizeof (EMACS_INT);
5079 /* Put the pdump_wire variables in place */
5080 count = *(EMACS_INT *)p;
5081 p += sizeof(EMACS_INT);
5083 for (i=0; i<count; i++)
5085 Lisp_Object *var, obj;
5086 var = *(Lisp_Object **)p;
5087 p += sizeof (Lisp_Object *);
5089 obj = *(Lisp_Object *)p;
5090 p += sizeof (Lisp_Object);
5092 if (obj && POINTER_TYPE_P (XTYPE (obj)))
5097 /* Final cleanups */
5098 /* reorganize hash tables */
5102 pdump_reloc_table *rt = (pdump_reloc_table *)p;
5103 p += sizeof (pdump_reloc_table);
5106 if (rt->desc == hash_table_description)
5108 for (i=0; i<rt->count; i++)
5110 struct Lisp_Hash_Table *ht = XHASH_TABLE (*(EMACS_INT *)p);
5111 reorganize_hash_table (ht);
5112 p += sizeof (EMACS_INT);
5116 p += sizeof (EMACS_INT)*rt->count;