1 /* Storage allocation and gc for XEmacs Lisp interpreter.
2 Copyright (C) 1985-1998 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
4 Copyright (C) 1995, 1996 Ben Wing.
6 This file is part of XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from
28 FSF: Original version; a long time ago.
29 Mly: Significantly rewritten to use new 3-bit tags and
30 nicely abstracted object definitions, for 19.8.
31 JWZ: Improved code to keep track of purespace usage and
32 issue nice purespace and GC stats.
33 Ben Wing: Cleaned up frob-block lrecord code, added error-checking
34 and various changes for Mule, for 19.12.
35 Added bit vectors for 19.13.
36 Added lcrecord lists for 19.14.
37 slb: Lots of work on the purification and dump time code.
38 Synched Doug Lea malloc support from Emacs 20.2.
39 og: Killed the purespace. Portable dumper.
45 #include "backtrace.h"
56 #include "redisplay.h"
57 #include "specifier.h"
60 #include "console-stream.h"
62 #ifdef DOUG_LEA_MALLOC
74 const struct lrecord_description *desc;
78 static char *pdump_rt_list = 0;
81 EXFUN (Fgarbage_collect, 0);
83 #if 0 /* this is _way_ too slow to be part of the standard debug options */
84 #if defined(DEBUG_XEMACS) && defined(MULE)
85 #define VERIFY_STRING_CHARS_INTEGRITY
89 /* Define this to use malloc/free with no freelist for all datatypes,
90 the hope being that some debugging tools may help detect
91 freed memory references */
92 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
94 #define ALLOC_NO_POOLS
98 static int debug_allocation;
99 static int debug_allocation_backtrace_length;
102 /* Number of bytes of consing done since the last gc */
103 EMACS_INT consing_since_gc;
104 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
106 #define debug_allocation_backtrace() \
108 if (debug_allocation_backtrace_length > 0) \
109 debug_short_backtrace (debug_allocation_backtrace_length); \
113 #define INCREMENT_CONS_COUNTER(foosize, type) \
115 if (debug_allocation) \
117 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
118 debug_allocation_backtrace (); \
120 INCREMENT_CONS_COUNTER_1 (foosize); \
122 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
124 if (debug_allocation > 1) \
126 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
127 debug_allocation_backtrace (); \
129 INCREMENT_CONS_COUNTER_1 (foosize); \
132 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
133 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
134 INCREMENT_CONS_COUNTER_1 (size)
137 #define DECREMENT_CONS_COUNTER(size) do { \
138 consing_since_gc -= (size); \
139 if (consing_since_gc < 0) \
140 consing_since_gc = 0; \
143 /* Number of bytes of consing since gc before another gc should be done. */
144 EMACS_INT gc_cons_threshold;
146 /* Nonzero during gc */
149 /* Number of times GC has happened at this level or below.
150 * Level 0 is most volatile, contrary to usual convention.
151 * (Of course, there's only one level at present) */
152 EMACS_INT gc_generation_number[1];
154 /* This is just for use by the printer, to allow things to print uniquely */
155 static int lrecord_uid_counter;
157 /* Nonzero when calling certain hooks or doing other things where
159 int gc_currently_forbidden;
162 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
163 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
165 /* "Garbage collecting" */
166 Lisp_Object Vgc_message;
167 Lisp_Object Vgc_pointer_glyph;
168 static const char gc_default_message[] = "Garbage collecting";
169 Lisp_Object Qgarbage_collecting;
171 #ifndef VIRT_ADDR_VARIES
173 #endif /* VIRT_ADDR_VARIES */
174 EMACS_INT malloc_sbrk_used;
176 #ifndef VIRT_ADDR_VARIES
178 #endif /* VIRT_ADDR_VARIES */
179 EMACS_INT malloc_sbrk_unused;
181 /* Non-zero means we're in the process of doing the dump */
184 #ifdef ERROR_CHECK_TYPECHECK
186 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
191 c_readonly (Lisp_Object obj)
193 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
197 lisp_readonly (Lisp_Object obj)
199 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
203 /* Maximum amount of C stack to save when a GC happens. */
205 #ifndef MAX_SAVE_STACK
206 #define MAX_SAVE_STACK 0 /* 16000 */
209 /* Non-zero means ignore malloc warnings. Set during initialization. */
210 int ignore_malloc_warnings;
213 static void *breathing_space;
216 release_breathing_space (void)
220 void *tmp = breathing_space;
226 /* malloc calls this if it finds we are near exhausting storage */
228 malloc_warning (const char *str)
230 if (ignore_malloc_warnings)
236 "Killing some buffers may delay running out of memory.\n"
237 "However, certainly by the time you receive the 95%% warning,\n"
238 "you should clean up, kill this Emacs, and start a new one.",
242 /* Called if malloc returns zero */
246 /* Force a GC next time eval is called.
247 It's better to loop garbage-collecting (we might reclaim enough
248 to win) than to loop beeping and barfing "Memory exhausted"
250 consing_since_gc = gc_cons_threshold + 1;
251 release_breathing_space ();
253 /* Flush some histories which might conceivably contain garbalogical
255 if (!NILP (Fboundp (Qvalues)))
256 Fset (Qvalues, Qnil);
257 Vcommand_history = Qnil;
259 error ("Memory exhausted");
262 /* like malloc and realloc but check for no memory left, and block input. */
266 xmalloc (size_t size)
268 void *val = malloc (size);
270 if (!val && (size != 0)) memory_full ();
276 xcalloc (size_t nelem, size_t elsize)
278 void *val = calloc (nelem, elsize);
280 if (!val && (nelem != 0)) memory_full ();
285 xmalloc_and_zero (size_t size)
287 return xcalloc (size, sizeof (char));
292 xrealloc (void *block, size_t size)
294 /* We must call malloc explicitly when BLOCK is 0, since some
295 reallocs don't do this. */
296 void *val = block ? realloc (block, size) : malloc (size);
298 if (!val && (size != 0)) memory_full ();
303 #ifdef ERROR_CHECK_MALLOC
304 xfree_1 (void *block)
309 #ifdef ERROR_CHECK_MALLOC
310 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
311 error until much later on for many system mallocs, such as
312 the one that comes with Solaris 2.3. FMH!! */
313 assert (block != (void *) 0xDEADBEEF);
315 #endif /* ERROR_CHECK_MALLOC */
319 #ifdef ERROR_CHECK_GC
322 typedef unsigned int four_byte_t;
323 #elif SIZEOF_LONG == 4
324 typedef unsigned long four_byte_t;
325 #elif SIZEOF_SHORT == 4
326 typedef unsigned short four_byte_t;
328 What kind of strange-ass system are we running on?
332 deadbeef_memory (void *ptr, size_t size)
334 four_byte_t *ptr4 = (four_byte_t *) ptr;
335 size_t beefs = size >> 2;
337 /* In practice, size will always be a multiple of four. */
339 (*ptr4++) = 0xDEADBEEF;
342 #else /* !ERROR_CHECK_GC */
345 #define deadbeef_memory(ptr, size)
347 #endif /* !ERROR_CHECK_GC */
351 xstrdup (const char *str)
353 int len = strlen (str) + 1; /* for stupid terminating 0 */
355 void *val = xmalloc (len);
356 if (val == 0) return 0;
357 return (char *) memcpy (val, str, len);
362 strdup (const char *s)
366 #endif /* NEED_STRDUP */
370 allocate_lisp_storage (size_t size)
372 return xmalloc (size);
376 /* lcrecords are chained together through their "next" field.
377 After doing the mark phase, GC will walk this linked list
378 and free any lcrecord which hasn't been marked. */
379 static struct lcrecord_header *all_lcrecords;
382 alloc_lcrecord (size_t size, const struct lrecord_implementation *implementation)
384 struct lcrecord_header *lcheader;
387 ((implementation->static_size == 0 ?
388 implementation->size_in_bytes_method != NULL :
389 implementation->static_size == size)
391 (! implementation->basic_p)
393 (! (implementation->hash == NULL && implementation->equal != NULL)));
395 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
396 set_lheader_implementation (&(lcheader->lheader), implementation);
397 lcheader->next = all_lcrecords;
398 #if 1 /* mly prefers to see small ID numbers */
399 lcheader->uid = lrecord_uid_counter++;
400 #else /* jwz prefers to see real addrs */
401 lcheader->uid = (int) &lcheader;
404 all_lcrecords = lcheader;
405 INCREMENT_CONS_COUNTER (size, implementation->name);
409 #if 0 /* Presently unused */
410 /* Very, very poor man's EGC?
411 * This may be slow and thrash pages all over the place.
412 * Only call it if you really feel you must (and if the
413 * lrecord was fairly recently allocated).
414 * Otherwise, just let the GC do its job -- that's what it's there for
417 free_lcrecord (struct lcrecord_header *lcrecord)
419 if (all_lcrecords == lcrecord)
421 all_lcrecords = lcrecord->next;
425 struct lrecord_header *header = all_lcrecords;
428 struct lrecord_header *next = header->next;
429 if (next == lcrecord)
431 header->next = lrecord->next;
440 if (lrecord->implementation->finalizer)
441 lrecord->implementation->finalizer (lrecord, 0);
449 disksave_object_finalization_1 (void)
451 struct lcrecord_header *header;
453 for (header = all_lcrecords; header; header = header->next)
455 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
457 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
462 /************************************************************************/
463 /* Debugger support */
464 /************************************************************************/
465 /* Give gdb/dbx enough information to decode Lisp Objects. We make
466 sure certain symbols are always defined, so gdb doesn't complain
467 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
468 to see how this is used. */
470 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
471 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
473 #ifdef USE_UNION_TYPE
474 unsigned char dbg_USE_UNION_TYPE = 1;
476 unsigned char dbg_USE_UNION_TYPE = 0;
479 unsigned char dbg_valbits = VALBITS;
480 unsigned char dbg_gctypebits = GCTYPEBITS;
482 /* Macros turned into functions for ease of debugging.
483 Debuggers don't know about macros! */
484 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
486 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
488 return EQ (obj1, obj2);
492 /************************************************************************/
493 /* Fixed-size type macros */
494 /************************************************************************/
496 /* For fixed-size types that are commonly used, we malloc() large blocks
497 of memory at a time and subdivide them into chunks of the correct
498 size for an object of that type. This is more efficient than
499 malloc()ing each object separately because we save on malloc() time
500 and overhead due to the fewer number of malloc()ed blocks, and
501 also because we don't need any extra pointers within each object
502 to keep them threaded together for GC purposes. For less common
503 (and frequently large-size) types, we use lcrecords, which are
504 malloc()ed individually and chained together through a pointer
505 in the lcrecord header. lcrecords do not need to be fixed-size
506 (i.e. two objects of the same type need not have the same size;
507 however, the size of a particular object cannot vary dynamically).
508 It is also much easier to create a new lcrecord type because no
509 additional code needs to be added to alloc.c. Finally, lcrecords
510 may be more efficient when there are only a small number of them.
512 The types that are stored in these large blocks (or "frob blocks")
513 are cons, float, compiled-function, symbol, marker, extent, event,
516 Note that strings are special in that they are actually stored in
517 two parts: a structure containing information about the string, and
518 the actual data associated with the string. The former structure
519 (a struct Lisp_String) is a fixed-size structure and is managed the
520 same way as all the other such types. This structure contains a
521 pointer to the actual string data, which is stored in structures of
522 type struct string_chars_block. Each string_chars_block consists
523 of a pointer to a struct Lisp_String, followed by the data for that
524 string, followed by another pointer to a Lisp_String, followed by
525 the data for that string, etc. At GC time, the data in these
526 blocks is compacted by searching sequentially through all the
527 blocks and compressing out any holes created by unmarked strings.
528 Strings that are more than a certain size (bigger than the size of
529 a string_chars_block, although something like half as big might
530 make more sense) are malloc()ed separately and not stored in
531 string_chars_blocks. Furthermore, no one string stretches across
532 two string_chars_blocks.
534 Vectors are each malloc()ed separately, similar to lcrecords.
536 In the following discussion, we use conses, but it applies equally
537 well to the other fixed-size types.
539 We store cons cells inside of cons_blocks, allocating a new
540 cons_block with malloc() whenever necessary. Cons cells reclaimed
541 by GC are put on a free list to be reallocated before allocating
542 any new cons cells from the latest cons_block. Each cons_block is
543 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
544 the versions in malloc.c and gmalloc.c) really allocates in units
545 of powers of two and uses 4 bytes for its own overhead.
547 What GC actually does is to search through all the cons_blocks,
548 from the most recently allocated to the oldest, and put all
549 cons cells that are not marked (whether or not they're already
550 free) on a cons_free_list. The cons_free_list is a stack, and
551 so the cons cells in the oldest-allocated cons_block end up
552 at the head of the stack and are the first to be reallocated.
553 If any cons_block is entirely free, it is freed with free()
554 and its cons cells removed from the cons_free_list. Because
555 the cons_free_list ends up basically in memory order, we have
556 a high locality of reference (assuming a reasonable turnover
557 of allocating and freeing) and have a reasonable probability
558 of entirely freeing up cons_blocks that have been more recently
559 allocated. This stage is called the "sweep stage" of GC, and
560 is executed after the "mark stage", which involves starting
561 from all places that are known to point to in-use Lisp objects
562 (e.g. the obarray, where are all symbols are stored; the
563 current catches and condition-cases; the backtrace list of
564 currently executing functions; the gcpro list; etc.) and
565 recursively marking all objects that are accessible.
567 At the beginning of the sweep stage, the conses in the cons
568 blocks are in one of three states: in use and marked, in use
569 but not marked, and not in use (already freed). Any conses
570 that are marked have been marked in the mark stage just
571 executed, because as part of the sweep stage we unmark any
572 marked objects. The way we tell whether or not a cons cell
573 is in use is through the FREE_STRUCT_P macro. This basically
574 looks at the first 4 bytes (or however many bytes a pointer
575 fits in) to see if all the bits in those bytes are 1. The
576 resulting value (0xFFFFFFFF) is not a valid pointer and is
577 not a valid Lisp_Object. All current fixed-size types have
578 a pointer or Lisp_Object as their first element with the
579 exception of strings; they have a size value, which can
580 never be less than zero, and so 0xFFFFFFFF is invalid for
581 strings as well. Now assuming that a cons cell is in use,
582 the way we tell whether or not it is marked is to look at
583 the mark bit of its car (each Lisp_Object has one bit
584 reserved as a mark bit, in case it's needed). Note that
585 different types of objects use different fields to indicate
586 whether the object is marked, but the principle is the same.
588 Conses on the free_cons_list are threaded through a pointer
589 stored in the bytes directly after the bytes that are set
590 to 0xFFFFFFFF (we cannot overwrite these because the cons
591 is still in a cons_block and needs to remain marked as
592 not in use for the next time that GC happens). This
593 implies that all fixed-size types must be at least big
594 enough to store two pointers, which is indeed the case
595 for all current fixed-size types.
597 Some types of objects need additional "finalization" done
598 when an object is converted from in use to not in use;
599 this is the purpose of the ADDITIONAL_FREE_type macro.
600 For example, markers need to be removed from the chain
601 of markers that is kept in each buffer. This is because
602 markers in a buffer automatically disappear if the marker
603 is no longer referenced anywhere (the same does not
604 apply to extents, however).
606 WARNING: Things are in an extremely bizarre state when
607 the ADDITIONAL_FREE_type macros are called, so beware!
609 When ERROR_CHECK_GC is defined, we do things differently
610 so as to maximize our chances of catching places where
611 there is insufficient GCPROing. The thing we want to
612 avoid is having an object that we're using but didn't
613 GCPRO get freed by GC and then reallocated while we're
614 in the process of using it -- this will result in something
615 seemingly unrelated getting trashed, and is extremely
616 difficult to track down. If the object gets freed but
617 not reallocated, we can usually catch this because we
618 set all bytes of a freed object to 0xDEADBEEF. (The
619 first four bytes, however, are 0xFFFFFFFF, and the next
620 four are a pointer used to chain freed objects together;
621 we play some tricks with this pointer to make it more
622 bogus, so crashes are more likely to occur right away.)
624 We want freed objects to stay free as long as possible,
625 so instead of doing what we do above, we maintain the
626 free objects in a first-in first-out queue. We also
627 don't recompute the free list each GC, unlike above;
628 this ensures that the queue ordering is preserved.
629 [This means that we are likely to have worse locality
630 of reference, and that we can never free a frob block
631 once it's allocated. (Even if we know that all cells
632 in it are free, there's no easy way to remove all those
633 cells from the free list because the objects on the
634 free list are unlikely to be in memory order.)]
635 Furthermore, we never take objects off the free list
636 unless there's a large number (usually 1000, but
637 varies depending on type) of them already on the list.
638 This way, we ensure that an object that gets freed will
639 remain free for the next 1000 (or whatever) times that
640 an object of that type is allocated. */
642 #ifndef MALLOC_OVERHEAD
644 #define MALLOC_OVERHEAD 0
645 #elif defined (rcheck)
646 #define MALLOC_OVERHEAD 20
648 #define MALLOC_OVERHEAD 8
650 #endif /* MALLOC_OVERHEAD */
652 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
653 /* If we released our reserve (due to running out of memory),
654 and we have a fair amount free once again,
655 try to set aside another reserve in case we run out once more.
657 This is called when a relocatable block is freed in ralloc.c. */
658 void refill_memory_reserve (void);
660 refill_memory_reserve ()
662 if (breathing_space == 0)
663 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
667 #ifdef ALLOC_NO_POOLS
668 # define TYPE_ALLOC_SIZE(type, structtype) 1
670 # define TYPE_ALLOC_SIZE(type, structtype) \
671 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
672 / sizeof (structtype))
673 #endif /* ALLOC_NO_POOLS */
675 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
677 struct type##_block \
679 struct type##_block *prev; \
680 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
683 static struct type##_block *current_##type##_block; \
684 static int current_##type##_block_index; \
686 static structtype *type##_free_list; \
687 static structtype *type##_free_list_tail; \
690 init_##type##_alloc (void) \
692 current_##type##_block = 0; \
693 current_##type##_block_index = \
694 countof (current_##type##_block->block); \
695 type##_free_list = 0; \
696 type##_free_list_tail = 0; \
699 static int gc_count_num_##type##_in_use; \
700 static int gc_count_num_##type##_freelist
702 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
703 if (current_##type##_block_index \
704 == countof (current_##type##_block->block)) \
706 struct type##_block *AFTFB_new = (struct type##_block *) \
707 allocate_lisp_storage (sizeof (struct type##_block)); \
708 AFTFB_new->prev = current_##type##_block; \
709 current_##type##_block = AFTFB_new; \
710 current_##type##_block_index = 0; \
713 &(current_##type##_block->block[current_##type##_block_index++]); \
716 /* Allocate an instance of a type that is stored in blocks.
717 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
720 #ifdef ERROR_CHECK_GC
722 /* Note: if you get crashes in this function, suspect incorrect calls
723 to free_cons() and friends. This happened once because the cons
724 cell was not GC-protected and was getting collected before
725 free_cons() was called. */
727 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
730 if (gc_count_num_##type##_freelist > \
731 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
733 result = type##_free_list; \
734 /* Before actually using the chain pointer, we complement all its \
735 bits; see FREE_FIXED_TYPE(). */ \
737 (structtype *) ~(unsigned long) \
738 (* (structtype **) ((char *) result + sizeof (void *))); \
739 gc_count_num_##type##_freelist--; \
742 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
743 MARK_STRUCT_AS_NOT_FREE (result); \
746 #else /* !ERROR_CHECK_GC */
748 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
751 if (type##_free_list) \
753 result = type##_free_list; \
755 * (structtype **) ((char *) result + sizeof (void *)); \
758 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
759 MARK_STRUCT_AS_NOT_FREE (result); \
762 #endif /* !ERROR_CHECK_GC */
764 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
767 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
768 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
771 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
774 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
775 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
778 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
779 to a Lisp object and invalid as an actual Lisp_Object value. We have
780 to make sure that this value cannot be an integer in Lisp_Object form.
781 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
782 On a 32-bit system, the type bits will be non-zero, making the value
783 be a pointer, and the pointer will be misaligned.
785 Even if Emacs is run on some weirdo system that allows and allocates
786 byte-aligned pointers, this pointer is at the very top of the address
787 space and so it's almost inconceivable that it could ever be valid. */
790 # define INVALID_POINTER_VALUE 0xFFFFFFFF
792 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
794 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
796 You have some weird system and need to supply a reasonable value here.
799 #define FREE_STRUCT_P(ptr) \
800 (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
801 #define MARK_STRUCT_AS_FREE(ptr) \
802 (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
803 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
804 (* (void **) ptr = 0)
806 #ifdef ERROR_CHECK_GC
808 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
809 do { if (type##_free_list_tail) \
811 /* When we store the chain pointer, we complement all \
812 its bits; this should significantly increase its \
813 bogosity in case someone tries to use the value, and \
814 should make us dump faster if someone stores something \
815 over the pointer because when it gets un-complemented in \
816 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
817 extremely bogus. */ \
819 ((char *) type##_free_list_tail + sizeof (void *)) = \
820 (structtype *) ~(unsigned long) ptr; \
823 type##_free_list = ptr; \
824 type##_free_list_tail = ptr; \
827 #else /* !ERROR_CHECK_GC */
829 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
830 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
832 type##_free_list = (ptr); \
835 #endif /* !ERROR_CHECK_GC */
837 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
839 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
840 structtype *FFT_ptr = (ptr); \
841 ADDITIONAL_FREE_##type (FFT_ptr); \
842 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
843 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
844 MARK_STRUCT_AS_FREE (FFT_ptr); \
847 /* Like FREE_FIXED_TYPE() but used when we are explicitly
848 freeing a structure through free_cons(), free_marker(), etc.
849 rather than through the normal process of sweeping.
850 We attempt to undo the changes made to the allocation counters
851 as a result of this structure being allocated. This is not
852 completely necessary but helps keep things saner: e.g. this way,
853 repeatedly allocating and freeing a cons will not result in
854 the consing-since-gc counter advancing, which would cause a GC
855 and somewhat defeat the purpose of explicitly freeing. */
857 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
858 do { FREE_FIXED_TYPE (type, structtype, ptr); \
859 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
860 gc_count_num_##type##_freelist++; \
865 /************************************************************************/
866 /* Cons allocation */
867 /************************************************************************/
869 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
870 /* conses are used and freed so often that we set this really high */
871 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
872 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
875 mark_cons (Lisp_Object obj)
877 if (NILP (XCDR (obj)))
880 mark_object (XCAR (obj));
885 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
888 while (internal_equal (XCAR (ob1), XCAR (ob2), depth))
892 if (! CONSP (ob1) || ! CONSP (ob2))
893 return internal_equal (ob1, ob2, depth);
898 static const struct lrecord_description cons_description[] = {
899 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
900 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
904 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
905 mark_cons, print_cons, 0,
908 * No `hash' method needed.
909 * internal_hash knows how to
916 DEFUN ("cons", Fcons, 2, 2, 0, /*
917 Create a new cons, give it CAR and CDR as components, and return it.
921 /* This cannot GC. */
925 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
926 set_lheader_implementation (&(c->lheader), &lrecord_cons);
933 /* This is identical to Fcons() but it used for conses that we're
934 going to free later, and is useful when trying to track down
937 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
942 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
943 set_lheader_implementation (&(c->lheader), &lrecord_cons);
950 DEFUN ("list", Flist, 0, MANY, 0, /*
951 Return a newly created list with specified arguments as elements.
952 Any number of arguments, even zero arguments, are allowed.
954 (int nargs, Lisp_Object *args))
956 Lisp_Object val = Qnil;
957 Lisp_Object *argp = args + nargs;
960 val = Fcons (*--argp, val);
965 list1 (Lisp_Object obj0)
967 /* This cannot GC. */
968 return Fcons (obj0, Qnil);
972 list2 (Lisp_Object obj0, Lisp_Object obj1)
974 /* This cannot GC. */
975 return Fcons (obj0, Fcons (obj1, Qnil));
979 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
981 /* This cannot GC. */
982 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
986 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
988 /* This cannot GC. */
989 return Fcons (obj0, Fcons (obj1, obj2));
993 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
995 return Fcons (Fcons (key, value), alist);
999 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1001 /* This cannot GC. */
1002 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1006 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1009 /* This cannot GC. */
1010 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1014 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1015 Lisp_Object obj4, Lisp_Object obj5)
1017 /* This cannot GC. */
1018 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1021 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1022 Return a new list of length LENGTH, with each element being INIT.
1026 CHECK_NATNUM (length);
1029 Lisp_Object val = Qnil;
1030 size_t size = XINT (length);
1033 val = Fcons (init, val);
1039 /************************************************************************/
1040 /* Float allocation */
1041 /************************************************************************/
1043 #ifdef LISP_FLOAT_TYPE
1045 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
1046 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1049 make_float (double float_value)
1054 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
1056 /* Avoid dump-time `uninitialized memory read' purify warnings. */
1057 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1060 set_lheader_implementation (&(f->lheader), &lrecord_float);
1061 float_data (f) = float_value;
1066 #endif /* LISP_FLOAT_TYPE */
1069 /************************************************************************/
1070 /* Vector allocation */
1071 /************************************************************************/
1074 mark_vector (Lisp_Object obj)
1076 Lisp_Vector *ptr = XVECTOR (obj);
1077 int len = vector_length (ptr);
1080 for (i = 0; i < len - 1; i++)
1081 mark_object (ptr->contents[i]);
1082 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1086 size_vector (const void *lheader)
1088 return offsetof (Lisp_Vector, contents[((Lisp_Vector *) lheader)->size]);
1092 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1094 int len = XVECTOR_LENGTH (obj1);
1095 if (len != XVECTOR_LENGTH (obj2))
1099 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1100 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1102 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1109 vector_hash (Lisp_Object obj, int depth)
1111 return HASH2 (XVECTOR_LENGTH (obj),
1112 internal_array_hash (XVECTOR_DATA (obj),
1113 XVECTOR_LENGTH (obj),
1117 static const struct lrecord_description vector_description[] = {
1118 { XD_LONG, offsetof (Lisp_Vector, size) },
1119 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1123 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1124 mark_vector, print_vector, 0,
1128 size_vector, Lisp_Vector);
1130 /* #### should allocate `small' vectors from a frob-block */
1131 static Lisp_Vector *
1132 make_vector_internal (size_t sizei)
1134 /* no vector_next */
1135 size_t sizem = offsetof (Lisp_Vector, contents[sizei]);
1136 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1143 make_vector (size_t length, Lisp_Object init)
1145 Lisp_Vector *vecp = make_vector_internal (length);
1146 Lisp_Object *p = vector_data (vecp);
1153 XSETVECTOR (vector, vecp);
1158 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1159 Return a new vector of length LENGTH, with each element being INIT.
1160 See also the function `vector'.
1164 CONCHECK_NATNUM (length);
1165 return make_vector (XINT (length), init);
1168 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1169 Return a newly created vector with specified arguments as elements.
1170 Any number of arguments, even zero arguments, are allowed.
1172 (int nargs, Lisp_Object *args))
1174 Lisp_Vector *vecp = make_vector_internal (nargs);
1175 Lisp_Object *p = vector_data (vecp);
1182 XSETVECTOR (vector, vecp);
1188 vector1 (Lisp_Object obj0)
1190 return Fvector (1, &obj0);
1194 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1196 Lisp_Object args[2];
1199 return Fvector (2, args);
1203 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1205 Lisp_Object args[3];
1209 return Fvector (3, args);
1212 #if 0 /* currently unused */
1215 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1218 Lisp_Object args[4];
1223 return Fvector (4, args);
1227 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1228 Lisp_Object obj3, Lisp_Object obj4)
1230 Lisp_Object args[5];
1236 return Fvector (5, args);
1240 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1241 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1243 Lisp_Object args[6];
1250 return Fvector (6, args);
1254 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1255 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1258 Lisp_Object args[7];
1266 return Fvector (7, args);
1270 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1271 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1272 Lisp_Object obj6, Lisp_Object obj7)
1274 Lisp_Object args[8];
1283 return Fvector (8, args);
1287 /************************************************************************/
1288 /* Bit Vector allocation */
1289 /************************************************************************/
1291 static Lisp_Object all_bit_vectors;
1293 /* #### should allocate `small' bit vectors from a frob-block */
1294 static Lisp_Bit_Vector *
1295 make_bit_vector_internal (size_t sizei)
1297 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1298 size_t sizem = offsetof (Lisp_Bit_Vector, bits[num_longs]);
1299 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1300 set_lheader_implementation (&(p->lheader), &lrecord_bit_vector);
1302 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1304 bit_vector_length (p) = sizei;
1305 bit_vector_next (p) = all_bit_vectors;
1306 /* make sure the extra bits in the last long are 0; the calling
1307 functions might not set them. */
1308 p->bits[num_longs - 1] = 0;
1309 XSETBIT_VECTOR (all_bit_vectors, p);
1314 make_bit_vector (size_t length, Lisp_Object init)
1316 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1317 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1322 memset (p->bits, 0, num_longs * sizeof (long));
1325 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1326 memset (p->bits, ~0, num_longs * sizeof (long));
1327 /* But we have to make sure that the unused bits in the
1328 last long are 0, so that equal/hash is easy. */
1330 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1334 Lisp_Object bit_vector;
1335 XSETBIT_VECTOR (bit_vector, p);
1341 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1344 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1346 for (i = 0; i < length; i++)
1347 set_bit_vector_bit (p, i, bytevec[i]);
1350 Lisp_Object bit_vector;
1351 XSETBIT_VECTOR (bit_vector, p);
1356 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1357 Return a new bit vector of length LENGTH. with each bit being INIT.
1358 Each element is set to INIT. See also the function `bit-vector'.
1362 CONCHECK_NATNUM (length);
1364 return make_bit_vector (XINT (length), init);
1367 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1368 Return a newly created bit vector with specified arguments as elements.
1369 Any number of arguments, even zero arguments, are allowed.
1371 (int nargs, Lisp_Object *args))
1374 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1376 for (i = 0; i < nargs; i++)
1378 CHECK_BIT (args[i]);
1379 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1383 Lisp_Object bit_vector;
1384 XSETBIT_VECTOR (bit_vector, p);
1390 /************************************************************************/
1391 /* Compiled-function allocation */
1392 /************************************************************************/
1394 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1395 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1398 make_compiled_function (void)
1400 Lisp_Compiled_Function *f;
1403 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1404 set_lheader_implementation (&(f->lheader), &lrecord_compiled_function);
1407 f->specpdl_depth = 0;
1408 f->flags.documentationp = 0;
1409 f->flags.interactivep = 0;
1410 f->flags.domainp = 0; /* I18N3 */
1411 f->instructions = Qzero;
1412 f->constants = Qzero;
1414 f->doc_and_interactive = Qnil;
1415 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1416 f->annotated = Qnil;
1418 XSETCOMPILED_FUNCTION (fun, f);
1422 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1423 Return a new compiled-function object.
1424 Usage: (arglist instructions constants stack-depth
1425 &optional doc-string interactive)
1426 Note that, unlike all other emacs-lisp functions, calling this with five
1427 arguments is NOT the same as calling it with six arguments, the last of
1428 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1429 that this function was defined with `(interactive)'. If the arg is not
1430 specified, then that means the function is not interactive.
1431 This is terrible behavior which is retained for compatibility with old
1432 `.elc' files which expect these semantics.
1434 (int nargs, Lisp_Object *args))
1436 /* In a non-insane world this function would have this arglist...
1437 (arglist instructions constants stack_depth &optional doc_string interactive)
1439 Lisp_Object fun = make_compiled_function ();
1440 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1442 Lisp_Object arglist = args[0];
1443 Lisp_Object instructions = args[1];
1444 Lisp_Object constants = args[2];
1445 Lisp_Object stack_depth = args[3];
1446 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1447 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1449 if (nargs < 4 || nargs > 6)
1450 return Fsignal (Qwrong_number_of_arguments,
1451 list2 (intern ("make-byte-code"), make_int (nargs)));
1453 /* Check for valid formal parameter list now, to allow us to use
1454 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1456 Lisp_Object symbol, tail;
1457 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1459 CHECK_SYMBOL (symbol);
1460 if (EQ (symbol, Qt) ||
1461 EQ (symbol, Qnil) ||
1462 SYMBOL_IS_KEYWORD (symbol))
1463 signal_simple_error_2
1464 ("Invalid constant symbol in formal parameter list",
1468 f->arglist = arglist;
1470 /* `instructions' is a string or a cons (string . int) for a
1471 lazy-loaded function. */
1472 if (CONSP (instructions))
1474 CHECK_STRING (XCAR (instructions));
1475 CHECK_INT (XCDR (instructions));
1479 CHECK_STRING (instructions);
1481 f->instructions = instructions;
1483 if (!NILP (constants))
1484 CHECK_VECTOR (constants);
1485 f->constants = constants;
1487 CHECK_NATNUM (stack_depth);
1488 f->stack_depth = XINT (stack_depth);
1490 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1491 if (!NILP (Vcurrent_compiled_function_annotation))
1492 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1493 else if (!NILP (Vload_file_name_internal_the_purecopy))
1494 f->annotated = Vload_file_name_internal_the_purecopy;
1495 else if (!NILP (Vload_file_name_internal))
1497 struct gcpro gcpro1;
1498 GCPRO1 (fun); /* don't let fun get reaped */
1499 Vload_file_name_internal_the_purecopy =
1500 Ffile_name_nondirectory (Vload_file_name_internal);
1501 f->annotated = Vload_file_name_internal_the_purecopy;
1504 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1506 /* doc_string may be nil, string, int, or a cons (string . int).
1507 interactive may be list or string (or unbound). */
1508 f->doc_and_interactive = Qunbound;
1510 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1511 f->doc_and_interactive = Vfile_domain;
1513 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1515 f->doc_and_interactive
1516 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1517 Fcons (interactive, f->doc_and_interactive));
1519 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1521 f->doc_and_interactive
1522 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1523 Fcons (doc_string, f->doc_and_interactive));
1525 if (UNBOUNDP (f->doc_and_interactive))
1526 f->doc_and_interactive = Qnil;
1532 /************************************************************************/
1533 /* Symbol allocation */
1534 /************************************************************************/
1536 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1537 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1539 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1540 Return a newly allocated uninterned symbol whose name is NAME.
1541 Its value and function definition are void, and its property list is nil.
1548 CHECK_STRING (name);
1550 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1551 set_lheader_implementation (&(p->lheader), &lrecord_symbol);
1552 p->name = XSTRING (name);
1554 p->value = Qunbound;
1555 p->function = Qunbound;
1556 symbol_next (p) = 0;
1557 XSETSYMBOL (val, p);
1562 /************************************************************************/
1563 /* Extent allocation */
1564 /************************************************************************/
1566 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1567 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1570 allocate_extent (void)
1574 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1575 set_lheader_implementation (&(e->lheader), &lrecord_extent);
1576 extent_object (e) = Qnil;
1577 set_extent_start (e, -1);
1578 set_extent_end (e, -1);
1583 extent_face (e) = Qnil;
1584 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1585 e->flags.detachable = 1;
1591 /************************************************************************/
1592 /* Event allocation */
1593 /************************************************************************/
1595 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1596 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1599 allocate_event (void)
1604 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1605 set_lheader_implementation (&(e->lheader), &lrecord_event);
1612 /************************************************************************/
1613 /* Marker allocation */
1614 /************************************************************************/
1616 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1617 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1619 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1620 Return a new marker which does not point at any place.
1627 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1628 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1631 marker_next (p) = 0;
1632 marker_prev (p) = 0;
1633 p->insertion_type = 0;
1634 XSETMARKER (val, p);
1639 noseeum_make_marker (void)
1644 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1645 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1648 marker_next (p) = 0;
1649 marker_prev (p) = 0;
1650 p->insertion_type = 0;
1651 XSETMARKER (val, p);
1656 /************************************************************************/
1657 /* String allocation */
1658 /************************************************************************/
1660 /* The data for "short" strings generally resides inside of structs of type
1661 string_chars_block. The Lisp_String structure is allocated just like any
1662 other Lisp object (except for vectors), and these are freelisted when
1663 they get garbage collected. The data for short strings get compacted,
1664 but the data for large strings do not.
1666 Previously Lisp_String structures were relocated, but this caused a lot
1667 of bus-errors because the C code didn't include enough GCPRO's for
1668 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1669 that the reference would get relocated).
1671 This new method makes things somewhat bigger, but it is MUCH safer. */
1673 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1674 /* strings are used and freed quite often */
1675 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1676 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1679 mark_string (Lisp_Object obj)
1681 Lisp_String *ptr = XSTRING (obj);
1683 if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1684 flush_cached_extent_info (XCAR (ptr->plist));
1689 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1692 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1693 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1696 static const struct lrecord_description string_description[] = {
1697 { XD_BYTECOUNT, offsetof (Lisp_String, size) },
1698 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1699 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) },
1703 /* We store the string's extent info as the first element of the string's
1704 property list; and the string's MODIFF as the first or second element
1705 of the string's property list (depending on whether the extent info
1706 is present), but only if the string has been modified. This is ugly
1707 but it reduces the memory allocated for the string in the vast
1708 majority of cases, where the string is never modified and has no
1711 #### This means you can't use an int as a key in a string's plist. */
1713 static Lisp_Object *
1714 string_plist_ptr (Lisp_Object string)
1716 Lisp_Object *ptr = &XSTRING (string)->plist;
1718 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
1720 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
1726 string_getprop (Lisp_Object string, Lisp_Object property)
1728 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME);
1732 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value)
1734 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME);
1739 string_remprop (Lisp_Object string, Lisp_Object property)
1741 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME);
1745 string_plist (Lisp_Object string)
1747 return *string_plist_ptr (string);
1750 /* No `finalize', or `hash' methods.
1751 internal_hash() already knows how to hash strings and finalization
1752 is done with the ADDITIONAL_FREE_string macro, which is the
1753 standard way to do finalization when using
1754 SWEEP_FIXED_TYPE_BLOCK(). */
1755 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
1756 mark_string, print_string,
1765 /* String blocks contain this many useful bytes. */
1766 #define STRING_CHARS_BLOCK_SIZE \
1767 ((Bytecount) (8192 - MALLOC_OVERHEAD - \
1768 ((2 * sizeof (struct string_chars_block *)) \
1769 + sizeof (EMACS_INT))))
1770 /* Block header for small strings. */
1771 struct string_chars_block
1774 struct string_chars_block *next;
1775 struct string_chars_block *prev;
1776 /* Contents of string_chars_block->string_chars are interleaved
1777 string_chars structures (see below) and the actual string data */
1778 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1781 static struct string_chars_block *first_string_chars_block;
1782 static struct string_chars_block *current_string_chars_block;
1784 /* If SIZE is the length of a string, this returns how many bytes
1785 * the string occupies in string_chars_block->string_chars
1786 * (including alignment padding).
1788 #define STRING_FULLSIZE(size) \
1789 ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1790 ALIGNOF (Lisp_String *))
1792 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1793 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1797 Lisp_String *string;
1798 unsigned char chars[1];
1801 struct unused_string_chars
1803 Lisp_String *string;
1808 init_string_chars_alloc (void)
1810 first_string_chars_block = xnew (struct string_chars_block);
1811 first_string_chars_block->prev = 0;
1812 first_string_chars_block->next = 0;
1813 first_string_chars_block->pos = 0;
1814 current_string_chars_block = first_string_chars_block;
1817 static struct string_chars *
1818 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1821 struct string_chars *s_chars;
1824 (countof (current_string_chars_block->string_chars)
1825 - current_string_chars_block->pos))
1827 /* This string can fit in the current string chars block */
1828 s_chars = (struct string_chars *)
1829 (current_string_chars_block->string_chars
1830 + current_string_chars_block->pos);
1831 current_string_chars_block->pos += fullsize;
1835 /* Make a new current string chars block */
1836 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1838 current_string_chars_block->next = new_scb;
1839 new_scb->prev = current_string_chars_block;
1841 current_string_chars_block = new_scb;
1842 new_scb->pos = fullsize;
1843 s_chars = (struct string_chars *)
1844 current_string_chars_block->string_chars;
1847 s_chars->string = string_it_goes_with;
1849 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1855 make_uninit_string (Bytecount length)
1858 EMACS_INT fullsize = STRING_FULLSIZE (length);
1861 assert (length >= 0 && fullsize > 0);
1863 /* Allocate the string header */
1864 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1865 set_lheader_implementation (&(s->lheader), &lrecord_string);
1867 set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1868 ? xnew_array (Bufbyte, length + 1)
1869 : allocate_string_chars_struct (s, fullsize)->chars);
1871 set_string_length (s, length);
1874 set_string_byte (s, length, 0);
1876 XSETSTRING (val, s);
1880 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1881 static void verify_string_chars_integrity (void);
1884 /* Resize the string S so that DELTA bytes can be inserted starting
1885 at POS. If DELTA < 0, it means deletion starting at POS. If
1886 POS < 0, resize the string but don't copy any characters. Use
1887 this if you're planning on completely overwriting the string.
1891 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
1893 Bytecount oldfullsize, newfullsize;
1894 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1895 verify_string_chars_integrity ();
1898 #ifdef ERROR_CHECK_BUFPOS
1901 assert (pos <= string_length (s));
1903 assert (pos + (-delta) <= string_length (s));
1908 assert ((-delta) <= string_length (s));
1910 #endif /* ERROR_CHECK_BUFPOS */
1913 /* simplest case: no size change. */
1916 if (pos >= 0 && delta < 0)
1917 /* If DELTA < 0, the functions below will delete the characters
1918 before POS. We want to delete characters *after* POS, however,
1919 so convert this to the appropriate form. */
1922 oldfullsize = STRING_FULLSIZE (string_length (s));
1923 newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1925 if (BIG_STRING_FULLSIZE_P (oldfullsize))
1927 if (BIG_STRING_FULLSIZE_P (newfullsize))
1929 /* Both strings are big. We can just realloc().
1930 But careful! If the string is shrinking, we have to
1931 memmove() _before_ realloc(), and if growing, we have to
1932 memmove() _after_ realloc() - otherwise the access is
1933 illegal, and we might crash. */
1934 Bytecount len = string_length (s) + 1 - pos;
1936 if (delta < 0 && pos >= 0)
1937 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1938 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1939 string_length (s) + delta + 1));
1940 if (delta > 0 && pos >= 0)
1941 memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1943 else /* String has been demoted from BIG_STRING. */
1946 allocate_string_chars_struct (s, newfullsize)->chars;
1947 Bufbyte *old_data = string_data (s);
1951 memcpy (new_data, old_data, pos);
1952 memcpy (new_data + pos + delta, old_data + pos,
1953 string_length (s) + 1 - pos);
1955 set_string_data (s, new_data);
1959 else /* old string is small */
1961 if (oldfullsize == newfullsize)
1963 /* special case; size change but the necessary
1964 allocation size won't change (up or down; code
1965 somewhere depends on there not being any unused
1966 allocation space, modulo any alignment
1970 Bufbyte *addroff = pos + string_data (s);
1972 memmove (addroff + delta, addroff,
1973 /* +1 due to zero-termination. */
1974 string_length (s) + 1 - pos);
1979 Bufbyte *old_data = string_data (s);
1981 BIG_STRING_FULLSIZE_P (newfullsize)
1982 ? xnew_array (Bufbyte, string_length (s) + delta + 1)
1983 : allocate_string_chars_struct (s, newfullsize)->chars;
1987 memcpy (new_data, old_data, pos);
1988 memcpy (new_data + pos + delta, old_data + pos,
1989 string_length (s) + 1 - pos);
1991 set_string_data (s, new_data);
1994 /* We need to mark this chunk of the string_chars_block
1995 as unused so that compact_string_chars() doesn't
1997 struct string_chars *old_s_chars = (struct string_chars *)
1998 ((char *) old_data - offsetof (struct string_chars, chars));
1999 /* Sanity check to make sure we aren't hosed by strange
2000 alignment/padding. */
2001 assert (old_s_chars->string == s);
2002 MARK_STRUCT_AS_FREE (old_s_chars);
2003 ((struct unused_string_chars *) old_s_chars)->fullsize =
2009 set_string_length (s, string_length (s) + delta);
2010 /* If pos < 0, the string won't be zero-terminated.
2011 Terminate now just to make sure. */
2012 string_data (s)[string_length (s)] = '\0';
2018 XSETSTRING (string, s);
2019 /* We also have to adjust all of the extent indices after the
2020 place we did the change. We say "pos - 1" because
2021 adjust_extents() is exclusive of the starting position
2023 adjust_extents (string, pos - 1, string_length (s),
2027 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2028 verify_string_chars_integrity ();
2035 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2037 Bufbyte newstr[MAX_EMCHAR_LEN];
2038 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2039 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2040 Bytecount newlen = set_charptr_emchar (newstr, c);
2042 if (oldlen != newlen)
2043 resize_string (s, bytoff, newlen - oldlen);
2044 /* Remember, string_data (s) might have changed so we can't cache it. */
2045 memcpy (string_data (s) + bytoff, newstr, newlen);
2050 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2051 Return a new string of length LENGTH, with each character being INIT.
2052 LENGTH must be an integer and INIT must be a character.
2056 CHECK_NATNUM (length);
2057 CHECK_CHAR_COERCE_INT (init);
2059 Bufbyte init_str[MAX_EMCHAR_LEN];
2060 int len = set_charptr_emchar (init_str, XCHAR (init));
2061 Lisp_Object val = make_uninit_string (len * XINT (length));
2064 /* Optimize the single-byte case */
2065 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2069 Bufbyte *ptr = XSTRING_DATA (val);
2071 for (i = XINT (length); i; i--)
2073 Bufbyte *init_ptr = init_str;
2076 case 4: *ptr++ = *init_ptr++;
2077 case 3: *ptr++ = *init_ptr++;
2078 case 2: *ptr++ = *init_ptr++;
2079 case 1: *ptr++ = *init_ptr++;
2087 DEFUN ("string", Fstring, 0, MANY, 0, /*
2088 Concatenate all the argument characters and make the result a string.
2090 (int nargs, Lisp_Object *args))
2092 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2093 Bufbyte *p = storage;
2095 for (; nargs; nargs--, args++)
2097 Lisp_Object lisp_char = *args;
2098 CHECK_CHAR_COERCE_INT (lisp_char);
2099 p += set_charptr_emchar (p, XCHAR (lisp_char));
2101 return make_string (storage, p - storage);
2105 /* Take some raw memory, which MUST already be in internal format,
2106 and package it up into a Lisp string. */
2108 make_string (const Bufbyte *contents, Bytecount length)
2112 /* Make sure we find out about bad make_string's when they happen */
2113 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2114 bytecount_to_charcount (contents, length); /* Just for the assertions */
2117 val = make_uninit_string (length);
2118 memcpy (XSTRING_DATA (val), contents, length);
2122 /* Take some raw memory, encoded in some external data format,
2123 and convert it into a Lisp string. */
2125 make_ext_string (const Extbyte *contents, EMACS_INT length,
2126 Lisp_Object coding_system)
2129 TO_INTERNAL_FORMAT (DATA, (contents, length),
2130 LISP_STRING, string,
2136 build_string (const char *str)
2138 /* Some strlen's crash and burn if passed null. */
2139 return make_string ((const Bufbyte *) str, (str ? strlen(str) : 0));
2143 build_ext_string (const char *str, Lisp_Object coding_system)
2145 /* Some strlen's crash and burn if passed null. */
2146 return make_ext_string ((const Extbyte *) str, (str ? strlen(str) : 0),
2151 build_translated_string (const char *str)
2153 return build_string (GETTEXT (str));
2157 make_string_nocopy (const Bufbyte *contents, Bytecount length)
2162 /* Make sure we find out about bad make_string_nocopy's when they happen */
2163 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2164 bytecount_to_charcount (contents, length); /* Just for the assertions */
2167 /* Allocate the string header */
2168 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2169 set_lheader_implementation (&(s->lheader), &lrecord_string);
2170 SET_C_READONLY_RECORD_HEADER (&s->lheader);
2172 set_string_data (s, (Bufbyte *)contents);
2173 set_string_length (s, length);
2175 XSETSTRING (val, s);
2180 /************************************************************************/
2181 /* lcrecord lists */
2182 /************************************************************************/
2184 /* Lcrecord lists are used to manage the allocation of particular
2185 sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2186 malloc() and garbage-collection junk) as much as possible.
2187 It is similar to the Blocktype class.
2191 1) Create an lcrecord-list object using make_lcrecord_list().
2192 This is often done at initialization. Remember to staticpro_nodump
2193 this object! The arguments to make_lcrecord_list() are the
2194 same as would be passed to alloc_lcrecord().
2195 2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2196 and pass the lcrecord-list earlier created.
2197 3) When done with the lcrecord, call free_managed_lcrecord().
2198 The standard freeing caveats apply: ** make sure there are no
2199 pointers to the object anywhere! **
2200 4) Calling free_managed_lcrecord() is just like kissing the
2201 lcrecord goodbye as if it were garbage-collected. This means:
2202 -- the contents of the freed lcrecord are undefined, and the
2203 contents of something produced by allocate_managed_lcrecord()
2204 are undefined, just like for alloc_lcrecord().
2205 -- the mark method for the lcrecord's type will *NEVER* be called
2207 -- the finalize method for the lcrecord's type will be called
2208 at the time that free_managed_lcrecord() is called.
2213 mark_lcrecord_list (Lisp_Object obj)
2215 struct lcrecord_list *list = XLCRECORD_LIST (obj);
2216 Lisp_Object chain = list->free;
2218 while (!NILP (chain))
2220 struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2221 struct free_lcrecord_header *free_header =
2222 (struct free_lcrecord_header *) lheader;
2225 (/* There should be no other pointers to the free list. */
2226 ! MARKED_RECORD_HEADER_P (lheader)
2228 /* Only lcrecords should be here. */
2229 ! LHEADER_IMPLEMENTATION (lheader)->basic_p
2231 /* Only free lcrecords should be here. */
2232 free_header->lcheader.free
2234 /* The type of the lcrecord must be right. */
2235 LHEADER_IMPLEMENTATION (lheader) == list->implementation
2237 /* So must the size. */
2238 (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2239 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
2242 MARK_RECORD_HEADER (lheader);
2243 chain = free_header->chain;
2249 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2250 mark_lcrecord_list, internal_object_printer,
2251 0, 0, 0, 0, struct lcrecord_list);
2253 make_lcrecord_list (size_t size,
2254 const struct lrecord_implementation *implementation)
2256 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2257 &lrecord_lcrecord_list);
2260 p->implementation = implementation;
2263 XSETLCRECORD_LIST (val, p);
2268 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2270 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2271 if (!NILP (list->free))
2273 Lisp_Object val = list->free;
2274 struct free_lcrecord_header *free_header =
2275 (struct free_lcrecord_header *) XPNTR (val);
2277 #ifdef ERROR_CHECK_GC
2278 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2280 /* There should be no other pointers to the free list. */
2281 assert (! MARKED_RECORD_HEADER_P (lheader));
2282 /* Only lcrecords should be here. */
2283 assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
2284 /* Only free lcrecords should be here. */
2285 assert (free_header->lcheader.free);
2286 /* The type of the lcrecord must be right. */
2287 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
2288 /* So must the size. */
2289 assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
2290 LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
2291 #endif /* ERROR_CHECK_GC */
2293 list->free = free_header->chain;
2294 free_header->lcheader.free = 0;
2301 XSETOBJ (val, Lisp_Type_Record,
2302 alloc_lcrecord (list->size, list->implementation));
2308 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2310 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2311 struct free_lcrecord_header *free_header =
2312 (struct free_lcrecord_header *) XPNTR (lcrecord);
2313 struct lrecord_header *lheader = &free_header->lcheader.lheader;
2314 const struct lrecord_implementation *implementation
2315 = LHEADER_IMPLEMENTATION (lheader);
2317 /* Make sure the size is correct. This will catch, for example,
2318 putting a window configuration on the wrong free list. */
2319 gc_checking_assert ((implementation->size_in_bytes_method ?
2320 implementation->size_in_bytes_method (lheader) :
2321 implementation->static_size)
2324 if (implementation->finalizer)
2325 implementation->finalizer (lheader, 0);
2326 free_header->chain = list->free;
2327 free_header->lcheader.free = 1;
2328 list->free = lcrecord;
2334 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2335 Kept for compatibility, returns its argument.
2337 Make a copy of OBJECT in pure storage.
2338 Recursively copies contents of vectors and cons cells.
2339 Does not copy symbols.
2347 /************************************************************************/
2348 /* Garbage Collection */
2349 /************************************************************************/
2351 /* This will be used more extensively In The Future */
2352 static int last_lrecord_type_index_assigned;
2354 /* All the built-in lisp object types are enumerated in `enum lrecord_type'.
2355 Additional ones may be defined by a module (none yet). We leave some
2356 room in `lrecord_implementations_table' for such new lisp object types. */
2357 #define MODULE_DEFINABLE_TYPE_COUNT 32
2358 const struct lrecord_implementation *lrecord_implementations_table[lrecord_type_count + MODULE_DEFINABLE_TYPE_COUNT];
2360 /* Object marker functions are in the lrecord_implementation structure.
2361 But copying them to a parallel array is much more cache-friendly.
2362 This hack speeds up (garbage-collect) by about 5%. */
2363 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
2365 struct gcpro *gcprolist;
2367 /* 415 used Mly 29-Jun-93 */
2368 /* 1327 used slb 28-Feb-98 */
2369 /* 1328 used og 03-Oct-99 (moving slowly, heh?) */
2371 #define NSTATICS 4000
2373 #define NSTATICS 2000
2375 /* Not "static" because of linker lossage on some systems */
2376 Lisp_Object *staticvec[NSTATICS]
2377 /* Force it into data space! */
2379 static int staticidx;
2381 /* Put an entry in staticvec, pointing at the variable whose address is given
2384 staticpro (Lisp_Object *varaddress)
2386 if (staticidx >= countof (staticvec))
2387 /* #### This is now a dubious abort() since this routine may be called */
2388 /* by Lisp attempting to load a DLL. */
2390 staticvec[staticidx++] = varaddress;
2393 /* Not "static" because of linker lossage on some systems */
2394 Lisp_Object *staticvec_nodump[200]
2395 /* Force it into data space! */
2397 static int staticidx_nodump;
2399 /* Put an entry in staticvec_nodump, pointing at the variable whose address is given
2402 staticpro_nodump (Lisp_Object *varaddress)
2404 if (staticidx_nodump >= countof (staticvec_nodump))
2405 /* #### This is now a dubious abort() since this routine may be called */
2406 /* by Lisp attempting to load a DLL. */
2408 staticvec_nodump[staticidx_nodump++] = varaddress;
2411 /* Not "static" because of linker lossage on some systems */
2415 const struct struct_description *desc;
2416 } dumpstructvec[200];
2418 static int dumpstructidx;
2420 /* Put an entry in dumpstructvec, pointing at the variable whose address is given
2423 dumpstruct (void *varaddress, const struct struct_description *desc)
2425 if (dumpstructidx >= countof (dumpstructvec))
2427 dumpstructvec[dumpstructidx].data = varaddress;
2428 dumpstructvec[dumpstructidx].desc = desc;
2432 /* Not "static" because of linker lossage on some systems */
2433 struct dumpopaque_info
2437 } dumpopaquevec[200];
2439 static int dumpopaqueidx;
2441 /* Put an entry in dumpopaquevec, pointing at the variable whose address is given
2444 dumpopaque (void *varaddress, size_t size)
2446 if (dumpopaqueidx >= countof (dumpopaquevec))
2448 dumpopaquevec[dumpopaqueidx].data = varaddress;
2449 dumpopaquevec[dumpopaqueidx].size = size;
2453 Lisp_Object *pdump_wirevec[50];
2454 static int pdump_wireidx;
2456 /* Put an entry in pdump_wirevec, pointing at the variable whose address is given
2459 pdump_wire (Lisp_Object *varaddress)
2461 if (pdump_wireidx >= countof (pdump_wirevec))
2463 pdump_wirevec[pdump_wireidx++] = varaddress;
2467 Lisp_Object *pdump_wirevec_list[50];
2468 static int pdump_wireidx_list;
2470 /* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given
2473 pdump_wire_list (Lisp_Object *varaddress)
2475 if (pdump_wireidx_list >= countof (pdump_wirevec_list))
2477 pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
2480 #ifdef ERROR_CHECK_GC
2481 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
2482 struct lrecord_header * GCLI_lh = (lheader); \
2483 assert (GCLI_lh != 0); \
2484 assert (GCLI_lh->type <= last_lrecord_type_index_assigned); \
2485 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \
2486 (MARKED_RECORD_HEADER_P (GCLI_lh) && \
2487 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \
2490 #define GC_CHECK_LHEADER_INVARIANTS(lheader)
2494 /* Mark reference to a Lisp_Object. If the object referred to has not been
2495 seen yet, recursively mark all the references contained in it. */
2498 mark_object (Lisp_Object obj)
2502 /* Checks we used to perform */
2503 /* if (EQ (obj, Qnull_pointer)) return; */
2504 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2505 /* if (PURIFIED (XPNTR (obj))) return; */
2507 if (XTYPE (obj) == Lisp_Type_Record)
2509 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2511 GC_CHECK_LHEADER_INVARIANTS (lheader);
2513 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
2514 ! ((struct lcrecord_header *) lheader)->free);
2516 /* All c_readonly objects have their mark bit set,
2517 so that we only need to check the mark bit here. */
2518 if (! MARKED_RECORD_HEADER_P (lheader))
2520 MARK_RECORD_HEADER (lheader);
2522 if (RECORD_MARKER (lheader))
2524 obj = RECORD_MARKER (lheader) (obj);
2525 if (!NILP (obj)) goto tail_recurse;
2531 /* mark all of the conses in a list and mark the final cdr; but
2532 DO NOT mark the cars.
2534 Use only for internal lists! There should never be other pointers
2535 to the cons cells, because if so, the cars will remain unmarked
2536 even when they maybe should be marked. */
2538 mark_conses_in_list (Lisp_Object obj)
2542 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2544 if (CONS_MARKED_P (XCONS (rest)))
2546 MARK_CONS (XCONS (rest));
2553 /* Find all structures not marked, and free them. */
2555 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2556 static int gc_count_bit_vector_storage;
2557 static int gc_count_num_short_string_in_use;
2558 static int gc_count_string_total_size;
2559 static int gc_count_short_string_total_size;
2561 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2564 /* stats on lcrecords in use - kinda kludgy */
2568 int instances_in_use;
2570 int instances_freed;
2572 int instances_on_free_list;
2573 } lcrecord_stats [countof (lrecord_implementations_table)];
2576 tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
2578 unsigned int type_index = h->type;
2580 if (((struct lcrecord_header *) h)->free)
2582 gc_checking_assert (!free_p);
2583 lcrecord_stats[type_index].instances_on_free_list++;
2587 const struct lrecord_implementation *implementation =
2588 LHEADER_IMPLEMENTATION (h);
2590 size_t sz = (implementation->size_in_bytes_method ?
2591 implementation->size_in_bytes_method (h) :
2592 implementation->static_size);
2595 lcrecord_stats[type_index].instances_freed++;
2596 lcrecord_stats[type_index].bytes_freed += sz;
2600 lcrecord_stats[type_index].instances_in_use++;
2601 lcrecord_stats[type_index].bytes_in_use += sz;
2607 /* Free all unmarked records */
2609 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2611 struct lcrecord_header *header;
2613 /* int total_size = 0; */
2615 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2617 /* First go through and call all the finalize methods.
2618 Then go through and free the objects. There used to
2619 be only one loop here, with the call to the finalizer
2620 occurring directly before the xfree() below. That
2621 is marginally faster but much less safe -- if the
2622 finalize method for an object needs to reference any
2623 other objects contained within it (and many do),
2624 we could easily be screwed by having already freed that
2627 for (header = *prev; header; header = header->next)
2629 struct lrecord_header *h = &(header->lheader);
2631 GC_CHECK_LHEADER_INVARIANTS (h);
2633 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
2635 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2636 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2640 for (header = *prev; header; )
2642 struct lrecord_header *h = &(header->lheader);
2643 if (MARKED_RECORD_HEADER_P (h))
2645 if (! C_READONLY_RECORD_HEADER_P (h))
2646 UNMARK_RECORD_HEADER (h);
2648 /* total_size += n->implementation->size_in_bytes (h);*/
2649 /* #### May modify header->next on a C_READONLY lcrecord */
2650 prev = &(header->next);
2652 tick_lcrecord_stats (h, 0);
2656 struct lcrecord_header *next = header->next;
2658 tick_lcrecord_stats (h, 1);
2659 /* used to call finalizer right here. */
2665 /* *total = total_size; */
2670 sweep_bit_vectors_1 (Lisp_Object *prev,
2671 int *used, int *total, int *storage)
2673 Lisp_Object bit_vector;
2676 int total_storage = 0;
2678 /* BIT_VECTORP fails because the objects are marked, which changes
2679 their implementation */
2680 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2682 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2684 if (MARKED_RECORD_P (bit_vector))
2686 if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
2687 UNMARK_RECORD_HEADER (&(v->lheader));
2691 offsetof (Lisp_Bit_Vector, bits[BIT_VECTOR_LONG_STORAGE (len)]);
2693 /* #### May modify next on a C_READONLY bitvector */
2694 prev = &(bit_vector_next (v));
2699 Lisp_Object next = bit_vector_next (v);
2706 *total = total_size;
2707 *storage = total_storage;
2710 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2711 to make macros prettier. */
2713 #ifdef ERROR_CHECK_GC
2715 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2717 struct typename##_block *SFTB_current; \
2718 struct typename##_block **SFTB_prev; \
2720 int num_free = 0, num_used = 0; \
2722 for (SFTB_prev = ¤t_##typename##_block, \
2723 SFTB_current = current_##typename##_block, \
2724 SFTB_limit = current_##typename##_block_index; \
2730 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2732 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2734 if (FREE_STRUCT_P (SFTB_victim)) \
2738 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2742 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2745 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2750 UNMARK_##typename (SFTB_victim); \
2753 SFTB_prev = &(SFTB_current->prev); \
2754 SFTB_current = SFTB_current->prev; \
2755 SFTB_limit = countof (current_##typename##_block->block); \
2758 gc_count_num_##typename##_in_use = num_used; \
2759 gc_count_num_##typename##_freelist = num_free; \
2762 #else /* !ERROR_CHECK_GC */
2764 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2766 struct typename##_block *SFTB_current; \
2767 struct typename##_block **SFTB_prev; \
2769 int num_free = 0, num_used = 0; \
2771 typename##_free_list = 0; \
2773 for (SFTB_prev = ¤t_##typename##_block, \
2774 SFTB_current = current_##typename##_block, \
2775 SFTB_limit = current_##typename##_block_index; \
2780 int SFTB_empty = 1; \
2781 obj_type *SFTB_old_free_list = typename##_free_list; \
2783 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2785 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2787 if (FREE_STRUCT_P (SFTB_victim)) \
2790 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2792 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2797 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2800 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2806 UNMARK_##typename (SFTB_victim); \
2811 SFTB_prev = &(SFTB_current->prev); \
2812 SFTB_current = SFTB_current->prev; \
2814 else if (SFTB_current == current_##typename##_block \
2815 && !SFTB_current->prev) \
2817 /* No real point in freeing sole allocation block */ \
2822 struct typename##_block *SFTB_victim_block = SFTB_current; \
2823 if (SFTB_victim_block == current_##typename##_block) \
2824 current_##typename##_block_index \
2825 = countof (current_##typename##_block->block); \
2826 SFTB_current = SFTB_current->prev; \
2828 *SFTB_prev = SFTB_current; \
2829 xfree (SFTB_victim_block); \
2830 /* Restore free list to what it was before victim was swept */ \
2831 typename##_free_list = SFTB_old_free_list; \
2832 num_free -= SFTB_limit; \
2835 SFTB_limit = countof (current_##typename##_block->block); \
2838 gc_count_num_##typename##_in_use = num_used; \
2839 gc_count_num_##typename##_freelist = num_free; \
2842 #endif /* !ERROR_CHECK_GC */
2850 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2851 #define ADDITIONAL_FREE_cons(ptr)
2853 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2856 /* Explicitly free a cons cell. */
2858 free_cons (Lisp_Cons *ptr)
2860 #ifdef ERROR_CHECK_GC
2861 /* If the CAR is not an int, then it will be a pointer, which will
2862 always be four-byte aligned. If this cons cell has already been
2863 placed on the free list, however, its car will probably contain
2864 a chain pointer to the next cons on the list, which has cleverly
2865 had all its 0's and 1's inverted. This allows for a quick
2866 check to make sure we're not freeing something already freed. */
2867 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2868 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2869 #endif /* ERROR_CHECK_GC */
2871 #ifndef ALLOC_NO_POOLS
2872 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2873 #endif /* ALLOC_NO_POOLS */
2876 /* explicitly free a list. You **must make sure** that you have
2877 created all the cons cells that make up this list and that there
2878 are no pointers to any of these cons cells anywhere else. If there
2879 are, you will lose. */
2882 free_list (Lisp_Object list)
2884 Lisp_Object rest, next;
2886 for (rest = list; !NILP (rest); rest = next)
2889 free_cons (XCONS (rest));
2893 /* explicitly free an alist. You **must make sure** that you have
2894 created all the cons cells that make up this alist and that there
2895 are no pointers to any of these cons cells anywhere else. If there
2896 are, you will lose. */
2899 free_alist (Lisp_Object alist)
2901 Lisp_Object rest, next;
2903 for (rest = alist; !NILP (rest); rest = next)
2906 free_cons (XCONS (XCAR (rest)));
2907 free_cons (XCONS (rest));
2912 sweep_compiled_functions (void)
2914 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2915 #define ADDITIONAL_FREE_compiled_function(ptr)
2917 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2921 #ifdef LISP_FLOAT_TYPE
2925 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2926 #define ADDITIONAL_FREE_float(ptr)
2928 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
2930 #endif /* LISP_FLOAT_TYPE */
2933 sweep_symbols (void)
2935 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2936 #define ADDITIONAL_FREE_symbol(ptr)
2938 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
2942 sweep_extents (void)
2944 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2945 #define ADDITIONAL_FREE_extent(ptr)
2947 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2953 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2954 #define ADDITIONAL_FREE_event(ptr)
2956 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
2960 sweep_markers (void)
2962 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2963 #define ADDITIONAL_FREE_marker(ptr) \
2964 do { Lisp_Object tem; \
2965 XSETMARKER (tem, ptr); \
2966 unchain_marker (tem); \
2969 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
2972 /* Explicitly free a marker. */
2974 free_marker (Lisp_Marker *ptr)
2976 /* Perhaps this will catch freeing an already-freed marker. */
2977 gc_checking_assert (ptr->lheader.type = lrecord_type_marker);
2979 #ifndef ALLOC_NO_POOLS
2980 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
2981 #endif /* ALLOC_NO_POOLS */
2985 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2988 verify_string_chars_integrity (void)
2990 struct string_chars_block *sb;
2992 /* Scan each existing string block sequentially, string by string. */
2993 for (sb = first_string_chars_block; sb; sb = sb->next)
2996 /* POS is the index of the next string in the block. */
2997 while (pos < sb->pos)
2999 struct string_chars *s_chars =
3000 (struct string_chars *) &(sb->string_chars[pos]);
3001 Lisp_String *string;
3005 /* If the string_chars struct is marked as free (i.e. the STRING
3006 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3007 storage. (See below.) */
3009 if (FREE_STRUCT_P (s_chars))
3011 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3016 string = s_chars->string;
3017 /* Must be 32-bit aligned. */
3018 assert ((((int) string) & 3) == 0);
3020 size = string_length (string);
3021 fullsize = STRING_FULLSIZE (size);
3023 assert (!BIG_STRING_FULLSIZE_P (fullsize));
3024 assert (string_data (string) == s_chars->chars);
3027 assert (pos == sb->pos);
3031 #endif /* MULE && ERROR_CHECK_GC */
3033 /* Compactify string chars, relocating the reference to each --
3034 free any empty string_chars_block we see. */
3036 compact_string_chars (void)
3038 struct string_chars_block *to_sb = first_string_chars_block;
3040 struct string_chars_block *from_sb;
3042 /* Scan each existing string block sequentially, string by string. */
3043 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3046 /* FROM_POS is the index of the next string in the block. */
3047 while (from_pos < from_sb->pos)
3049 struct string_chars *from_s_chars =
3050 (struct string_chars *) &(from_sb->string_chars[from_pos]);
3051 struct string_chars *to_s_chars;
3052 Lisp_String *string;
3056 /* If the string_chars struct is marked as free (i.e. the STRING
3057 pointer is 0xFFFFFFFF) then this is an unused chunk of string
3058 storage. This happens under Mule when a string's size changes
3059 in such a way that its fullsize changes. (Strings can change
3060 size because a different-length character can be substituted
3061 for another character.) In this case, after the bogus string
3062 pointer is the "fullsize" of this entry, i.e. how many bytes
3065 if (FREE_STRUCT_P (from_s_chars))
3067 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3068 from_pos += fullsize;
3072 string = from_s_chars->string;
3073 assert (!(FREE_STRUCT_P (string)));
3075 size = string_length (string);
3076 fullsize = STRING_FULLSIZE (size);
3078 if (BIG_STRING_FULLSIZE_P (fullsize))
3081 /* Just skip it if it isn't marked. */
3082 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3084 from_pos += fullsize;
3088 /* If it won't fit in what's left of TO_SB, close TO_SB out
3089 and go on to the next string_chars_block. We know that TO_SB
3090 cannot advance past FROM_SB here since FROM_SB is large enough
3091 to currently contain this string. */
3092 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3094 to_sb->pos = to_pos;
3095 to_sb = to_sb->next;
3099 /* Compute new address of this string
3100 and update TO_POS for the space being used. */
3101 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3103 /* Copy the string_chars to the new place. */
3104 if (from_s_chars != to_s_chars)
3105 memmove (to_s_chars, from_s_chars, fullsize);
3107 /* Relocate FROM_S_CHARS's reference */
3108 set_string_data (string, &(to_s_chars->chars[0]));
3110 from_pos += fullsize;
3115 /* Set current to the last string chars block still used and
3116 free any that follow. */
3118 struct string_chars_block *victim;
3120 for (victim = to_sb->next; victim; )
3122 struct string_chars_block *next = victim->next;
3127 current_string_chars_block = to_sb;
3128 current_string_chars_block->pos = to_pos;
3129 current_string_chars_block->next = 0;
3133 #if 1 /* Hack to debug missing purecopy's */
3134 static int debug_string_purity;
3137 debug_string_purity_print (Lisp_String *p)
3140 Charcount s = string_char_length (p);
3141 putc ('\"', stderr);
3142 for (i = 0; i < s; i++)
3144 Emchar ch = string_char (p, i);
3145 if (ch < 32 || ch >= 126)
3146 stderr_out ("\\%03o", ch);
3147 else if (ch == '\\' || ch == '\"')
3148 stderr_out ("\\%c", ch);
3150 stderr_out ("%c", ch);
3152 stderr_out ("\"\n");
3158 sweep_strings (void)
3160 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3161 int debug = debug_string_purity;
3163 #define UNMARK_string(ptr) do { \
3164 Lisp_String *p = (ptr); \
3165 size_t size = string_length (p); \
3166 UNMARK_RECORD_HEADER (&(p->lheader)); \
3167 num_bytes += size; \
3168 if (!BIG_STRING_SIZE_P (size)) \
3169 { num_small_bytes += size; \
3173 debug_string_purity_print (p); \
3175 #define ADDITIONAL_FREE_string(ptr) do { \
3176 size_t size = string_length (ptr); \
3177 if (BIG_STRING_SIZE_P (size)) \
3178 xfree (ptr->data); \
3181 SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3183 gc_count_num_short_string_in_use = num_small_used;
3184 gc_count_string_total_size = num_bytes;
3185 gc_count_short_string_total_size = num_small_bytes;
3189 /* I hate duplicating all this crap! */
3191 marked_p (Lisp_Object obj)
3193 /* Checks we used to perform. */
3194 /* if (EQ (obj, Qnull_pointer)) return 1; */
3195 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3196 /* if (PURIFIED (XPNTR (obj))) return 1; */
3198 if (XTYPE (obj) == Lisp_Type_Record)
3200 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3202 GC_CHECK_LHEADER_INVARIANTS (lheader);
3204 return MARKED_RECORD_HEADER_P (lheader);
3212 /* Free all unmarked records. Do this at the very beginning,
3213 before anything else, so that the finalize methods can safely
3214 examine items in the objects. sweep_lcrecords_1() makes
3215 sure to call all the finalize methods *before* freeing anything,
3216 to complete the safety. */
3219 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3222 compact_string_chars ();
3224 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3225 macros) must be *extremely* careful to make sure they're not
3226 referencing freed objects. The only two existing finalize
3227 methods (for strings and markers) pass muster -- the string
3228 finalizer doesn't look at anything but its own specially-
3229 created block, and the marker finalizer only looks at live
3230 buffers (which will never be freed) and at the markers before
3231 and after it in the chain (which, by induction, will never be
3232 freed because if so, they would have already removed themselves
3235 /* Put all unmarked strings on free list, free'ing the string chars
3236 of large unmarked strings */
3239 /* Put all unmarked conses on free list */
3242 /* Free all unmarked bit vectors */
3243 sweep_bit_vectors_1 (&all_bit_vectors,
3244 &gc_count_num_bit_vector_used,
3245 &gc_count_bit_vector_total_size,
3246 &gc_count_bit_vector_storage);
3248 /* Free all unmarked compiled-function objects */
3249 sweep_compiled_functions ();
3251 #ifdef LISP_FLOAT_TYPE
3252 /* Put all unmarked floats on free list */
3256 /* Put all unmarked symbols on free list */
3259 /* Put all unmarked extents on free list */
3262 /* Put all unmarked markers on free list.
3263 Dechain each one first from the buffer into which it points. */
3269 /* Unmark all dumped objects */
3272 char *p = pdump_rt_list;
3276 pdump_reloc_table *rt = (pdump_reloc_table *)p;
3277 p += sizeof (pdump_reloc_table);
3280 for (i=0; i<rt->count; i++)
3282 struct lrecord_header *lh = * (struct lrecord_header **) p;
3283 if (! C_READONLY_RECORD_HEADER_P (lh))
3284 UNMARK_RECORD_HEADER (lh);
3285 p += sizeof (EMACS_INT);
3294 /* Clearing for disksave. */
3297 disksave_object_finalization (void)
3299 /* It's important that certain information from the environment not get
3300 dumped with the executable (pathnames, environment variables, etc.).
3301 To make it easier to tell when this has happened with strings(1) we
3302 clear some known-to-be-garbage blocks of memory, so that leftover
3303 results of old evaluation don't look like potential problems.
3304 But first we set some notable variables to nil and do one more GC,
3305 to turn those strings into garbage.
3308 /* Yeah, this list is pretty ad-hoc... */
3309 Vprocess_environment = Qnil;
3310 Vexec_directory = Qnil;
3311 Vdata_directory = Qnil;
3312 Vsite_directory = Qnil;
3313 Vdoc_directory = Qnil;
3314 Vconfigure_info_directory = Qnil;
3317 /* Vdump_load_path = Qnil; */
3318 /* Release hash tables for locate_file */
3319 Flocate_file_clear_hashing (Qt);
3320 uncache_home_directory();
3322 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3323 defined(LOADHIST_BUILTIN))
3324 Vload_history = Qnil;
3326 Vshell_file_name = Qnil;
3328 garbage_collect_1 ();
3330 /* Run the disksave finalization methods of all live objects. */
3331 disksave_object_finalization_1 ();
3333 /* Zero out the uninitialized (really, unused) part of the containers
3334 for the live strings. */
3336 struct string_chars_block *scb;
3337 for (scb = first_string_chars_block; scb; scb = scb->next)
3339 int count = sizeof (scb->string_chars) - scb->pos;
3341 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3344 /* from the block's fill ptr to the end */
3345 memset ((scb->string_chars + scb->pos), 0, count);
3350 /* There, that ought to be enough... */
3356 restore_gc_inhibit (Lisp_Object val)
3358 gc_currently_forbidden = XINT (val);
3362 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3363 static int gc_hooks_inhibited;
3367 garbage_collect_1 (void)
3369 #if MAX_SAVE_STACK > 0
3370 char stack_top_variable;
3371 extern char *stack_bottom;
3376 Lisp_Object pre_gc_cursor;
3377 struct gcpro gcpro1;
3380 || gc_currently_forbidden
3382 || preparing_for_armageddon)
3385 /* We used to call selected_frame() here.
3387 The following functions cannot be called inside GC
3388 so we move to after the above tests. */
3391 Lisp_Object device = Fselected_device (Qnil);
3392 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3394 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3396 signal_simple_error ("No frames exist on device", device);
3400 pre_gc_cursor = Qnil;
3403 GCPRO1 (pre_gc_cursor);
3405 /* Very important to prevent GC during any of the following
3406 stuff that might run Lisp code; otherwise, we'll likely
3407 have infinite GC recursion. */
3408 speccount = specpdl_depth ();
3409 record_unwind_protect (restore_gc_inhibit,
3410 make_int (gc_currently_forbidden));
3411 gc_currently_forbidden = 1;
3413 if (!gc_hooks_inhibited)
3414 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3416 /* Now show the GC cursor/message. */
3417 if (!noninteractive)
3419 if (FRAME_WIN_P (f))
3421 Lisp_Object frame = make_frame (f);
3422 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3423 FRAME_SELECTED_WINDOW (f),
3425 pre_gc_cursor = f->pointer;
3426 if (POINTER_IMAGE_INSTANCEP (cursor)
3427 /* don't change if we don't know how to change back. */
3428 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3431 Fset_frame_pointer (frame, cursor);
3435 /* Don't print messages to the stream device. */
3436 if (!cursor_changed && !FRAME_STREAM_P (f))
3438 char *msg = (STRINGP (Vgc_message)
3439 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3441 Lisp_Object args[2], whole_msg;
3442 args[0] = build_string (msg ? msg :
3443 GETTEXT ((const char *) gc_default_message));
3444 args[1] = build_string ("...");
3445 whole_msg = Fconcat (2, args);
3446 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3447 Qgarbage_collecting);
3451 /***** Now we actually start the garbage collection. */
3455 gc_generation_number[0]++;
3457 #if MAX_SAVE_STACK > 0
3459 /* Save a copy of the contents of the stack, for debugging. */
3462 /* Static buffer in which we save a copy of the C stack at each GC. */
3463 static char *stack_copy;
3464 static size_t stack_copy_size;
3466 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3467 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3468 if (stack_size < MAX_SAVE_STACK)
3470 if (stack_copy_size < stack_size)
3472 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3473 stack_copy_size = stack_size;
3477 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3481 #endif /* MAX_SAVE_STACK > 0 */
3483 /* Do some totally ad-hoc resource clearing. */
3484 /* #### generalize this? */
3485 clear_event_resource ();
3486 cleanup_specifiers ();
3488 /* Mark all the special slots that serve as the roots of accessibility. */
3492 for (i = 0; i < staticidx; i++)
3493 mark_object (*(staticvec[i]));
3494 for (i = 0; i < staticidx_nodump; i++)
3495 mark_object (*(staticvec_nodump[i]));
3501 for (tail = gcprolist; tail; tail = tail->next)
3502 for (i = 0; i < tail->nvars; i++)
3503 mark_object (tail->var[i]);
3507 struct specbinding *bind;
3508 for (bind = specpdl; bind != specpdl_ptr; bind++)
3510 mark_object (bind->symbol);
3511 mark_object (bind->old_value);
3516 struct catchtag *catch;
3517 for (catch = catchlist; catch; catch = catch->next)
3519 mark_object (catch->tag);
3520 mark_object (catch->val);
3525 struct backtrace *backlist;
3526 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3528 int nargs = backlist->nargs;
3531 mark_object (*backlist->function);
3532 if (nargs == UNEVALLED || nargs == MANY)
3533 mark_object (backlist->args[0]);
3535 for (i = 0; i < nargs; i++)
3536 mark_object (backlist->args[i]);
3541 mark_profiling_info ();
3543 /* OK, now do the after-mark stuff. This is for things that
3544 are only marked when something else is marked (e.g. weak hash tables).
3545 There may be complex dependencies between such objects -- e.g.
3546 a weak hash table might be unmarked, but after processing a later
3547 weak hash table, the former one might get marked. So we have to
3548 iterate until nothing more gets marked. */
3550 while (finish_marking_weak_hash_tables () > 0 ||
3551 finish_marking_weak_lists () > 0)
3554 /* And prune (this needs to be called after everything else has been
3555 marked and before we do any sweeping). */
3556 /* #### this is somewhat ad-hoc and should probably be an object
3558 prune_weak_hash_tables ();
3559 prune_weak_lists ();
3560 prune_specifiers ();
3561 prune_syntax_tables ();
3565 consing_since_gc = 0;
3566 #ifndef DEBUG_XEMACS
3567 /* Allow you to set it really fucking low if you really want ... */
3568 if (gc_cons_threshold < 10000)
3569 gc_cons_threshold = 10000;
3574 /******* End of garbage collection ********/
3576 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3578 /* Now remove the GC cursor/message */
3579 if (!noninteractive)
3582 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3583 else if (!FRAME_STREAM_P (f))
3585 char *msg = (STRINGP (Vgc_message)
3586 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3589 /* Show "...done" only if the echo area would otherwise be empty. */
3590 if (NILP (clear_echo_area (selected_frame (),
3591 Qgarbage_collecting, 0)))
3593 Lisp_Object args[2], whole_msg;
3594 args[0] = build_string (msg ? msg :
3595 GETTEXT ((const char *)
3596 gc_default_message));
3597 args[1] = build_string ("... done");
3598 whole_msg = Fconcat (2, args);
3599 echo_area_message (selected_frame (), (Bufbyte *) 0,
3601 Qgarbage_collecting);
3606 /* now stop inhibiting GC */
3607 unbind_to (speccount, Qnil);
3609 if (!breathing_space)
3611 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3618 /* Debugging aids. */
3621 gc_plist_hack (const char *name, int value, Lisp_Object tail)
3623 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3624 or portable numeric datatypes, or bit-vectors, or characters, or
3625 arrays, or exceptions, or ...) */
3626 return cons3 (intern (name), make_int (value), tail);
3629 #define HACK_O_MATIC(type, name, pl) do { \
3631 struct type##_block *x = current_##type##_block; \
3632 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3633 (pl) = gc_plist_hack ((name), s, (pl)); \
3636 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3637 Reclaim storage for Lisp objects no longer needed.
3638 Return info on amount of space in use:
3639 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3640 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3642 where `PLIST' is a list of alternating keyword/value pairs providing
3643 more detailed information.
3644 Garbage collection happens automatically if you cons more than
3645 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3649 Lisp_Object pl = Qnil;
3651 int gc_count_vector_total_size = 0;
3653 garbage_collect_1 ();
3655 for (i = 0; i <= last_lrecord_type_index_assigned; i++)
3657 if (lcrecord_stats[i].bytes_in_use != 0
3658 || lcrecord_stats[i].bytes_freed != 0
3659 || lcrecord_stats[i].instances_on_free_list != 0)
3662 const char *name = lrecord_implementations_table[i]->name;
3663 int len = strlen (name);
3664 /* save this for the FSFmacs-compatible part of the summary */
3665 if (i == lrecord_vector.lrecord_type_index)
3666 gc_count_vector_total_size =
3667 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3669 sprintf (buf, "%s-storage", name);
3670 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3671 /* Okay, simple pluralization check for `symbol-value-varalias' */
3672 if (name[len-1] == 's')
3673 sprintf (buf, "%ses-freed", name);
3675 sprintf (buf, "%ss-freed", name);
3676 if (lcrecord_stats[i].instances_freed != 0)
3677 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3678 if (name[len-1] == 's')
3679 sprintf (buf, "%ses-on-free-list", name);
3681 sprintf (buf, "%ss-on-free-list", name);
3682 if (lcrecord_stats[i].instances_on_free_list != 0)
3683 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3685 if (name[len-1] == 's')
3686 sprintf (buf, "%ses-used", name);
3688 sprintf (buf, "%ss-used", name);
3689 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3693 HACK_O_MATIC (extent, "extent-storage", pl);
3694 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3695 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3696 HACK_O_MATIC (event, "event-storage", pl);
3697 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3698 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3699 HACK_O_MATIC (marker, "marker-storage", pl);
3700 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3701 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3702 #ifdef LISP_FLOAT_TYPE
3703 HACK_O_MATIC (float, "float-storage", pl);
3704 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3705 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3706 #endif /* LISP_FLOAT_TYPE */
3707 HACK_O_MATIC (string, "string-header-storage", pl);
3708 pl = gc_plist_hack ("long-strings-total-length",
3709 gc_count_string_total_size
3710 - gc_count_short_string_total_size, pl);
3711 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3712 pl = gc_plist_hack ("short-strings-total-length",
3713 gc_count_short_string_total_size, pl);
3714 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3715 pl = gc_plist_hack ("long-strings-used",
3716 gc_count_num_string_in_use
3717 - gc_count_num_short_string_in_use, pl);
3718 pl = gc_plist_hack ("short-strings-used",
3719 gc_count_num_short_string_in_use, pl);
3721 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3722 pl = gc_plist_hack ("compiled-functions-free",
3723 gc_count_num_compiled_function_freelist, pl);
3724 pl = gc_plist_hack ("compiled-functions-used",
3725 gc_count_num_compiled_function_in_use, pl);
3727 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3728 pl = gc_plist_hack ("bit-vectors-total-length",
3729 gc_count_bit_vector_total_size, pl);
3730 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3732 HACK_O_MATIC (symbol, "symbol-storage", pl);
3733 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3734 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3736 HACK_O_MATIC (cons, "cons-storage", pl);
3737 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3738 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3740 /* The things we do for backwards-compatibility */
3742 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3743 make_int (gc_count_num_cons_freelist)),
3744 Fcons (make_int (gc_count_num_symbol_in_use),
3745 make_int (gc_count_num_symbol_freelist)),
3746 Fcons (make_int (gc_count_num_marker_in_use),
3747 make_int (gc_count_num_marker_freelist)),
3748 make_int (gc_count_string_total_size),
3749 make_int (gc_count_vector_total_size),
3754 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3755 Return the number of bytes consed since the last garbage collection.
3756 \"Consed\" is a misnomer in that this actually counts allocation
3757 of all different kinds of objects, not just conses.
3759 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3763 return make_int (consing_since_gc);
3767 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
3768 Return the address of the last byte Emacs has allocated, divided by 1024.
3769 This may be helpful in debugging Emacs's memory usage.
3770 The value is divided by 1024 to make sure it will fit in a lisp integer.
3774 return make_int ((EMACS_INT) sbrk (0) / 1024);
3780 object_dead_p (Lisp_Object obj)
3782 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3783 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3784 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3785 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3786 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3787 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3788 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3791 #ifdef MEMORY_USAGE_STATS
3793 /* Attempt to determine the actual amount of space that is used for
3794 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3796 It seems that the following holds:
3798 1. When using the old allocator (malloc.c):
3800 -- blocks are always allocated in chunks of powers of two. For
3801 each block, there is an overhead of 8 bytes if rcheck is not
3802 defined, 20 bytes if it is defined. In other words, a
3803 one-byte allocation needs 8 bytes of overhead for a total of
3804 9 bytes, and needs to have 16 bytes of memory chunked out for
3807 2. When using the new allocator (gmalloc.c):
3809 -- blocks are always allocated in chunks of powers of two up
3810 to 4096 bytes. Larger blocks are allocated in chunks of
3811 an integral multiple of 4096 bytes. The minimum block
3812 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3813 is defined. There is no per-block overhead, but there
3814 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3817 3. When using the system malloc, anything goes, but they are
3818 generally slower and more space-efficient than the GNU
3819 allocators. One possibly reasonable assumption to make
3820 for want of better data is that sizeof (void *), or maybe
3821 2 * sizeof (void *), is required as overhead and that
3822 blocks are allocated in the minimum required size except
3823 that some minimum block size is imposed (e.g. 16 bytes). */
3826 malloced_storage_size (void *ptr, size_t claimed_size,
3827 struct overhead_stats *stats)
3829 size_t orig_claimed_size = claimed_size;
3833 if (claimed_size < 2 * sizeof (void *))
3834 claimed_size = 2 * sizeof (void *);
3835 # ifdef SUNOS_LOCALTIME_BUG
3836 if (claimed_size < 16)
3839 if (claimed_size < 4096)
3843 /* compute the log base two, more or less, then use it to compute
3844 the block size needed. */
3846 /* It's big, it's heavy, it's wood! */
3847 while ((claimed_size /= 2) != 0)
3850 /* It's better than bad, it's good! */
3856 /* We have to come up with some average about the amount of
3858 if ((size_t) (rand () & 4095) < claimed_size)
3859 claimed_size += 3 * sizeof (void *);
3863 claimed_size += 4095;
3864 claimed_size &= ~4095;
3865 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3868 #elif defined (SYSTEM_MALLOC)
3870 if (claimed_size < 16)
3872 claimed_size += 2 * sizeof (void *);
3874 #else /* old GNU allocator */
3876 # ifdef rcheck /* #### may not be defined here */
3884 /* compute the log base two, more or less, then use it to compute
3885 the block size needed. */
3887 /* It's big, it's heavy, it's wood! */
3888 while ((claimed_size /= 2) != 0)
3891 /* It's better than bad, it's good! */
3899 #endif /* old GNU allocator */
3903 stats->was_requested += orig_claimed_size;
3904 stats->malloc_overhead += claimed_size - orig_claimed_size;
3906 return claimed_size;
3910 fixed_type_block_overhead (size_t size)
3912 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3913 size_t overhead = 0;
3914 size_t storage_size = malloced_storage_size (0, per_block, 0);
3915 while (size >= per_block)
3918 overhead += sizeof (void *) + per_block - storage_size;
3920 if (rand () % per_block < size)
3921 overhead += sizeof (void *) + per_block - storage_size;
3925 #endif /* MEMORY_USAGE_STATS */
3928 /* Initialization */
3930 reinit_alloc_once_early (void)
3932 gc_generation_number[0] = 0;
3933 breathing_space = 0;
3934 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3935 XSETINT (Vgc_message, 0);
3937 ignore_malloc_warnings = 1;
3938 #ifdef DOUG_LEA_MALLOC
3939 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3940 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3941 #if 0 /* Moved to emacs.c */
3942 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3945 init_string_alloc ();
3946 init_string_chars_alloc ();
3948 init_symbol_alloc ();
3949 init_compiled_function_alloc ();
3950 #ifdef LISP_FLOAT_TYPE
3951 init_float_alloc ();
3952 #endif /* LISP_FLOAT_TYPE */
3953 init_marker_alloc ();
3954 init_extent_alloc ();
3955 init_event_alloc ();
3957 ignore_malloc_warnings = 0;
3959 staticidx_nodump = 0;
3963 consing_since_gc = 0;
3965 gc_cons_threshold = 500000; /* XEmacs change */
3967 gc_cons_threshold = 15000; /* debugging */
3969 #ifdef VIRT_ADDR_VARIES
3970 malloc_sbrk_unused = 1<<22; /* A large number */
3971 malloc_sbrk_used = 100000; /* as reasonable as any number */
3972 #endif /* VIRT_ADDR_VARIES */
3973 lrecord_uid_counter = 259;
3974 debug_string_purity = 0;
3977 gc_currently_forbidden = 0;
3978 gc_hooks_inhibited = 0;
3980 #ifdef ERROR_CHECK_TYPECHECK
3981 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3984 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3986 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3988 #endif /* ERROR_CHECK_TYPECHECK */
3992 init_alloc_once_early (void)
3994 reinit_alloc_once_early ();
3996 last_lrecord_type_index_assigned = lrecord_type_count - 1;
4000 for (i = 0; i < countof (lrecord_implementations_table); i++)
4001 lrecord_implementations_table[i] = 0;
4004 INIT_LRECORD_IMPLEMENTATION (cons);
4005 INIT_LRECORD_IMPLEMENTATION (vector);
4006 INIT_LRECORD_IMPLEMENTATION (string);
4007 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
4012 int pure_bytes_used = 0;
4021 syms_of_alloc (void)
4023 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
4024 defsymbol (&Qpost_gc_hook, "post-gc-hook");
4025 defsymbol (&Qgarbage_collecting, "garbage-collecting");
4030 DEFSUBR (Fbit_vector);
4031 DEFSUBR (Fmake_byte_code);
4032 DEFSUBR (Fmake_list);
4033 DEFSUBR (Fmake_vector);
4034 DEFSUBR (Fmake_bit_vector);
4035 DEFSUBR (Fmake_string);
4037 DEFSUBR (Fmake_symbol);
4038 DEFSUBR (Fmake_marker);
4039 DEFSUBR (Fpurecopy);
4040 DEFSUBR (Fgarbage_collect);
4042 DEFSUBR (Fmemory_limit);
4044 DEFSUBR (Fconsing_since_gc);
4048 vars_of_alloc (void)
4050 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
4051 *Number of bytes of consing between garbage collections.
4052 \"Consing\" is a misnomer in that this actually counts allocation
4053 of all different kinds of objects, not just conses.
4054 Garbage collection can happen automatically once this many bytes have been
4055 allocated since the last garbage collection. All data types count.
4057 Garbage collection happens automatically when `eval' or `funcall' are
4058 called. (Note that `funcall' is called implicitly as part of evaluation.)
4059 By binding this temporarily to a large number, you can effectively
4060 prevent garbage collection during a part of the program.
4062 See also `consing-since-gc'.
4065 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
4066 Number of bytes of sharable Lisp data allocated so far.
4070 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
4071 Number of bytes of unshared memory allocated in this session.
4074 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
4075 Number of bytes of unshared memory remaining available in this session.
4080 DEFVAR_INT ("debug-allocation", &debug_allocation /*
4081 If non-zero, print out information to stderr about all objects allocated.
4082 See also `debug-allocation-backtrace-length'.
4084 debug_allocation = 0;
4086 DEFVAR_INT ("debug-allocation-backtrace-length",
4087 &debug_allocation_backtrace_length /*
4088 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
4090 debug_allocation_backtrace_length = 2;
4093 DEFVAR_BOOL ("purify-flag", &purify_flag /*
4094 Non-nil means loading Lisp code in order to dump an executable.
4095 This means that certain objects should be allocated in readonly space.
4098 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
4099 Function or functions to be run just before each garbage collection.
4100 Interrupts, garbage collection, and errors are inhibited while this hook
4101 runs, so be extremely careful in what you add here. In particular, avoid
4102 consing, and do not interact with the user.
4104 Vpre_gc_hook = Qnil;
4106 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4107 Function or functions to be run just after each garbage collection.
4108 Interrupts, garbage collection, and errors are inhibited while this hook
4109 runs, so be extremely careful in what you add here. In particular, avoid
4110 consing, and do not interact with the user.
4112 Vpost_gc_hook = Qnil;
4114 DEFVAR_LISP ("gc-message", &Vgc_message /*
4115 String to print to indicate that a garbage collection is in progress.
4116 This is printed in the echo area. If the selected frame is on a
4117 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4118 image instance) in the domain of the selected frame, the mouse pointer
4119 will change instead of this message being printed.
4121 Vgc_message = build_string (gc_default_message);
4123 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4124 Pointer glyph used to indicate that a garbage collection is in progress.
4125 If the selected window is on a window system and this glyph specifies a
4126 value (i.e. a pointer image instance) in the domain of the selected
4127 window, the pointer will be changed as specified during garbage collection.
4128 Otherwise, a message will be printed in the echo area, as controlled
4134 complex_vars_of_alloc (void)
4136 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
4142 /* The structure of the file
4145 * 256 - dumped objects
4146 * stab_offset - nb_staticpro*(Lisp_Object *) from staticvec
4147 * - nb_staticpro*(relocated Lisp_Object) pointed to by staticpro
4148 * - nb_structdmp*pair(void *, adr) for pointers to structures
4149 * - lrecord_implementations_table[]
4150 * - relocation table
4151 * - wired variable address/value couples with the count preceding the list
4156 EMACS_UINT stab_offset;
4157 EMACS_UINT reloc_address;
4164 char *pdump_start, *pdump_end;
4166 static const unsigned char align_table[256] =
4168 8, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4169 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4170 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4171 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
4172 6, 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 7, 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 6, 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
4186 typedef struct pdump_entry_list_elmt
4188 struct pdump_entry_list_elmt *next;
4193 EMACS_INT save_offset;
4194 } pdump_entry_list_elmt;
4198 pdump_entry_list_elmt *first;
4203 typedef struct pdump_struct_list_elmt
4205 pdump_entry_list list;
4206 const struct struct_description *sdesc;
4207 } pdump_struct_list_elmt;
4211 pdump_struct_list_elmt *list;
4214 } pdump_struct_list;
4216 static pdump_entry_list pdump_object_table[256];
4217 static pdump_entry_list pdump_opaque_data_list;
4218 static pdump_struct_list pdump_struct_table;
4219 static pdump_entry_list_elmt *pdump_qnil;
4221 static int pdump_alert_undump_object[256];
4223 static unsigned long cur_offset;
4224 static size_t max_size;
4225 static int pdump_fd;
4226 static void *pdump_buf;
4228 #define PDUMP_HASHSIZE 200001
4230 static pdump_entry_list_elmt **pdump_hash;
4232 /* Since most pointers are eight bytes aligned, the >>3 allows for a better hash */
4234 pdump_make_hash (const void *obj)
4236 return ((unsigned long)(obj)>>3) % PDUMP_HASHSIZE;
4239 static pdump_entry_list_elmt *
4240 pdump_get_entry (const void *obj)
4242 int pos = pdump_make_hash (obj);
4243 pdump_entry_list_elmt *e;
4247 while ((e = pdump_hash[pos]) != 0)
4253 if (pos == PDUMP_HASHSIZE)
4260 pdump_add_entry (pdump_entry_list *list, const void *obj, size_t size, int count, int is_lrecord)
4262 pdump_entry_list_elmt *e;
4264 int pos = pdump_make_hash (obj);
4266 while ((e = pdump_hash[pos]) != 0)
4272 if (pos == PDUMP_HASHSIZE)
4276 e = xnew (pdump_entry_list_elmt);
4278 e->next = list->first;
4282 e->is_lrecord = is_lrecord;
4285 list->count += count;
4286 pdump_hash[pos] = e;
4288 align = align_table[size & 255];
4289 if (align < 2 && is_lrecord)
4292 if (align < list->align)
4293 list->align = align;
4296 static pdump_entry_list *
4297 pdump_get_entry_list (const struct struct_description *sdesc)
4300 for (i=0; i<pdump_struct_table.count; i++)
4301 if (pdump_struct_table.list[i].sdesc == sdesc)
4302 return &pdump_struct_table.list[i].list;
4304 if (pdump_struct_table.size <= pdump_struct_table.count)
4306 if (pdump_struct_table.size == -1)
4307 pdump_struct_table.size = 10;
4309 pdump_struct_table.size = pdump_struct_table.size * 2;
4310 pdump_struct_table.list = (pdump_struct_list_elmt *)
4311 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;
4324 struct lrecord_header *obj;
4331 static void pdump_backtrace (void)
4334 fprintf (stderr, "pdump backtrace :\n");
4335 for (i=0;i<depth;i++)
4337 if (!backtrace[i].obj)
4338 fprintf (stderr, " - ind. (%d, %d)\n", backtrace[i].position, backtrace[i].offset);
4341 fprintf (stderr, " - %s (%d, %d)\n",
4342 LHEADER_IMPLEMENTATION (backtrace[i].obj)->name,
4343 backtrace[i].position,
4344 backtrace[i].offset);
4349 static void pdump_register_object (Lisp_Object obj);
4350 static void pdump_register_struct (const void *data, const struct struct_description *sdesc, int count);
4353 pdump_get_indirect_count (EMACS_INT code, const struct lrecord_description *idesc, const void *idata)
4358 int line = XD_INDIRECT_VAL (code);
4359 int delta = XD_INDIRECT_DELTA (code);
4361 irdata = ((char *)idata) + idesc[line].offset;
4362 switch (idesc[line].type)
4365 count = *(size_t *)irdata;
4368 count = *(int *)irdata;
4371 count = *(long *)irdata;
4374 count = *(Bytecount *)irdata;
4377 fprintf (stderr, "Unsupported count type : %d (line = %d, code=%ld)\n", idesc[line].type, line, (long)code);
4386 pdump_register_sub (const void *data, const struct lrecord_description *desc, int me)
4391 for (pos = 0; desc[pos].type != XD_END; pos++)
4393 const void *rdata = (const char *)data + desc[pos].offset;
4395 backtrace[me].position = pos;
4396 backtrace[me].offset = desc[pos].offset;
4398 switch (desc[pos].type)
4400 case XD_SPECIFIER_END:
4402 desc = ((const Lisp_Specifier *)data)->methods->extra_description;
4408 case XD_LO_RESET_NIL:
4412 case XD_OPAQUE_DATA_PTR:
4414 EMACS_INT count = desc[pos].data1;
4415 if (XD_IS_INDIRECT (count))
4416 count = pdump_get_indirect_count (count, desc, data);
4418 pdump_add_entry (&pdump_opaque_data_list,
4427 const char *str = *(const char **)rdata;
4429 pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
4434 const char *str = *(const char **)rdata;
4435 if ((EMACS_INT)str > 0)
4436 pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
4439 case XD_LISP_OBJECT:
4441 const Lisp_Object *pobj = (const Lisp_Object *)rdata;
4443 assert (desc[pos].data1 == 0);
4445 backtrace[me].offset = (const char *)pobj - (const char *)data;
4446 pdump_register_object (*pobj);
4449 case XD_LISP_OBJECT_ARRAY:
4452 EMACS_INT count = desc[pos].data1;
4453 if (XD_IS_INDIRECT (count))
4454 count = pdump_get_indirect_count (count, desc, data);
4456 for (i = 0; i < count; i++)
4458 const Lisp_Object *pobj = ((const Lisp_Object *)rdata) + i;
4459 Lisp_Object dobj = *pobj;
4461 backtrace[me].offset = (const char *)pobj - (const char *)data;
4462 pdump_register_object (dobj);
4468 EMACS_INT count = desc[pos].data1;
4469 const struct struct_description *sdesc = desc[pos].data2;
4470 const char *dobj = *(const char **)rdata;
4473 if (XD_IS_INDIRECT (count))
4474 count = pdump_get_indirect_count (count, desc, data);
4476 pdump_register_struct (dobj, sdesc, count);
4481 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4489 pdump_register_object (Lisp_Object obj)
4491 struct lrecord_header *objh;
4493 if (!POINTER_TYPE_P (XTYPE (obj)))
4496 objh = XRECORD_LHEADER (obj);
4500 if (pdump_get_entry (objh))
4503 if (LHEADER_IMPLEMENTATION (objh)->description)
4508 fprintf (stderr, "Backtrace overflow, loop ?\n");
4511 backtrace[me].obj = objh;
4512 backtrace[me].position = 0;
4513 backtrace[me].offset = 0;
4515 pdump_add_entry (pdump_object_table + objh->type,
4517 LHEADER_IMPLEMENTATION (objh)->static_size ?
4518 LHEADER_IMPLEMENTATION (objh)->static_size :
4519 LHEADER_IMPLEMENTATION (objh)->size_in_bytes_method (objh),
4522 pdump_register_sub (objh,
4523 LHEADER_IMPLEMENTATION (objh)->description,
4529 pdump_alert_undump_object[objh->type]++;
4530 fprintf (stderr, "Undumpable object type : %s\n", LHEADER_IMPLEMENTATION (objh)->name);
4536 pdump_register_struct (const void *data, const struct struct_description *sdesc, int count)
4538 if (data && !pdump_get_entry (data))
4544 fprintf (stderr, "Backtrace overflow, loop ?\n");
4547 backtrace[me].obj = 0;
4548 backtrace[me].position = 0;
4549 backtrace[me].offset = 0;
4551 pdump_add_entry (pdump_get_entry_list (sdesc),
4556 for (i=0; i<count; i++)
4558 pdump_register_sub (((char *)data) + sdesc->size*i,
4567 pdump_dump_data (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
4569 size_t size = elmt->size;
4570 int count = elmt->count;
4574 memcpy (pdump_buf, elmt->obj, size*count);
4576 for (i=0; i<count; i++)
4578 char *cur = ((char *)pdump_buf) + i*size;
4580 for (pos = 0; desc[pos].type != XD_END; pos++)
4582 void *rdata = cur + desc[pos].offset;
4583 switch (desc[pos].type)
4585 case XD_SPECIFIER_END:
4586 desc = ((const Lisp_Specifier *)(elmt->obj))->methods->extra_description;
4593 case XD_LO_RESET_NIL:
4595 EMACS_INT count = desc[pos].data1;
4597 if (XD_IS_INDIRECT (count))
4598 count = pdump_get_indirect_count (count, desc, elmt->obj);
4599 for (i=0; i<count; i++)
4600 ((EMACS_INT *)rdata)[i] = pdump_qnil->save_offset;
4605 EMACS_INT val = desc[pos].data1;
4606 if (XD_IS_INDIRECT (val))
4607 val = pdump_get_indirect_count (val, desc, elmt->obj);
4608 *(int *)rdata = val;
4611 case XD_OPAQUE_DATA_PTR:
4615 void *ptr = *(void **)rdata;
4617 *(EMACS_INT *)rdata = pdump_get_entry (ptr)->save_offset;
4622 Lisp_Object obj = *(Lisp_Object *)rdata;
4623 pdump_entry_list_elmt *elmt1;
4626 elmt1 = pdump_get_entry (XRECORD_LHEADER (obj));
4629 obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
4631 *(EMACS_INT *)rdata = elmt1->save_offset;
4634 case XD_LISP_OBJECT:
4636 Lisp_Object *pobj = (Lisp_Object *) rdata;
4638 assert (desc[pos].data1 == 0);
4640 if (POINTER_TYPE_P (XTYPE (*pobj)) && XRECORD_LHEADER (*pobj))
4641 *(EMACS_INT *)pobj =
4642 pdump_get_entry (XRECORD_LHEADER (*pobj))->save_offset;
4645 case XD_LISP_OBJECT_ARRAY:
4647 EMACS_INT count = desc[pos].data1;
4649 if (XD_IS_INDIRECT (count))
4650 count = pdump_get_indirect_count (count, desc, elmt->obj);
4652 for (i=0; i<count; i++)
4654 Lisp_Object *pobj = ((Lisp_Object *)rdata) + i;
4655 if (POINTER_TYPE_P (XTYPE (*pobj)) && XRECORD_LHEADER (*pobj))
4656 *(EMACS_INT *)pobj =
4657 pdump_get_entry (XRECORD_LHEADER (*pobj))->save_offset;
4663 EMACS_INT str = *(EMACS_INT *)rdata;
4665 *(EMACS_INT *)rdata = pdump_get_entry ((void *)str)->save_offset;
4669 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4675 write (pdump_fd, desc ? pdump_buf : elmt->obj, size*count);
4676 if (elmt->is_lrecord && ((size*count) & 3))
4677 write (pdump_fd, "\0\0\0", 4-((size*count) & 3));
4681 pdump_reloc_one (void *data, EMACS_INT delta, const struct lrecord_description *desc)
4686 for (pos = 0; desc[pos].type != XD_END; pos++)
4688 void *rdata = (char *)data + desc[pos].offset;
4689 switch (desc[pos].type)
4691 case XD_SPECIFIER_END:
4693 desc = ((const Lisp_Specifier *)data)->methods->extra_description;
4701 case XD_OPAQUE_DATA_PTR:
4706 EMACS_INT ptr = *(EMACS_INT *)rdata;
4708 *(EMACS_INT *)rdata = ptr+delta;
4711 case XD_LISP_OBJECT:
4713 Lisp_Object *pobj = (Lisp_Object *) rdata;
4715 assert (desc[pos].data1 == 0);
4717 if (POINTER_TYPE_P (XTYPE (*pobj))
4718 && ! EQ (*pobj, Qnull_pointer))
4719 XSETOBJ (*pobj, XTYPE (*pobj), (char *) XPNTR (*pobj) + delta);
4723 case XD_LISP_OBJECT_ARRAY:
4724 case XD_LO_RESET_NIL:
4726 EMACS_INT count = desc[pos].data1;
4728 if (XD_IS_INDIRECT (count))
4729 count = pdump_get_indirect_count (count, desc, data);
4731 for (i=0; i<count; i++)
4733 Lisp_Object *pobj = (Lisp_Object *) rdata + i;
4735 if (POINTER_TYPE_P (XTYPE (*pobj))
4736 && ! EQ (*pobj, Qnull_pointer))
4737 XSETOBJ (*pobj, XTYPE (*pobj), (char *) XPNTR (*pobj) + delta);
4743 EMACS_INT str = *(EMACS_INT *)rdata;
4745 *(EMACS_INT *)rdata = str + delta;
4749 fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
4756 pdump_allocate_offset (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
4758 size_t size = (elmt->is_lrecord ? (elmt->size + 3) & ~3 : elmt->size)*elmt->count;
4759 elmt->save_offset = cur_offset;
4766 pdump_scan_by_alignment (void (*f)(pdump_entry_list_elmt *, const struct lrecord_description *))
4769 const struct lrecord_description *idesc;
4770 pdump_entry_list_elmt *elmt;
4771 for (align=8; align>=0; align--)
4773 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4774 if (pdump_object_table[i].align == align)
4776 elmt = pdump_object_table[i].first;
4779 idesc = lrecord_implementations_table[i]->description;
4787 for (i=0; i<pdump_struct_table.count; i++)
4788 if (pdump_struct_table.list[i].list.align == align)
4790 elmt = pdump_struct_table.list[i].list.first;
4791 idesc = pdump_struct_table.list[i].sdesc->description;
4799 elmt = pdump_opaque_data_list.first;
4802 if (align_table[elmt->size & 255] == align)
4810 pdump_dump_staticvec (void)
4812 EMACS_INT *reloc = xnew_array (EMACS_INT, staticidx);
4814 write (pdump_fd, staticvec, staticidx*sizeof (Lisp_Object *));
4816 for (i=0; i<staticidx; i++)
4818 Lisp_Object obj = *staticvec[i];
4819 if (POINTER_TYPE_P (XTYPE (obj)))
4820 reloc[i] = pdump_get_entry (XRECORD_LHEADER (obj))->save_offset;
4822 reloc[i] = *(EMACS_INT *)(staticvec[i]);
4824 write (pdump_fd, reloc, staticidx*sizeof (Lisp_Object));
4829 pdump_dump_structvec (void)
4832 for (i=0; i<dumpstructidx; i++)
4835 write (pdump_fd, &(dumpstructvec[i].data), sizeof (void *));
4836 adr = pdump_get_entry (*(void **)(dumpstructvec[i].data))->save_offset;
4837 write (pdump_fd, &adr, sizeof (adr));
4842 pdump_dump_opaquevec (void)
4845 for (i=0; i<dumpopaqueidx; i++)
4847 write (pdump_fd, &(dumpopaquevec[i]), sizeof (dumpopaquevec[i]));
4848 write (pdump_fd, dumpopaquevec[i].data, dumpopaquevec[i].size);
4853 pdump_dump_itable (void)
4855 write (pdump_fd, lrecord_implementations_table, sizeof (lrecord_implementations_table));
4859 pdump_dump_rtables (void)
4862 pdump_entry_list_elmt *elmt;
4863 pdump_reloc_table rt;
4865 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4867 elmt = pdump_object_table[i].first;
4870 rt.desc = lrecord_implementations_table[i]->description;
4871 rt.count = pdump_object_table[i].count;
4872 write (pdump_fd, &rt, sizeof (rt));
4875 EMACS_INT rdata = pdump_get_entry (elmt->obj)->save_offset;
4876 write (pdump_fd, &rdata, sizeof (rdata));
4883 write (pdump_fd, &rt, sizeof (rt));
4885 for (i=0; i<pdump_struct_table.count; i++)
4887 elmt = pdump_struct_table.list[i].list.first;
4888 rt.desc = pdump_struct_table.list[i].sdesc->description;
4889 rt.count = pdump_struct_table.list[i].list.count;
4890 write (pdump_fd, &rt, sizeof (rt));
4893 EMACS_INT rdata = pdump_get_entry (elmt->obj)->save_offset;
4894 for (j=0; j<elmt->count; j++)
4896 write (pdump_fd, &rdata, sizeof (rdata));
4897 rdata += elmt->size;
4904 write (pdump_fd, &rt, sizeof (rt));
4908 pdump_dump_wired (void)
4910 EMACS_INT count = pdump_wireidx + pdump_wireidx_list;
4913 write (pdump_fd, &count, sizeof (count));
4915 for (i=0; i<pdump_wireidx; i++)
4917 EMACS_INT obj = pdump_get_entry (XRECORD_LHEADER (*(pdump_wirevec[i])))->save_offset;
4918 write (pdump_fd, &pdump_wirevec[i], sizeof (pdump_wirevec[i]));
4919 write (pdump_fd, &obj, sizeof (obj));
4922 for (i=0; i<pdump_wireidx_list; i++)
4924 Lisp_Object obj = *(pdump_wirevec_list[i]);
4925 pdump_entry_list_elmt *elmt;
4930 const struct lrecord_description *desc;
4932 elmt = pdump_get_entry (XRECORD_LHEADER (obj));
4935 desc = XRECORD_LHEADER_IMPLEMENTATION (obj)->description;
4936 for (pos = 0; desc[pos].type != XD_LO_LINK; pos++)
4937 if (desc[pos].type == XD_END)
4940 obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
4942 res = elmt->save_offset;
4944 write (pdump_fd, &pdump_wirevec_list[i], sizeof (pdump_wirevec_list[i]));
4945 write (pdump_fd, &res, sizeof (res));
4953 Lisp_Object t_console, t_device, t_frame;
4957 /* These appear in a DEFVAR_LISP, which does a staticpro() */
4958 t_console = Vterminal_console;
4959 t_frame = Vterminal_frame;
4960 t_device = Vterminal_device;
4962 Vterminal_console = Qnil;
4963 Vterminal_frame = Qnil;
4964 Vterminal_device = Qnil;
4966 pdump_hash = xnew_array_and_zero (pdump_entry_list_elmt *, PDUMP_HASHSIZE);
4968 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4970 pdump_object_table[i].first = 0;
4971 pdump_object_table[i].align = 8;
4972 pdump_object_table[i].count = 0;
4973 pdump_alert_undump_object[i] = 0;
4975 pdump_struct_table.count = 0;
4976 pdump_struct_table.size = -1;
4978 pdump_opaque_data_list.first = 0;
4979 pdump_opaque_data_list.align = 8;
4980 pdump_opaque_data_list.count = 0;
4983 for (i=0; i<staticidx; i++)
4984 pdump_register_object (*staticvec[i]);
4985 for (i=0; i<pdump_wireidx; i++)
4986 pdump_register_object (*pdump_wirevec[i]);
4989 for (i=0; i<=last_lrecord_type_index_assigned; i++)
4990 if (pdump_alert_undump_object[i])
4993 printf ("Undumpable types list :\n");
4995 printf (" - %s (%d)\n", lrecord_implementations_table[i]->name, pdump_alert_undump_object[i]);
5000 for (i=0; i<dumpstructidx; i++)
5001 pdump_register_struct (*(void **)(dumpstructvec[i].data), dumpstructvec[i].desc, 1);
5003 memcpy (hd.signature, "XEmacsDP", 8);
5004 hd.reloc_address = 0;
5005 hd.nb_staticpro = staticidx;
5006 hd.nb_structdmp = dumpstructidx;
5007 hd.nb_opaquedmp = dumpopaqueidx;
5008 hd.last_type = last_lrecord_type_index_assigned;
5013 pdump_scan_by_alignment (pdump_allocate_offset);
5014 pdump_qnil = pdump_get_entry (XRECORD_LHEADER (Qnil));
5016 pdump_buf = xmalloc (max_size);
5017 /* Avoid use of the `open' macro. We want the real function. */
5019 pdump_fd = open ("xemacs.dmp",
5020 O_WRONLY | O_CREAT | O_TRUNC | OPEN_BINARY, 0666);
5021 hd.stab_offset = (cur_offset + 3) & ~3;
5023 write (pdump_fd, &hd, sizeof (hd));
5024 lseek (pdump_fd, 256, SEEK_SET);
5026 pdump_scan_by_alignment (pdump_dump_data);
5028 lseek (pdump_fd, hd.stab_offset, SEEK_SET);
5030 pdump_dump_staticvec ();
5031 pdump_dump_structvec ();
5032 pdump_dump_opaquevec ();
5033 pdump_dump_itable ();
5034 pdump_dump_rtables ();
5035 pdump_dump_wired ();
5042 Vterminal_console = t_console;
5043 Vterminal_frame = t_frame;
5044 Vterminal_device = t_device;
5056 #define PDUMP_READ(p, type) (p = (char*) (((type *) p) + 1), *((type *) p - 1))
5058 pdump_start = pdump_end = 0;
5060 pdump_fd = open ("xemacs.dmp", O_RDONLY | OPEN_BINARY);
5064 length = lseek (pdump_fd, 0, SEEK_END);
5065 lseek (pdump_fd, 0, SEEK_SET);
5068 pdump_start = (char *) mmap (0, length, PROT_READ|PROT_WRITE, MAP_PRIVATE, pdump_fd, 0);
5069 if (pdump_start == MAP_FAILED)
5075 pdump_start = (char *)((((unsigned long)(xmalloc(length+255))) + 255) & ~255);
5076 read (pdump_fd, pdump_start, length);
5081 pdump_end = pdump_start + length;
5083 staticidx = ((dump_header *)(pdump_start))->nb_staticpro;
5084 last_lrecord_type_index_assigned = ((dump_header *)pdump_start)->last_type;
5085 delta = ((EMACS_INT)pdump_start) - ((dump_header *)pdump_start)->reloc_address;
5086 p = pdump_start + ((dump_header *)pdump_start)->stab_offset;
5088 /* Put back the staticvec in place */
5089 memcpy (staticvec, p, staticidx*sizeof (Lisp_Object *));
5090 p += staticidx*sizeof (Lisp_Object *);
5091 for (i=0; i<staticidx; i++)
5093 Lisp_Object obj = PDUMP_READ (p, Lisp_Object);
5094 if (POINTER_TYPE_P (XTYPE (obj)))
5095 XSETOBJ (obj, XTYPE (obj), (char *) XPNTR (obj) + delta);
5096 *staticvec[i] = obj;
5099 /* Put back the dumpstructs */
5100 for (i=0; i<((dump_header *)pdump_start)->nb_structdmp; i++)
5102 void **adr = PDUMP_READ (p, void **);
5103 *adr = (void *) (PDUMP_READ (p, char *) + delta);
5106 /* Put back the opaques */
5107 for (i=0; i<((dump_header *)pdump_start)->nb_opaquedmp; i++)
5109 struct dumpopaque_info di = PDUMP_READ (p, struct dumpopaque_info);
5110 memcpy (di.data, p, di.size);
5114 /* Put back the lrecord_implementations_table */
5115 memcpy (lrecord_implementations_table, p, sizeof (lrecord_implementations_table));
5116 p += sizeof (lrecord_implementations_table);
5118 /* Reinitialize lrecord_markers from lrecord_implementations_table */
5119 for (i=0; i < countof (lrecord_implementations_table); i++)
5120 if (lrecord_implementations_table[i])
5121 lrecord_markers[i] = lrecord_implementations_table[i]->marker;
5123 /* Do the relocations */
5128 pdump_reloc_table rt = PDUMP_READ (p, pdump_reloc_table);
5131 for (i=0; i < rt.count; i++)
5133 char *adr = delta + *(char **)p;
5135 pdump_reloc_one (adr, delta, rt.desc);
5136 p += sizeof (char *);
5143 /* Put the pdump_wire variables in place */
5144 count = PDUMP_READ (p, EMACS_INT);
5146 for (i=0; i<count; i++)
5148 Lisp_Object *var = PDUMP_READ (p, Lisp_Object *);
5149 Lisp_Object obj = PDUMP_READ (p, Lisp_Object);
5151 if (POINTER_TYPE_P (XTYPE (obj)))
5152 XSETOBJ (obj, XTYPE (obj), (char *) XPNTR (obj) + delta);
5157 /* Final cleanups */
5158 /* reorganize hash tables */
5162 pdump_reloc_table rt = PDUMP_READ (p, pdump_reloc_table);
5165 if (rt.desc == hash_table_description)
5167 for (i=0; i < rt.count; i++)
5168 pdump_reorganize_hash_table (PDUMP_READ (p, Lisp_Object));
5171 p += sizeof (Lisp_Object) * rt.count;
5174 /* Put back noninteractive1 to its real value */
5175 noninteractive1 = noninteractive;