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.
45 #include "backtrace.h"
56 #include "redisplay.h"
57 #include "specifier.h"
63 #ifdef DOUG_LEA_MALLOC
67 EXFUN (Fgarbage_collect, 0);
69 /* Return the true size of a struct with a variable-length array field. */
70 #define STRETCHY_STRUCT_SIZEOF(stretchy_struct_type, \
71 stretchy_array_field, \
72 stretchy_array_length) \
73 (offsetof (stretchy_struct_type, stretchy_array_field) + \
74 (offsetof (stretchy_struct_type, stretchy_array_field[1]) - \
75 offsetof (stretchy_struct_type, stretchy_array_field[0])) * \
76 (stretchy_array_length))
78 #if 0 /* this is _way_ too slow to be part of the standard debug options */
79 #if defined(DEBUG_XEMACS) && defined(MULE)
80 #define VERIFY_STRING_CHARS_INTEGRITY
84 /* Define this to use malloc/free with no freelist for all datatypes,
85 the hope being that some debugging tools may help detect
86 freed memory references */
87 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
89 #define ALLOC_NO_POOLS
93 static int debug_allocation;
94 static int debug_allocation_backtrace_length;
97 /* Number of bytes of consing done since the last gc */
98 EMACS_INT consing_since_gc;
99 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
101 #define debug_allocation_backtrace() \
103 if (debug_allocation_backtrace_length > 0) \
104 debug_short_backtrace (debug_allocation_backtrace_length); \
108 #define INCREMENT_CONS_COUNTER(foosize, type) \
110 if (debug_allocation) \
112 stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
113 debug_allocation_backtrace (); \
115 INCREMENT_CONS_COUNTER_1 (foosize); \
117 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \
119 if (debug_allocation > 1) \
121 stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
122 debug_allocation_backtrace (); \
124 INCREMENT_CONS_COUNTER_1 (foosize); \
127 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
128 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
129 INCREMENT_CONS_COUNTER_1 (size)
132 #define DECREMENT_CONS_COUNTER(size) do { \
133 consing_since_gc -= (size); \
134 if (consing_since_gc < 0) \
135 consing_since_gc = 0; \
138 /* Number of bytes of consing since gc before another gc should be done. */
139 EMACS_INT gc_cons_threshold;
141 /* Nonzero during gc */
144 /* Number of times GC has happened at this level or below.
145 * Level 0 is most volatile, contrary to usual convention.
146 * (Of course, there's only one level at present) */
147 EMACS_INT gc_generation_number[1];
149 /* This is just for use by the printer, to allow things to print uniquely */
150 static int lrecord_uid_counter;
152 /* Nonzero when calling certain hooks or doing other things where
154 int gc_currently_forbidden;
157 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
158 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
160 /* "Garbage collecting" */
161 Lisp_Object Vgc_message;
162 Lisp_Object Vgc_pointer_glyph;
163 static CONST char gc_default_message[] = "Garbage collecting";
164 Lisp_Object Qgarbage_collecting;
166 #ifndef VIRT_ADDR_VARIES
168 #endif /* VIRT_ADDR_VARIES */
169 EMACS_INT malloc_sbrk_used;
171 #ifndef VIRT_ADDR_VARIES
173 #endif /* VIRT_ADDR_VARIES */
174 EMACS_INT malloc_sbrk_unused;
176 /* Non-zero means we're in the process of doing the dump */
180 extern void sheap_adjust_h();
183 #ifdef ERROR_CHECK_TYPECHECK
185 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
190 c_readonly (Lisp_Object obj)
192 return POINTER_TYPE_P (XGCTYPE (obj)) && C_READONLY (obj);
196 lisp_readonly (Lisp_Object obj)
198 return POINTER_TYPE_P (XGCTYPE (obj)) && LISP_READONLY (obj);
202 /* Maximum amount of C stack to save when a GC happens. */
204 #ifndef MAX_SAVE_STACK
205 #define MAX_SAVE_STACK 0 /* 16000 */
208 /* Non-zero means ignore malloc warnings. Set during initialization. */
209 int ignore_malloc_warnings;
212 static void *breathing_space;
215 release_breathing_space (void)
219 void *tmp = breathing_space;
225 /* malloc calls this if it finds we are near exhausting storage */
227 malloc_warning (CONST char *str)
229 if (ignore_malloc_warnings)
235 "Killing some buffers may delay running out of memory.\n"
236 "However, certainly by the time you receive the 95%% warning,\n"
237 "you should clean up, kill this Emacs, and start a new one.",
241 /* Called if malloc returns zero */
245 /* Force a GC next time eval is called.
246 It's better to loop garbage-collecting (we might reclaim enough
247 to win) than to loop beeping and barfing "Memory exhausted"
249 consing_since_gc = gc_cons_threshold + 1;
250 release_breathing_space ();
252 /* Flush some histories which might conceivably contain garbalogical
254 if (!NILP (Fboundp (Qvalues)))
255 Fset (Qvalues, Qnil);
256 Vcommand_history = Qnil;
258 error ("Memory exhausted");
261 /* like malloc and realloc but check for no memory left, and block input. */
268 xmalloc (size_t size)
270 void *val = malloc (size);
272 if (!val && (size != 0)) memory_full ();
281 xcalloc (size_t nelem, size_t elsize)
283 void *val = calloc (nelem, elsize);
285 if (!val && (nelem != 0)) memory_full ();
290 xmalloc_and_zero (size_t size)
292 return xcalloc (size, sizeof (char));
300 xrealloc (void *block, size_t size)
302 /* We must call malloc explicitly when BLOCK is 0, since some
303 reallocs don't do this. */
304 void *val = block ? realloc (block, size) : malloc (size);
306 if (!val && (size != 0)) memory_full ();
311 #ifdef ERROR_CHECK_MALLOC
312 xfree_1 (void *block)
317 #ifdef ERROR_CHECK_MALLOC
318 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
319 error until much later on for many system mallocs, such as
320 the one that comes with Solaris 2.3. FMH!! */
321 assert (block != (void *) 0xDEADBEEF);
323 #endif /* ERROR_CHECK_MALLOC */
327 #ifdef ERROR_CHECK_GC
330 typedef unsigned int four_byte_t;
331 #elif SIZEOF_LONG == 4
332 typedef unsigned long four_byte_t;
333 #elif SIZEOF_SHORT == 4
334 typedef unsigned short four_byte_t;
336 What kind of strange-ass system are we running on?
340 deadbeef_memory (void *ptr, size_t size)
342 four_byte_t *ptr4 = (four_byte_t *) ptr;
343 size_t beefs = size >> 2;
345 /* In practice, size will always be a multiple of four. */
347 (*ptr4++) = 0xDEADBEEF;
350 #else /* !ERROR_CHECK_GC */
353 #define deadbeef_memory(ptr, size)
355 #endif /* !ERROR_CHECK_GC */
362 xstrdup (CONST char *str)
364 int len = strlen (str) + 1; /* for stupid terminating 0 */
366 void *val = xmalloc (len);
367 if (val == 0) return 0;
368 memcpy (val, str, len);
374 strdup (CONST char *s)
378 #endif /* NEED_STRDUP */
382 allocate_lisp_storage (size_t size)
384 void *p = xmalloc (size);
389 /* lrecords are chained together through their "next.v" field.
390 * After doing the mark phase, the GC will walk this linked
391 * list and free any record which hasn't been marked.
393 static struct lcrecord_header *all_lcrecords;
396 alloc_lcrecord (size_t size, CONST struct lrecord_implementation *implementation)
398 struct lcrecord_header *lcheader;
400 #ifdef ERROR_CHECK_GC
401 if (implementation->static_size == 0)
402 assert (implementation->size_in_bytes_method);
404 assert (implementation->static_size == size);
407 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
408 set_lheader_implementation (&(lcheader->lheader), implementation);
409 lcheader->next = all_lcrecords;
410 #if 1 /* mly prefers to see small ID numbers */
411 lcheader->uid = lrecord_uid_counter++;
412 #else /* jwz prefers to see real addrs */
413 lcheader->uid = (int) &lcheader;
416 all_lcrecords = lcheader;
417 INCREMENT_CONS_COUNTER (size, implementation->name);
421 #if 0 /* Presently unused */
422 /* Very, very poor man's EGC?
423 * This may be slow and thrash pages all over the place.
424 * Only call it if you really feel you must (and if the
425 * lrecord was fairly recently allocated).
426 * Otherwise, just let the GC do its job -- that's what it's there for
429 free_lcrecord (struct lcrecord_header *lcrecord)
431 if (all_lcrecords == lcrecord)
433 all_lcrecords = lcrecord->next;
437 struct lrecord_header *header = all_lcrecords;
440 struct lrecord_header *next = header->next;
441 if (next == lcrecord)
443 header->next = lrecord->next;
452 if (lrecord->implementation->finalizer)
453 lrecord->implementation->finalizer (lrecord, 0);
461 disksave_object_finalization_1 (void)
463 struct lcrecord_header *header;
465 for (header = all_lcrecords; header; header = header->next)
467 if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
469 ((LHEADER_IMPLEMENTATION(&header->lheader)->finalizer)
475 /* This must not be called -- it just serves as for EQ test
476 * If lheader->implementation->finalizer is this_marks_a_marked_record,
477 * then lrecord has been marked by the GC sweeper
478 * header->implementation is put back to its correct value by
481 this_marks_a_marked_record (void *dummy0, int dummy1)
486 /* Semi-kludge -- lrecord_symbol_value_forward objects get stuck
487 in CONST space and you get SEGV's if you attempt to mark them.
488 This sits in lheader->implementation->marker. */
491 this_one_is_unmarkable (Lisp_Object obj, void (*markobj) (Lisp_Object))
497 /* XGCTYPE for records */
499 gc_record_type_p (Lisp_Object frob, CONST struct lrecord_implementation *type)
501 CONST struct lrecord_implementation *imp;
503 if (XGCTYPE (frob) != Lisp_Type_Record)
506 imp = XRECORD_LHEADER_IMPLEMENTATION (frob);
511 /************************************************************************/
512 /* Debugger support */
513 /************************************************************************/
514 /* Give gdb/dbx enough information to decode Lisp Objects. We make
515 sure certain symbols are always defined, so gdb doesn't complain
516 about expressions in src/gdbinit. See src/gdbinit or src/dbxrc to
517 see how this is used. */
519 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
520 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
522 #ifdef USE_UNION_TYPE
523 unsigned char dbg_USE_UNION_TYPE = 1;
525 unsigned char dbg_USE_UNION_TYPE = 0;
528 unsigned char Lisp_Type_Int = 100;
529 unsigned char Lisp_Type_Cons = 101;
530 unsigned char Lisp_Type_String = 102;
531 unsigned char Lisp_Type_Vector = 103;
532 unsigned char Lisp_Type_Symbol = 104;
535 unsigned char lrecord_char_table_entry;
536 unsigned char lrecord_charset;
538 unsigned char lrecord_coding_system;
542 #ifndef HAVE_TOOLBARS
543 unsigned char lrecord_toolbar_button;
547 unsigned char lrecord_tooltalk_message;
548 unsigned char lrecord_tooltalk_pattern;
551 #ifndef HAVE_DATABASE
552 unsigned char lrecord_database;
555 unsigned char dbg_valbits = VALBITS;
556 unsigned char dbg_gctypebits = GCTYPEBITS;
558 /* Macros turned into functions for ease of debugging.
559 Debuggers don't know about macros! */
560 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
562 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
564 return EQ (obj1, obj2);
568 /************************************************************************/
569 /* Fixed-size type macros */
570 /************************************************************************/
572 /* For fixed-size types that are commonly used, we malloc() large blocks
573 of memory at a time and subdivide them into chunks of the correct
574 size for an object of that type. This is more efficient than
575 malloc()ing each object separately because we save on malloc() time
576 and overhead due to the fewer number of malloc()ed blocks, and
577 also because we don't need any extra pointers within each object
578 to keep them threaded together for GC purposes. For less common
579 (and frequently large-size) types, we use lcrecords, which are
580 malloc()ed individually and chained together through a pointer
581 in the lcrecord header. lcrecords do not need to be fixed-size
582 (i.e. two objects of the same type need not have the same size;
583 however, the size of a particular object cannot vary dynamically).
584 It is also much easier to create a new lcrecord type because no
585 additional code needs to be added to alloc.c. Finally, lcrecords
586 may be more efficient when there are only a small number of them.
588 The types that are stored in these large blocks (or "frob blocks")
589 are cons, float, compiled-function, symbol, marker, extent, event,
592 Note that strings are special in that they are actually stored in
593 two parts: a structure containing information about the string, and
594 the actual data associated with the string. The former structure
595 (a struct Lisp_String) is a fixed-size structure and is managed the
596 same way as all the other such types. This structure contains a
597 pointer to the actual string data, which is stored in structures of
598 type struct string_chars_block. Each string_chars_block consists
599 of a pointer to a struct Lisp_String, followed by the data for that
600 string, followed by another pointer to a struct Lisp_String,
601 followed by the data for that string, etc. At GC time, the data in
602 these blocks is compacted by searching sequentially through all the
603 blocks and compressing out any holes created by unmarked strings.
604 Strings that are more than a certain size (bigger than the size of
605 a string_chars_block, although something like half as big might
606 make more sense) are malloc()ed separately and not stored in
607 string_chars_blocks. Furthermore, no one string stretches across
608 two string_chars_blocks.
610 Vectors are each malloc()ed separately, similar to lcrecords.
612 In the following discussion, we use conses, but it applies equally
613 well to the other fixed-size types.
615 We store cons cells inside of cons_blocks, allocating a new
616 cons_block with malloc() whenever necessary. Cons cells reclaimed
617 by GC are put on a free list to be reallocated before allocating
618 any new cons cells from the latest cons_block. Each cons_block is
619 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
620 the versions in malloc.c and gmalloc.c) really allocates in units
621 of powers of two and uses 4 bytes for its own overhead.
623 What GC actually does is to search through all the cons_blocks,
624 from the most recently allocated to the oldest, and put all
625 cons cells that are not marked (whether or not they're already
626 free) on a cons_free_list. The cons_free_list is a stack, and
627 so the cons cells in the oldest-allocated cons_block end up
628 at the head of the stack and are the first to be reallocated.
629 If any cons_block is entirely free, it is freed with free()
630 and its cons cells removed from the cons_free_list. Because
631 the cons_free_list ends up basically in memory order, we have
632 a high locality of reference (assuming a reasonable turnover
633 of allocating and freeing) and have a reasonable probability
634 of entirely freeing up cons_blocks that have been more recently
635 allocated. This stage is called the "sweep stage" of GC, and
636 is executed after the "mark stage", which involves starting
637 from all places that are known to point to in-use Lisp objects
638 (e.g. the obarray, where are all symbols are stored; the
639 current catches and condition-cases; the backtrace list of
640 currently executing functions; the gcpro list; etc.) and
641 recursively marking all objects that are accessible.
643 At the beginning of the sweep stage, the conses in the cons
644 blocks are in one of three states: in use and marked, in use
645 but not marked, and not in use (already freed). Any conses
646 that are marked have been marked in the mark stage just
647 executed, because as part of the sweep stage we unmark any
648 marked objects. The way we tell whether or not a cons cell
649 is in use is through the FREE_STRUCT_P macro. This basically
650 looks at the first 4 bytes (or however many bytes a pointer
651 fits in) to see if all the bits in those bytes are 1. The
652 resulting value (0xFFFFFFFF) is not a valid pointer and is
653 not a valid Lisp_Object. All current fixed-size types have
654 a pointer or Lisp_Object as their first element with the
655 exception of strings; they have a size value, which can
656 never be less than zero, and so 0xFFFFFFFF is invalid for
657 strings as well. Now assuming that a cons cell is in use,
658 the way we tell whether or not it is marked is to look at
659 the mark bit of its car (each Lisp_Object has one bit
660 reserved as a mark bit, in case it's needed). Note that
661 different types of objects use different fields to indicate
662 whether the object is marked, but the principle is the same.
664 Conses on the free_cons_list are threaded through a pointer
665 stored in the bytes directly after the bytes that are set
666 to 0xFFFFFFFF (we cannot overwrite these because the cons
667 is still in a cons_block and needs to remain marked as
668 not in use for the next time that GC happens). This
669 implies that all fixed-size types must be at least big
670 enough to store two pointers, which is indeed the case
671 for all current fixed-size types.
673 Some types of objects need additional "finalization" done
674 when an object is converted from in use to not in use;
675 this is the purpose of the ADDITIONAL_FREE_type macro.
676 For example, markers need to be removed from the chain
677 of markers that is kept in each buffer. This is because
678 markers in a buffer automatically disappear if the marker
679 is no longer referenced anywhere (the same does not
680 apply to extents, however).
682 WARNING: Things are in an extremely bizarre state when
683 the ADDITIONAL_FREE_type macros are called, so beware!
685 When ERROR_CHECK_GC is defined, we do things differently
686 so as to maximize our chances of catching places where
687 there is insufficient GCPROing. The thing we want to
688 avoid is having an object that we're using but didn't
689 GCPRO get freed by GC and then reallocated while we're
690 in the process of using it -- this will result in something
691 seemingly unrelated getting trashed, and is extremely
692 difficult to track down. If the object gets freed but
693 not reallocated, we can usually catch this because we
694 set all bytes of a freed object to 0xDEADBEEF. (The
695 first four bytes, however, are 0xFFFFFFFF, and the next
696 four are a pointer used to chain freed objects together;
697 we play some tricks with this pointer to make it more
698 bogus, so crashes are more likely to occur right away.)
700 We want freed objects to stay free as long as possible,
701 so instead of doing what we do above, we maintain the
702 free objects in a first-in first-out queue. We also
703 don't recompute the free list each GC, unlike above;
704 this ensures that the queue ordering is preserved.
705 [This means that we are likely to have worse locality
706 of reference, and that we can never free a frob block
707 once it's allocated. (Even if we know that all cells
708 in it are free, there's no easy way to remove all those
709 cells from the free list because the objects on the
710 free list are unlikely to be in memory order.)]
711 Furthermore, we never take objects off the free list
712 unless there's a large number (usually 1000, but
713 varies depending on type) of them already on the list.
714 This way, we ensure that an object that gets freed will
715 remain free for the next 1000 (or whatever) times that
716 an object of that type is allocated.
719 #ifndef MALLOC_OVERHEAD
721 #define MALLOC_OVERHEAD 0
722 #elif defined (rcheck)
723 #define MALLOC_OVERHEAD 20
725 #define MALLOC_OVERHEAD 8
727 #endif /* MALLOC_OVERHEAD */
729 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
730 /* If we released our reserve (due to running out of memory),
731 and we have a fair amount free once again,
732 try to set aside another reserve in case we run out once more.
734 This is called when a relocatable block is freed in ralloc.c. */
735 void refill_memory_reserve (void);
737 refill_memory_reserve ()
739 if (breathing_space == 0)
740 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
744 #ifdef ALLOC_NO_POOLS
745 # define TYPE_ALLOC_SIZE(type, structtype) 1
747 # define TYPE_ALLOC_SIZE(type, structtype) \
748 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \
749 / sizeof (structtype))
750 #endif /* ALLOC_NO_POOLS */
752 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
754 struct type##_block \
756 struct type##_block *prev; \
757 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
760 static struct type##_block *current_##type##_block; \
761 static int current_##type##_block_index; \
763 static structtype *type##_free_list; \
764 static structtype *type##_free_list_tail; \
767 init_##type##_alloc (void) \
769 current_##type##_block = 0; \
770 current_##type##_block_index = \
771 countof (current_##type##_block->block); \
772 type##_free_list = 0; \
773 type##_free_list_tail = 0; \
776 static int gc_count_num_##type##_in_use; \
777 static int gc_count_num_##type##_freelist
779 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
780 if (current_##type##_block_index \
781 == countof (current_##type##_block->block)) \
783 struct type##_block *AFTFB_new = (struct type##_block *) \
784 allocate_lisp_storage (sizeof (struct type##_block)); \
785 AFTFB_new->prev = current_##type##_block; \
786 current_##type##_block = AFTFB_new; \
787 current_##type##_block_index = 0; \
790 &(current_##type##_block->block[current_##type##_block_index++]); \
793 /* Allocate an instance of a type that is stored in blocks.
794 TYPE is the "name" of the type, STRUCTTYPE is the corresponding
797 #ifdef ERROR_CHECK_GC
799 /* Note: if you get crashes in this function, suspect incorrect calls
800 to free_cons() and friends. This happened once because the cons
801 cell was not GC-protected and was getting collected before
802 free_cons() was called. */
804 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
807 if (gc_count_num_##type##_freelist > \
808 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
810 result = type##_free_list; \
811 /* Before actually using the chain pointer, we complement all its \
812 bits; see FREE_FIXED_TYPE(). */ \
814 (structtype *) ~(unsigned long) \
815 (* (structtype **) ((char *) result + sizeof (void *))); \
816 gc_count_num_##type##_freelist--; \
819 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
820 MARK_STRUCT_AS_NOT_FREE (result); \
823 #else /* !ERROR_CHECK_GC */
825 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
828 if (type##_free_list) \
830 result = type##_free_list; \
832 * (structtype **) ((char *) result + sizeof (void *)); \
835 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
836 MARK_STRUCT_AS_NOT_FREE (result); \
839 #endif /* !ERROR_CHECK_GC */
841 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \
844 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
845 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
848 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \
851 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \
852 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
855 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
856 to a Lisp object and invalid as an actual Lisp_Object value. We have
857 to make sure that this value cannot be an integer in Lisp_Object form.
858 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
859 On a 32-bit system, the type bits will be non-zero, making the value
860 be a pointer, and the pointer will be misaligned.
862 Even if Emacs is run on some weirdo system that allows and allocates
863 byte-aligned pointers, this pointer is at the very top of the address
864 space and so it's almost inconceivable that it could ever be valid. */
867 # define INVALID_POINTER_VALUE 0xFFFFFFFF
869 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
871 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
873 You have some weird system and need to supply a reasonable value here.
876 #define FREE_STRUCT_P(ptr) \
877 (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
878 #define MARK_STRUCT_AS_FREE(ptr) \
879 (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
880 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
881 (* (void **) ptr = 0)
883 #ifdef ERROR_CHECK_GC
885 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
886 do { if (type##_free_list_tail) \
888 /* When we store the chain pointer, we complement all \
889 its bits; this should significantly increase its \
890 bogosity in case someone tries to use the value, and \
891 should make us dump faster if someone stores something \
892 over the pointer because when it gets un-complemented in \
893 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
894 extremely bogus. */ \
896 ((char *) type##_free_list_tail + sizeof (void *)) = \
897 (structtype *) ~(unsigned long) ptr; \
900 type##_free_list = ptr; \
901 type##_free_list_tail = ptr; \
904 #else /* !ERROR_CHECK_GC */
906 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
907 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
909 type##_free_list = (ptr); \
912 #endif /* !ERROR_CHECK_GC */
914 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
916 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \
917 structtype *FFT_ptr = (ptr); \
918 ADDITIONAL_FREE_##type (FFT_ptr); \
919 deadbeef_memory (FFT_ptr, sizeof (structtype)); \
920 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
921 MARK_STRUCT_AS_FREE (FFT_ptr); \
924 /* Like FREE_FIXED_TYPE() but used when we are explicitly
925 freeing a structure through free_cons(), free_marker(), etc.
926 rather than through the normal process of sweeping.
927 We attempt to undo the changes made to the allocation counters
928 as a result of this structure being allocated. This is not
929 completely necessary but helps keep things saner: e.g. this way,
930 repeatedly allocating and freeing a cons will not result in
931 the consing-since-gc counter advancing, which would cause a GC
932 and somewhat defeat the purpose of explicitly freeing. */
934 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \
935 do { FREE_FIXED_TYPE (type, structtype, ptr); \
936 DECREMENT_CONS_COUNTER (sizeof (structtype)); \
937 gc_count_num_##type##_freelist++; \
942 /************************************************************************/
943 /* Cons allocation */
944 /************************************************************************/
946 DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons);
947 /* conses are used and freed so often that we set this really high */
948 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
949 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
952 mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object))
954 if (GC_NILP (XCDR (obj)))
957 markobj (XCAR (obj));
962 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
964 while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1))
968 if (! CONSP (ob1) || ! CONSP (ob2))
969 return internal_equal (ob1, ob2, depth + 1);
974 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
975 mark_cons, print_cons, 0,
978 * No `hash' method needed.
979 * internal_hash knows how to
985 DEFUN ("cons", Fcons, 2, 2, 0, /*
986 Create a new cons, give it CAR and CDR as components, and return it.
990 /* This cannot GC. */
994 ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
995 set_lheader_implementation (&(c->lheader), &lrecord_cons);
1002 /* This is identical to Fcons() but it used for conses that we're
1003 going to free later, and is useful when trying to track down
1006 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
1009 struct Lisp_Cons *c;
1011 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1012 set_lheader_implementation (&(c->lheader), &lrecord_cons);
1019 DEFUN ("list", Flist, 0, MANY, 0, /*
1020 Return a newly created list with specified arguments as elements.
1021 Any number of arguments, even zero arguments, are allowed.
1023 (int nargs, Lisp_Object *args))
1025 Lisp_Object val = Qnil;
1026 Lisp_Object *argp = args + nargs;
1029 val = Fcons (*--argp, val);
1034 list1 (Lisp_Object obj0)
1036 /* This cannot GC. */
1037 return Fcons (obj0, Qnil);
1041 list2 (Lisp_Object obj0, Lisp_Object obj1)
1043 /* This cannot GC. */
1044 return Fcons (obj0, Fcons (obj1, Qnil));
1048 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1050 /* This cannot GC. */
1051 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1055 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1057 /* This cannot GC. */
1058 return Fcons (obj0, Fcons (obj1, obj2));
1062 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1064 return Fcons (Fcons (key, value), alist);
1068 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1070 /* This cannot GC. */
1071 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1075 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1078 /* This cannot GC. */
1079 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1083 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1084 Lisp_Object obj4, Lisp_Object obj5)
1086 /* This cannot GC. */
1087 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1090 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1091 Return a new list of length LENGTH, with each element being INIT.
1095 CHECK_NATNUM (length);
1098 Lisp_Object val = Qnil;
1099 int size = XINT (length);
1102 val = Fcons (init, val);
1108 /************************************************************************/
1109 /* Float allocation */
1110 /************************************************************************/
1112 #ifdef LISP_FLOAT_TYPE
1114 DECLARE_FIXED_TYPE_ALLOC (float, struct Lisp_Float);
1115 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1118 make_float (double float_value)
1121 struct Lisp_Float *f;
1123 ALLOCATE_FIXED_TYPE (float, struct Lisp_Float, f);
1124 set_lheader_implementation (&(f->lheader), &lrecord_float);
1125 float_data (f) = float_value;
1130 #endif /* LISP_FLOAT_TYPE */
1133 /************************************************************************/
1134 /* Vector allocation */
1135 /************************************************************************/
1138 mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
1140 Lisp_Vector *ptr = XVECTOR (obj);
1141 int len = vector_length (ptr);
1144 for (i = 0; i < len - 1; i++)
1145 markobj (ptr->contents[i]);
1146 return (len > 0) ? ptr->contents[len - 1] : Qnil;
1150 size_vector (CONST void *lheader)
1152 return STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents,
1153 ((Lisp_Vector *) lheader)->size);
1157 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1159 int len = XVECTOR_LENGTH (obj1);
1160 if (len != XVECTOR_LENGTH (obj2))
1164 Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1165 Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1167 if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1173 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1174 mark_vector, print_vector, 0,
1177 * No `hash' method needed for
1178 * vectors. internal_hash
1179 * knows how to handle vectors.
1182 size_vector, Lisp_Vector);
1184 /* #### should allocate `small' vectors from a frob-block */
1185 static Lisp_Vector *
1186 make_vector_internal (size_t sizei)
1188 /* no vector_next */
1189 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1190 Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1197 make_vector (size_t length, Lisp_Object init)
1199 Lisp_Vector *vecp = make_vector_internal (length);
1200 Lisp_Object *p = vector_data (vecp);
1207 XSETVECTOR (vector, vecp);
1212 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1213 Return a new vector of length LENGTH, with each element being INIT.
1214 See also the function `vector'.
1218 CONCHECK_NATNUM (length);
1219 return make_vector (XINT (length), init);
1222 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1223 Return a newly created vector with specified arguments as elements.
1224 Any number of arguments, even zero arguments, are allowed.
1226 (int nargs, Lisp_Object *args))
1228 Lisp_Vector *vecp = make_vector_internal (nargs);
1229 Lisp_Object *p = vector_data (vecp);
1236 XSETVECTOR (vector, vecp);
1242 vector1 (Lisp_Object obj0)
1244 return Fvector (1, &obj0);
1248 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1250 Lisp_Object args[2];
1253 return Fvector (2, args);
1257 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1259 Lisp_Object args[3];
1263 return Fvector (3, args);
1266 #if 0 /* currently unused */
1269 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1272 Lisp_Object args[4];
1277 return Fvector (4, args);
1281 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1282 Lisp_Object obj3, Lisp_Object obj4)
1284 Lisp_Object args[5];
1290 return Fvector (5, args);
1294 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1295 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1297 Lisp_Object args[6];
1304 return Fvector (6, args);
1308 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1309 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1312 Lisp_Object args[7];
1320 return Fvector (7, args);
1324 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1325 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1326 Lisp_Object obj6, Lisp_Object obj7)
1328 Lisp_Object args[8];
1337 return Fvector (8, args);
1341 /************************************************************************/
1342 /* Bit Vector allocation */
1343 /************************************************************************/
1345 static Lisp_Object all_bit_vectors;
1347 /* #### should allocate `small' bit vectors from a frob-block */
1348 static struct Lisp_Bit_Vector *
1349 make_bit_vector_internal (size_t sizei)
1351 size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1352 size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1353 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1354 set_lheader_implementation (&(p->lheader), &lrecord_bit_vector);
1356 INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1358 bit_vector_length (p) = sizei;
1359 bit_vector_next (p) = all_bit_vectors;
1360 /* make sure the extra bits in the last long are 0; the calling
1361 functions might not set them. */
1362 p->bits[num_longs - 1] = 0;
1363 XSETBIT_VECTOR (all_bit_vectors, p);
1368 make_bit_vector (size_t length, Lisp_Object init)
1370 struct Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1371 size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1376 memset (p->bits, 0, num_longs * sizeof (long));
1379 size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1380 memset (p->bits, ~0, num_longs * sizeof (long));
1381 /* But we have to make sure that the unused bits in the
1382 last long are 0, so that equal/hash is easy. */
1384 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1388 Lisp_Object bit_vector;
1389 XSETBIT_VECTOR (bit_vector, p);
1395 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1398 Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1400 for (i = 0; i < length; i++)
1401 set_bit_vector_bit (p, i, bytevec[i]);
1404 Lisp_Object bit_vector;
1405 XSETBIT_VECTOR (bit_vector, p);
1410 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1411 Return a new bit vector of length LENGTH. with each bit being INIT.
1412 Each element is set to INIT. See also the function `bit-vector'.
1416 CONCHECK_NATNUM (length);
1418 return make_bit_vector (XINT (length), init);
1421 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1422 Return a newly created bit vector with specified arguments as elements.
1423 Any number of arguments, even zero arguments, are allowed.
1425 (int nargs, Lisp_Object *args))
1428 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1430 for (i = 0; i < nargs; i++)
1432 CHECK_BIT (args[i]);
1433 set_bit_vector_bit (p, i, !ZEROP (args[i]));
1437 Lisp_Object bit_vector;
1438 XSETBIT_VECTOR (bit_vector, p);
1444 /************************************************************************/
1445 /* Compiled-function allocation */
1446 /************************************************************************/
1448 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1449 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1452 make_compiled_function (void)
1454 Lisp_Compiled_Function *f;
1457 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1458 set_lheader_implementation (&(f->lheader), &lrecord_compiled_function);
1461 f->specpdl_depth = 0;
1462 f->flags.documentationp = 0;
1463 f->flags.interactivep = 0;
1464 f->flags.domainp = 0; /* I18N3 */
1465 f->instructions = Qzero;
1466 f->constants = Qzero;
1468 f->doc_and_interactive = Qnil;
1469 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1470 f->annotated = Qnil;
1472 XSETCOMPILED_FUNCTION (fun, f);
1476 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1477 Return a new compiled-function object.
1478 Usage: (arglist instructions constants stack-depth
1479 &optional doc-string interactive)
1480 Note that, unlike all other emacs-lisp functions, calling this with five
1481 arguments is NOT the same as calling it with six arguments, the last of
1482 which is nil. If the INTERACTIVE arg is specified as nil, then that means
1483 that this function was defined with `(interactive)'. If the arg is not
1484 specified, then that means the function is not interactive.
1485 This is terrible behavior which is retained for compatibility with old
1486 `.elc' files which expect these semantics.
1488 (int nargs, Lisp_Object *args))
1490 /* In a non-insane world this function would have this arglist...
1491 (arglist instructions constants stack_depth &optional doc_string interactive)
1493 Lisp_Object fun = make_compiled_function ();
1494 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1496 Lisp_Object arglist = args[0];
1497 Lisp_Object instructions = args[1];
1498 Lisp_Object constants = args[2];
1499 Lisp_Object stack_depth = args[3];
1500 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
1501 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
1503 if (nargs < 4 || nargs > 6)
1504 return Fsignal (Qwrong_number_of_arguments,
1505 list2 (intern ("make-byte-code"), make_int (nargs)));
1507 /* Check for valid formal parameter list now, to allow us to use
1508 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1510 Lisp_Object symbol, tail;
1511 EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1513 CHECK_SYMBOL (symbol);
1514 if (EQ (symbol, Qt) ||
1515 EQ (symbol, Qnil) ||
1516 SYMBOL_IS_KEYWORD (symbol))
1517 signal_simple_error_2
1518 ("Invalid constant symbol in formal parameter list",
1522 f->arglist = arglist;
1524 /* `instructions' is a string or a cons (string . int) for a
1525 lazy-loaded function. */
1526 if (CONSP (instructions))
1528 CHECK_STRING (XCAR (instructions));
1529 CHECK_INT (XCDR (instructions));
1533 CHECK_STRING (instructions);
1535 f->instructions = instructions;
1537 if (!NILP (constants))
1538 CHECK_VECTOR (constants);
1539 f->constants = constants;
1541 CHECK_NATNUM (stack_depth);
1542 f->stack_depth = XINT (stack_depth);
1544 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1545 if (!NILP (Vcurrent_compiled_function_annotation))
1546 f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1547 else if (!NILP (Vload_file_name_internal_the_purecopy))
1548 f->annotated = Vload_file_name_internal_the_purecopy;
1549 else if (!NILP (Vload_file_name_internal))
1551 struct gcpro gcpro1;
1552 GCPRO1 (fun); /* don't let fun get reaped */
1553 Vload_file_name_internal_the_purecopy =
1554 Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
1555 f->annotated = Vload_file_name_internal_the_purecopy;
1558 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1560 /* doc_string may be nil, string, int, or a cons (string . int).
1561 interactive may be list or string (or unbound). */
1562 f->doc_and_interactive = Qunbound;
1564 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1565 f->doc_and_interactive = Vfile_domain;
1567 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1569 f->doc_and_interactive
1570 = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1571 Fcons (interactive, f->doc_and_interactive));
1573 if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1575 f->doc_and_interactive
1576 = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1577 Fcons (doc_string, f->doc_and_interactive));
1579 if (UNBOUNDP (f->doc_and_interactive))
1580 f->doc_and_interactive = Qnil;
1586 /************************************************************************/
1587 /* Symbol allocation */
1588 /************************************************************************/
1590 DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol);
1591 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1593 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1594 Return a newly allocated uninterned symbol whose name is NAME.
1595 Its value and function definition are void, and its property list is nil.
1600 struct Lisp_Symbol *p;
1602 CHECK_STRING (name);
1604 ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p);
1605 set_lheader_implementation (&(p->lheader), &lrecord_symbol);
1606 p->name = XSTRING (name);
1608 p->value = Qunbound;
1609 p->function = Qunbound;
1610 symbol_next (p) = 0;
1611 XSETSYMBOL (val, p);
1616 /************************************************************************/
1617 /* Extent allocation */
1618 /************************************************************************/
1620 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1621 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1624 allocate_extent (void)
1628 ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1629 set_lheader_implementation (&(e->lheader), &lrecord_extent);
1630 extent_object (e) = Qnil;
1631 set_extent_start (e, -1);
1632 set_extent_end (e, -1);
1637 extent_face (e) = Qnil;
1638 e->flags.end_open = 1; /* default is for endpoints to behave like markers */
1639 e->flags.detachable = 1;
1645 /************************************************************************/
1646 /* Event allocation */
1647 /************************************************************************/
1649 DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event);
1650 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1653 allocate_event (void)
1656 struct Lisp_Event *e;
1658 ALLOCATE_FIXED_TYPE (event, struct Lisp_Event, e);
1659 set_lheader_implementation (&(e->lheader), &lrecord_event);
1666 /************************************************************************/
1667 /* Marker allocation */
1668 /************************************************************************/
1670 DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker);
1671 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1673 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1674 Return a new marker which does not point at any place.
1679 struct Lisp_Marker *p;
1681 ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1682 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1685 marker_next (p) = 0;
1686 marker_prev (p) = 0;
1687 p->insertion_type = 0;
1688 XSETMARKER (val, p);
1693 noseeum_make_marker (void)
1696 struct Lisp_Marker *p;
1698 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1699 set_lheader_implementation (&(p->lheader), &lrecord_marker);
1702 marker_next (p) = 0;
1703 marker_prev (p) = 0;
1704 p->insertion_type = 0;
1705 XSETMARKER (val, p);
1710 /************************************************************************/
1711 /* String allocation */
1712 /************************************************************************/
1714 /* The data for "short" strings generally resides inside of structs of type
1715 string_chars_block. The Lisp_String structure is allocated just like any
1716 other Lisp object (except for vectors), and these are freelisted when
1717 they get garbage collected. The data for short strings get compacted,
1718 but the data for large strings do not.
1720 Previously Lisp_String structures were relocated, but this caused a lot
1721 of bus-errors because the C code didn't include enough GCPRO's for
1722 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1723 that the reference would get relocated).
1725 This new method makes things somewhat bigger, but it is MUCH safer. */
1727 DECLARE_FIXED_TYPE_ALLOC (string, struct Lisp_String);
1728 /* strings are used and freed quite often */
1729 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1730 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1733 mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object))
1735 struct Lisp_String *ptr = XSTRING (obj);
1737 if (GC_CONSP (ptr->plist) && GC_EXTENT_INFOP (XCAR (ptr->plist)))
1738 flush_cached_extent_info (XCAR (ptr->plist));
1743 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1746 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1747 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1750 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
1751 mark_string, print_string,
1753 * No `finalize', or `hash' methods.
1754 * internal_hash already knows how
1755 * to hash strings and finalization
1757 * ADDITIONAL_FREE_string macro,
1758 * which is the standard way to do
1759 * finalization when using
1760 * SWEEP_FIXED_TYPE_BLOCK().
1763 struct Lisp_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 struct string_chars_block *first_string_chars_block;
1782 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(s) \
1789 ALIGN_SIZE (((s) + 1 + sizeof (struct Lisp_String *)),\
1790 ALIGNOF (struct 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)))
1795 #define CHARS_TO_STRING_CHAR(x) \
1796 ((struct string_chars *) \
1797 (((char *) (x)) - (slot_offset (struct string_chars, chars[0]))))
1802 struct Lisp_String *string;
1803 unsigned char chars[1];
1806 struct unused_string_chars
1808 struct Lisp_String *string;
1813 init_string_chars_alloc (void)
1815 first_string_chars_block = xnew (struct string_chars_block);
1816 first_string_chars_block->prev = 0;
1817 first_string_chars_block->next = 0;
1818 first_string_chars_block->pos = 0;
1819 current_string_chars_block = first_string_chars_block;
1822 static struct string_chars *
1823 allocate_string_chars_struct (struct Lisp_String *string_it_goes_with,
1826 struct string_chars *s_chars;
1828 /* Allocate the string's actual data */
1829 if (BIG_STRING_FULLSIZE_P (fullsize))
1831 s_chars = (struct string_chars *) xmalloc (fullsize);
1833 else if (fullsize <=
1834 (countof (current_string_chars_block->string_chars)
1835 - current_string_chars_block->pos))
1837 /* This string can fit in the current string chars block */
1838 s_chars = (struct string_chars *)
1839 (current_string_chars_block->string_chars
1840 + current_string_chars_block->pos);
1841 current_string_chars_block->pos += fullsize;
1845 /* Make a new current string chars block */
1846 struct string_chars_block *new_scb = xnew (struct string_chars_block);
1848 current_string_chars_block->next = new_scb;
1849 new_scb->prev = current_string_chars_block;
1851 current_string_chars_block = new_scb;
1852 new_scb->pos = fullsize;
1853 s_chars = (struct string_chars *)
1854 current_string_chars_block->string_chars;
1857 s_chars->string = string_it_goes_with;
1859 INCREMENT_CONS_COUNTER (fullsize, "string chars");
1865 make_uninit_string (Bytecount length)
1867 struct Lisp_String *s;
1868 struct string_chars *s_chars;
1869 EMACS_INT fullsize = STRING_FULLSIZE (length);
1872 if ((length < 0) || (fullsize <= 0))
1875 /* Allocate the string header */
1876 ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
1877 set_lheader_implementation (&(s->lheader), &lrecord_string);
1879 s_chars = allocate_string_chars_struct (s, fullsize);
1881 set_string_data (s, &(s_chars->chars[0]));
1882 set_string_length (s, length);
1885 set_string_byte (s, length, 0);
1887 XSETSTRING (val, s);
1891 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1892 static void verify_string_chars_integrity (void);
1895 /* Resize the string S so that DELTA bytes can be inserted starting
1896 at POS. If DELTA < 0, it means deletion starting at POS. If
1897 POS < 0, resize the string but don't copy any characters. Use
1898 this if you're planning on completely overwriting the string.
1902 resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta)
1904 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1905 verify_string_chars_integrity ();
1908 #ifdef ERROR_CHECK_BUFPOS
1911 assert (pos <= string_length (s));
1913 assert (pos + (-delta) <= string_length (s));
1918 assert ((-delta) <= string_length (s));
1920 #endif /* ERROR_CHECK_BUFPOS */
1922 if (pos >= 0 && delta < 0)
1923 /* If DELTA < 0, the functions below will delete the characters
1924 before POS. We want to delete characters *after* POS, however,
1925 so convert this to the appropriate form. */
1929 /* simplest case: no size change. */
1933 Bytecount oldfullsize = STRING_FULLSIZE (string_length (s));
1934 Bytecount newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1936 if (oldfullsize == newfullsize)
1938 /* next simplest case; size change but the necessary
1939 allocation size won't change (up or down; code somewhere
1940 depends on there not being any unused allocation space,
1941 modulo any alignment constraints). */
1944 Bufbyte *addroff = pos + string_data (s);
1946 memmove (addroff + delta, addroff,
1947 /* +1 due to zero-termination. */
1948 string_length (s) + 1 - pos);
1951 else if (BIG_STRING_FULLSIZE_P (oldfullsize) &&
1952 BIG_STRING_FULLSIZE_P (newfullsize))
1954 /* next simplest case; the string is big enough to be malloc()ed
1955 itself, so we just realloc.
1957 It's important not to let the string get below the threshold
1958 for making big strings and still remain malloc()ed; if that
1959 were the case, repeated calls to this function on the same
1960 string could result in memory leakage. */
1961 set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1965 Bufbyte *addroff = pos + string_data (s);
1967 memmove (addroff + delta, addroff,
1968 /* +1 due to zero-termination. */
1969 string_length (s) + 1 - pos);
1974 /* worst case. We make a new string_chars struct and copy
1975 the string's data into it, inserting/deleting the delta
1976 in the process. The old string data will either get
1977 freed by us (if it was malloc()ed) or will be reclaimed
1978 in the normal course of garbage collection. */
1979 struct string_chars *s_chars =
1980 allocate_string_chars_struct (s, newfullsize);
1981 Bufbyte *new_addr = &(s_chars->chars[0]);
1982 Bufbyte *old_addr = string_data (s);
1985 memcpy (new_addr, old_addr, pos);
1986 memcpy (new_addr + pos + delta, old_addr + pos,
1987 string_length (s) + 1 - pos);
1989 set_string_data (s, new_addr);
1990 if (BIG_STRING_FULLSIZE_P (oldfullsize))
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 =
1998 (struct string_chars *) ((char *) old_addr -
1999 sizeof (struct Lisp_String *));
2000 /* Sanity check to make sure we aren't hosed by strange
2001 alignment/padding. */
2002 assert (old_s_chars->string == s);
2003 MARK_STRUCT_AS_FREE (old_s_chars);
2004 ((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),
2028 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2029 verify_string_chars_integrity ();
2036 set_string_char (struct Lisp_String *s, Charcount i, Emchar c)
2038 Bufbyte newstr[MAX_EMCHAR_LEN];
2039 Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2040 Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2041 Bytecount newlen = set_charptr_emchar (newstr, c);
2043 if (oldlen != newlen)
2044 resize_string (s, bytoff, newlen - oldlen);
2045 /* Remember, string_data (s) might have changed so we can't cache it. */
2046 memcpy (string_data (s) + bytoff, newstr, newlen);
2051 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2052 Return a new string of length LENGTH, with each character being INIT.
2053 LENGTH must be an integer and INIT must be a character.
2057 CHECK_NATNUM (length);
2058 CHECK_CHAR_COERCE_INT (init);
2060 Bufbyte init_str[MAX_EMCHAR_LEN];
2061 int len = set_charptr_emchar (init_str, XCHAR (init));
2062 Lisp_Object val = make_uninit_string (len * XINT (length));
2065 /* Optimize the single-byte case */
2066 memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2070 Bufbyte *ptr = XSTRING_DATA (val);
2072 for (i = XINT (length); i; i--)
2074 Bufbyte *init_ptr = init_str;
2077 case 4: *ptr++ = *init_ptr++;
2078 case 3: *ptr++ = *init_ptr++;
2079 case 2: *ptr++ = *init_ptr++;
2080 case 1: *ptr++ = *init_ptr++;
2088 DEFUN ("string", Fstring, 0, MANY, 0, /*
2089 Concatenate all the argument characters and make the result a string.
2091 (int nargs, Lisp_Object *args))
2093 Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2094 Bufbyte *p = storage;
2096 for (; nargs; nargs--, args++)
2098 Lisp_Object lisp_char = *args;
2099 CHECK_CHAR_COERCE_INT (lisp_char);
2100 p += set_charptr_emchar (p, XCHAR (lisp_char));
2102 return make_string (storage, p - storage);
2106 /* Take some raw memory, which MUST already be in internal format,
2107 and package it up into a Lisp string. */
2109 make_string (CONST Bufbyte *contents, Bytecount length)
2113 /* Make sure we find out about bad make_string's when they happen */
2114 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2115 bytecount_to_charcount (contents, length); /* Just for the assertions */
2118 val = make_uninit_string (length);
2119 memcpy (XSTRING_DATA (val), contents, length);
2123 /* Take some raw memory, encoded in some external data format,
2124 and convert it into a Lisp string. */
2126 make_ext_string (CONST Extbyte *contents, EMACS_INT length,
2127 enum external_data_format fmt)
2132 GET_CHARPTR_INT_DATA_ALLOCA (contents, length, fmt, intstr, intlen);
2133 return make_string (intstr, intlen);
2137 build_string (CONST char *str)
2139 /* Some strlen's crash and burn if passed null. */
2140 return make_string ((CONST Bufbyte *) str, (str ? strlen(str) : 0));
2144 build_ext_string (CONST char *str, enum external_data_format fmt)
2146 /* Some strlen's crash and burn if passed null. */
2147 return make_ext_string ((CONST Extbyte *) str, (str ? strlen(str) : 0), fmt);
2151 build_translated_string (CONST char *str)
2153 return build_string (GETTEXT (str));
2157 make_string_nocopy (CONST Bufbyte *contents, Bytecount length)
2159 struct Lisp_String *s;
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, struct 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
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, void (*markobj) (Lisp_Object))
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;
2224 #ifdef ERROR_CHECK_GC
2225 CONST struct lrecord_implementation *implementation
2226 = LHEADER_IMPLEMENTATION(lheader);
2228 /* There should be no other pointers to the free list. */
2229 assert (!MARKED_RECORD_HEADER_P (lheader));
2230 /* Only lcrecords should be here. */
2231 assert (!implementation->basic_p);
2232 /* Only free lcrecords should be here. */
2233 assert (free_header->lcheader.free);
2234 /* The type of the lcrecord must be right. */
2235 assert (implementation == list->implementation);
2236 /* So must the size. */
2237 assert (implementation->static_size == 0
2238 || implementation->static_size == list->size);
2239 #endif /* ERROR_CHECK_GC */
2241 MARK_RECORD_HEADER (lheader);
2242 chain = free_header->chain;
2248 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2249 mark_lcrecord_list, internal_object_printer,
2250 0, 0, 0, struct lcrecord_list);
2252 make_lcrecord_list (size_t size,
2253 CONST struct lrecord_implementation *implementation)
2255 struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2256 &lrecord_lcrecord_list);
2259 p->implementation = implementation;
2262 XSETLCRECORD_LIST (val, p);
2267 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2269 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2270 if (!NILP (list->free))
2272 Lisp_Object val = list->free;
2273 struct free_lcrecord_header *free_header =
2274 (struct free_lcrecord_header *) XPNTR (val);
2276 #ifdef ERROR_CHECK_GC
2277 struct lrecord_header *lheader =
2278 (struct lrecord_header *) free_header;
2279 CONST struct lrecord_implementation *implementation
2280 = LHEADER_IMPLEMENTATION (lheader);
2282 /* There should be no other pointers to the free list. */
2283 assert (!MARKED_RECORD_HEADER_P (lheader));
2284 /* Only lcrecords should be here. */
2285 assert (!implementation->basic_p);
2286 /* Only free lcrecords should be here. */
2287 assert (free_header->lcheader.free);
2288 /* The type of the lcrecord must be right. */
2289 assert (implementation == list->implementation);
2290 /* So must the size. */
2291 assert (implementation->static_size == 0
2292 || implementation->static_size == list->size);
2293 #endif /* ERROR_CHECK_GC */
2294 list->free = free_header->chain;
2295 free_header->lcheader.free = 0;
2302 XSETOBJ (val, Lisp_Type_Record,
2303 alloc_lcrecord (list->size, list->implementation));
2309 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2311 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2312 struct free_lcrecord_header *free_header =
2313 (struct free_lcrecord_header *) XPNTR (lcrecord);
2314 struct lrecord_header *lheader =
2315 (struct lrecord_header *) free_header;
2316 CONST struct lrecord_implementation *implementation
2317 = LHEADER_IMPLEMENTATION (lheader);
2319 #ifdef ERROR_CHECK_GC
2320 /* Make sure the size is correct. This will catch, for example,
2321 putting a window configuration on the wrong free list. */
2322 if (implementation->size_in_bytes_method)
2323 assert (implementation->size_in_bytes_method (lheader) == list->size);
2325 assert (implementation->static_size == list->size);
2326 #endif /* ERROR_CHECK_GC */
2328 if (implementation->finalizer)
2329 implementation->finalizer (lheader, 0);
2330 free_header->chain = list->free;
2331 free_header->lcheader.free = 1;
2332 list->free = lcrecord;
2338 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2339 Kept for compatibility, returns its argument.
2341 Make a copy of OBJECT in pure storage.
2342 Recursively copies contents of vectors and cons cells.
2343 Does not copy symbols.
2352 /************************************************************************/
2353 /* Garbage Collection */
2354 /************************************************************************/
2356 /* This will be used more extensively In The Future */
2357 static int last_lrecord_type_index_assigned;
2359 CONST struct lrecord_implementation *lrecord_implementations_table[128];
2360 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
2362 struct gcpro *gcprolist;
2364 /* 415 used Mly 29-Jun-93 */
2365 /* 1327 used slb 28-Feb-98 */
2367 #define NSTATICS 4000
2369 #define NSTATICS 2000
2371 /* Not "static" because of linker lossage on some systems */
2372 Lisp_Object *staticvec[NSTATICS]
2373 /* Force it into data space! */
2375 static int staticidx;
2377 /* Put an entry in staticvec, pointing at the variable whose address is given
2380 staticpro (Lisp_Object *varaddress)
2382 if (staticidx >= countof (staticvec))
2383 /* #### This is now a dubious abort() since this routine may be called */
2384 /* by Lisp attempting to load a DLL. */
2386 staticvec[staticidx++] = varaddress;
2390 /* Mark reference to a Lisp_Object. If the object referred to has not been
2391 seen yet, recursively mark all the references contained in it. */
2394 mark_object (Lisp_Object obj)
2398 #ifdef ERROR_CHECK_GC
2399 assert (! (GC_EQ (obj, Qnull_pointer)));
2401 /* Checks we used to perform */
2402 /* if (EQ (obj, Qnull_pointer)) return; */
2403 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2404 /* if (PURIFIED (XPNTR (obj))) return; */
2406 if (XGCTYPE (obj) == Lisp_Type_Record)
2408 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2409 #if defined (ERROR_CHECK_GC)
2410 assert (lheader->type <= last_lrecord_type_index_assigned);
2412 if (C_READONLY_RECORD_HEADER_P (lheader))
2415 if (! MARKED_RECORD_HEADER_P (lheader) &&
2416 ! UNMARKABLE_RECORD_HEADER_P (lheader))
2418 CONST struct lrecord_implementation *implementation =
2419 LHEADER_IMPLEMENTATION (lheader);
2420 MARK_RECORD_HEADER (lheader);
2421 #ifdef ERROR_CHECK_GC
2422 if (!implementation->basic_p)
2423 assert (! ((struct lcrecord_header *) lheader)->free);
2425 if (implementation->marker)
2427 obj = implementation->marker (obj, mark_object);
2428 if (!GC_NILP (obj)) goto tail_recurse;
2434 /* mark all of the conses in a list and mark the final cdr; but
2435 DO NOT mark the cars.
2437 Use only for internal lists! There should never be other pointers
2438 to the cons cells, because if so, the cars will remain unmarked
2439 even when they maybe should be marked. */
2441 mark_conses_in_list (Lisp_Object obj)
2445 for (rest = obj; CONSP (rest); rest = XCDR (rest))
2447 if (CONS_MARKED_P (XCONS (rest)))
2449 MARK_CONS (XCONS (rest));
2456 /* Find all structures not marked, and free them. */
2458 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2459 static int gc_count_bit_vector_storage;
2460 static int gc_count_num_short_string_in_use;
2461 static int gc_count_string_total_size;
2462 static int gc_count_short_string_total_size;
2464 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2468 lrecord_type_index (CONST struct lrecord_implementation *implementation)
2470 int type_index = *(implementation->lrecord_type_index);
2471 /* Have to do this circuitous validation test because of problems
2472 dumping out initialized variables (ie can't set xxx_type_index to -1
2473 because that would make xxx_type_index read-only in a dumped emacs. */
2474 if (type_index < 0 || type_index > max_lrecord_type
2475 || lrecord_implementations_table[type_index] != implementation)
2477 assert (last_lrecord_type_index_assigned < max_lrecord_type);
2478 type_index = ++last_lrecord_type_index_assigned;
2479 lrecord_implementations_table[type_index] = implementation;
2480 *(implementation->lrecord_type_index) = type_index;
2485 /* stats on lcrecords in use - kinda kludgy */
2489 int instances_in_use;
2491 int instances_freed;
2493 int instances_on_free_list;
2494 } lcrecord_stats [countof (lrecord_implementations_table)];
2497 tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p)
2499 CONST struct lrecord_implementation *implementation =
2500 LHEADER_IMPLEMENTATION (h);
2501 int type_index = lrecord_type_index (implementation);
2503 if (((struct lcrecord_header *) h)->free)
2506 lcrecord_stats[type_index].instances_on_free_list++;
2510 size_t sz = (implementation->size_in_bytes_method
2511 ? implementation->size_in_bytes_method (h)
2512 : implementation->static_size);
2516 lcrecord_stats[type_index].instances_freed++;
2517 lcrecord_stats[type_index].bytes_freed += sz;
2521 lcrecord_stats[type_index].instances_in_use++;
2522 lcrecord_stats[type_index].bytes_in_use += sz;
2528 /* Free all unmarked records */
2530 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2532 struct lcrecord_header *header;
2534 /* int total_size = 0; */
2536 xzero (lcrecord_stats); /* Reset all statistics to 0. */
2538 /* First go through and call all the finalize methods.
2539 Then go through and free the objects. There used to
2540 be only one loop here, with the call to the finalizer
2541 occurring directly before the xfree() below. That
2542 is marginally faster but much less safe -- if the
2543 finalize method for an object needs to reference any
2544 other objects contained within it (and many do),
2545 we could easily be screwed by having already freed that
2548 for (header = *prev; header; header = header->next)
2550 struct lrecord_header *h = &(header->lheader);
2551 if (!C_READONLY_RECORD_HEADER_P(h)
2552 && !MARKED_RECORD_HEADER_P (h)
2553 && ! (header->free))
2555 if (LHEADER_IMPLEMENTATION (h)->finalizer)
2556 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2560 for (header = *prev; header; )
2562 struct lrecord_header *h = &(header->lheader);
2563 if (C_READONLY_RECORD_HEADER_P(h) || MARKED_RECORD_HEADER_P (h))
2565 if (MARKED_RECORD_HEADER_P (h))
2566 UNMARK_RECORD_HEADER (h);
2568 /* total_size += n->implementation->size_in_bytes (h);*/
2569 /* ### May modify header->next on a C_READONLY lcrecord */
2570 prev = &(header->next);
2572 tick_lcrecord_stats (h, 0);
2576 struct lcrecord_header *next = header->next;
2578 tick_lcrecord_stats (h, 1);
2579 /* used to call finalizer right here. */
2585 /* *total = total_size; */
2590 sweep_bit_vectors_1 (Lisp_Object *prev,
2591 int *used, int *total, int *storage)
2593 Lisp_Object bit_vector;
2596 int total_storage = 0;
2598 /* BIT_VECTORP fails because the objects are marked, which changes
2599 their implementation */
2600 for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2602 Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2604 if (C_READONLY_RECORD_HEADER_P(&(v->lheader)) || MARKED_RECORD_P (bit_vector))
2606 if (MARKED_RECORD_P (bit_vector))
2607 UNMARK_RECORD_HEADER (&(v->lheader));
2611 STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2612 BIT_VECTOR_LONG_STORAGE (len));
2614 /* ### May modify next on a C_READONLY bitvector */
2615 prev = &(bit_vector_next (v));
2620 Lisp_Object next = bit_vector_next (v);
2627 *total = total_size;
2628 *storage = total_storage;
2631 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2632 to make macros prettier. */
2634 #ifdef ERROR_CHECK_GC
2636 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2638 struct typename##_block *SFTB_current; \
2639 struct typename##_block **SFTB_prev; \
2641 int num_free = 0, num_used = 0; \
2643 for (SFTB_prev = ¤t_##typename##_block, \
2644 SFTB_current = current_##typename##_block, \
2645 SFTB_limit = current_##typename##_block_index; \
2651 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2653 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2655 if (FREE_STRUCT_P (SFTB_victim)) \
2659 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2663 else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2666 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2671 UNMARK_##typename (SFTB_victim); \
2674 SFTB_prev = &(SFTB_current->prev); \
2675 SFTB_current = SFTB_current->prev; \
2676 SFTB_limit = countof (current_##typename##_block->block); \
2679 gc_count_num_##typename##_in_use = num_used; \
2680 gc_count_num_##typename##_freelist = num_free; \
2683 #else /* !ERROR_CHECK_GC */
2685 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
2687 struct typename##_block *SFTB_current; \
2688 struct typename##_block **SFTB_prev; \
2690 int num_free = 0, num_used = 0; \
2692 typename##_free_list = 0; \
2694 for (SFTB_prev = ¤t_##typename##_block, \
2695 SFTB_current = current_##typename##_block, \
2696 SFTB_limit = current_##typename##_block_index; \
2701 int SFTB_empty = 1; \
2702 obj_type *SFTB_old_free_list = typename##_free_list; \
2704 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
2706 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
2708 if (FREE_STRUCT_P (SFTB_victim)) \
2711 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
2713 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2718 else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
2721 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
2727 UNMARK_##typename (SFTB_victim); \
2732 SFTB_prev = &(SFTB_current->prev); \
2733 SFTB_current = SFTB_current->prev; \
2735 else if (SFTB_current == current_##typename##_block \
2736 && !SFTB_current->prev) \
2738 /* No real point in freeing sole allocation block */ \
2743 struct typename##_block *SFTB_victim_block = SFTB_current; \
2744 if (SFTB_victim_block == current_##typename##_block) \
2745 current_##typename##_block_index \
2746 = countof (current_##typename##_block->block); \
2747 SFTB_current = SFTB_current->prev; \
2749 *SFTB_prev = SFTB_current; \
2750 xfree (SFTB_victim_block); \
2751 /* Restore free list to what it was before victim was swept */ \
2752 typename##_free_list = SFTB_old_free_list; \
2753 num_free -= SFTB_limit; \
2756 SFTB_limit = countof (current_##typename##_block->block); \
2759 gc_count_num_##typename##_in_use = num_used; \
2760 gc_count_num_##typename##_freelist = num_free; \
2763 #endif /* !ERROR_CHECK_GC */
2771 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2772 #define ADDITIONAL_FREE_cons(ptr)
2774 SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons);
2777 /* Explicitly free a cons cell. */
2779 free_cons (struct Lisp_Cons *ptr)
2781 #ifdef ERROR_CHECK_GC
2782 /* If the CAR is not an int, then it will be a pointer, which will
2783 always be four-byte aligned. If this cons cell has already been
2784 placed on the free list, however, its car will probably contain
2785 a chain pointer to the next cons on the list, which has cleverly
2786 had all its 0's and 1's inverted. This allows for a quick
2787 check to make sure we're not freeing something already freed. */
2788 if (POINTER_TYPE_P (XTYPE (ptr->car)))
2789 ASSERT_VALID_POINTER (XPNTR (ptr->car));
2790 #endif /* ERROR_CHECK_GC */
2792 #ifndef ALLOC_NO_POOLS
2793 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, struct Lisp_Cons, ptr);
2794 #endif /* ALLOC_NO_POOLS */
2797 /* explicitly free a list. You **must make sure** that you have
2798 created all the cons cells that make up this list and that there
2799 are no pointers to any of these cons cells anywhere else. If there
2800 are, you will lose. */
2803 free_list (Lisp_Object list)
2805 Lisp_Object rest, next;
2807 for (rest = list; !NILP (rest); rest = next)
2810 free_cons (XCONS (rest));
2814 /* explicitly free an alist. You **must make sure** that you have
2815 created all the cons cells that make up this alist and that there
2816 are no pointers to any of these cons cells anywhere else. If there
2817 are, you will lose. */
2820 free_alist (Lisp_Object alist)
2822 Lisp_Object rest, next;
2824 for (rest = alist; !NILP (rest); rest = next)
2827 free_cons (XCONS (XCAR (rest)));
2828 free_cons (XCONS (rest));
2833 sweep_compiled_functions (void)
2835 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2836 #define ADDITIONAL_FREE_compiled_function(ptr)
2838 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2842 #ifdef LISP_FLOAT_TYPE
2846 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2847 #define ADDITIONAL_FREE_float(ptr)
2849 SWEEP_FIXED_TYPE_BLOCK (float, struct Lisp_Float);
2851 #endif /* LISP_FLOAT_TYPE */
2854 sweep_symbols (void)
2856 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2857 #define ADDITIONAL_FREE_symbol(ptr)
2859 SWEEP_FIXED_TYPE_BLOCK (symbol, struct Lisp_Symbol);
2863 sweep_extents (void)
2865 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2866 #define ADDITIONAL_FREE_extent(ptr)
2868 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2874 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2875 #define ADDITIONAL_FREE_event(ptr)
2877 SWEEP_FIXED_TYPE_BLOCK (event, struct Lisp_Event);
2881 sweep_markers (void)
2883 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2884 #define ADDITIONAL_FREE_marker(ptr) \
2885 do { Lisp_Object tem; \
2886 XSETMARKER (tem, ptr); \
2887 unchain_marker (tem); \
2890 SWEEP_FIXED_TYPE_BLOCK (marker, struct Lisp_Marker);
2893 /* Explicitly free a marker. */
2895 free_marker (struct Lisp_Marker *ptr)
2897 #ifdef ERROR_CHECK_GC
2898 /* Perhaps this will catch freeing an already-freed marker. */
2900 XSETMARKER (temmy, ptr);
2901 assert (GC_MARKERP (temmy));
2902 #endif /* ERROR_CHECK_GC */
2904 #ifndef ALLOC_NO_POOLS
2905 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr);
2906 #endif /* ALLOC_NO_POOLS */
2910 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2913 verify_string_chars_integrity (void)
2915 struct string_chars_block *sb;
2917 /* Scan each existing string block sequentially, string by string. */
2918 for (sb = first_string_chars_block; sb; sb = sb->next)
2921 /* POS is the index of the next string in the block. */
2922 while (pos < sb->pos)
2924 struct string_chars *s_chars =
2925 (struct string_chars *) &(sb->string_chars[pos]);
2926 struct Lisp_String *string;
2930 /* If the string_chars struct is marked as free (i.e. the STRING
2931 pointer is 0xFFFFFFFF) then this is an unused chunk of string
2932 storage. (See below.) */
2934 if (FREE_STRUCT_P (s_chars))
2936 fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
2941 string = s_chars->string;
2942 /* Must be 32-bit aligned. */
2943 assert ((((int) string) & 3) == 0);
2945 size = string_length (string);
2946 fullsize = STRING_FULLSIZE (size);
2948 assert (!BIG_STRING_FULLSIZE_P (fullsize));
2949 assert (string_data (string) == s_chars->chars);
2952 assert (pos == sb->pos);
2956 #endif /* MULE && ERROR_CHECK_GC */
2958 /* Compactify string chars, relocating the reference to each --
2959 free any empty string_chars_block we see. */
2961 compact_string_chars (void)
2963 struct string_chars_block *to_sb = first_string_chars_block;
2965 struct string_chars_block *from_sb;
2967 /* Scan each existing string block sequentially, string by string. */
2968 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
2971 /* FROM_POS is the index of the next string in the block. */
2972 while (from_pos < from_sb->pos)
2974 struct string_chars *from_s_chars =
2975 (struct string_chars *) &(from_sb->string_chars[from_pos]);
2976 struct string_chars *to_s_chars;
2977 struct Lisp_String *string;
2981 /* If the string_chars struct is marked as free (i.e. the STRING
2982 pointer is 0xFFFFFFFF) then this is an unused chunk of string
2983 storage. This happens under Mule when a string's size changes
2984 in such a way that its fullsize changes. (Strings can change
2985 size because a different-length character can be substituted
2986 for another character.) In this case, after the bogus string
2987 pointer is the "fullsize" of this entry, i.e. how many bytes
2990 if (FREE_STRUCT_P (from_s_chars))
2992 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
2993 from_pos += fullsize;
2997 string = from_s_chars->string;
2998 assert (!(FREE_STRUCT_P (string)));
3000 size = string_length (string);
3001 fullsize = STRING_FULLSIZE (size);
3003 if (BIG_STRING_FULLSIZE_P (fullsize))
3006 /* Just skip it if it isn't marked. */
3007 if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3009 from_pos += fullsize;
3013 /* If it won't fit in what's left of TO_SB, close TO_SB out
3014 and go on to the next string_chars_block. We know that TO_SB
3015 cannot advance past FROM_SB here since FROM_SB is large enough
3016 to currently contain this string. */
3017 if ((to_pos + fullsize) > countof (to_sb->string_chars))
3019 to_sb->pos = to_pos;
3020 to_sb = to_sb->next;
3024 /* Compute new address of this string
3025 and update TO_POS for the space being used. */
3026 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3028 /* Copy the string_chars to the new place. */
3029 if (from_s_chars != to_s_chars)
3030 memmove (to_s_chars, from_s_chars, fullsize);
3032 /* Relocate FROM_S_CHARS's reference */
3033 set_string_data (string, &(to_s_chars->chars[0]));
3035 from_pos += fullsize;
3040 /* Set current to the last string chars block still used and
3041 free any that follow. */
3043 struct string_chars_block *victim;
3045 for (victim = to_sb->next; victim; )
3047 struct string_chars_block *next = victim->next;
3052 current_string_chars_block = to_sb;
3053 current_string_chars_block->pos = to_pos;
3054 current_string_chars_block->next = 0;
3058 #if 1 /* Hack to debug missing purecopy's */
3059 static int debug_string_purity;
3062 debug_string_purity_print (struct Lisp_String *p)
3065 Charcount s = string_char_length (p);
3066 putc ('\"', stderr);
3067 for (i = 0; i < s; i++)
3069 Emchar ch = string_char (p, i);
3070 if (ch < 32 || ch >= 126)
3071 stderr_out ("\\%03o", ch);
3072 else if (ch == '\\' || ch == '\"')
3073 stderr_out ("\\%c", ch);
3075 stderr_out ("%c", ch);
3077 stderr_out ("\"\n");
3083 sweep_strings (void)
3085 int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3086 int debug = debug_string_purity;
3088 #define UNMARK_string(ptr) \
3089 do { struct Lisp_String *p = (ptr); \
3090 int size = string_length (p); \
3091 UNMARK_RECORD_HEADER (&(p->lheader)); \
3092 num_bytes += size; \
3093 if (!BIG_STRING_SIZE_P (size)) \
3094 { num_small_bytes += size; \
3097 if (debug) debug_string_purity_print (p); \
3099 #define ADDITIONAL_FREE_string(p) \
3100 do { int size = string_length (p); \
3101 if (BIG_STRING_SIZE_P (size)) \
3102 xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
3105 SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String);
3107 gc_count_num_short_string_in_use = num_small_used;
3108 gc_count_string_total_size = num_bytes;
3109 gc_count_short_string_total_size = num_small_bytes;
3113 /* I hate duplicating all this crap! */
3115 marked_p (Lisp_Object obj)
3117 #ifdef ERROR_CHECK_GC
3118 assert (! (GC_EQ (obj, Qnull_pointer)));
3120 /* Checks we used to perform. */
3121 /* if (EQ (obj, Qnull_pointer)) return 1; */
3122 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3123 /* if (PURIFIED (XPNTR (obj))) return 1; */
3125 if (XGCTYPE (obj) == Lisp_Type_Record)
3127 struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3128 #if defined (ERROR_CHECK_GC)
3129 assert (lheader->type <= last_lrecord_type_index_assigned);
3131 return C_READONLY_RECORD_HEADER_P (lheader) || MARKED_RECORD_HEADER_P (lheader);
3139 /* Free all unmarked records. Do this at the very beginning,
3140 before anything else, so that the finalize methods can safely
3141 examine items in the objects. sweep_lcrecords_1() makes
3142 sure to call all the finalize methods *before* freeing anything,
3143 to complete the safety. */
3146 sweep_lcrecords_1 (&all_lcrecords, &ignored);
3149 compact_string_chars ();
3151 /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3152 macros) must be *extremely* careful to make sure they're not
3153 referencing freed objects. The only two existing finalize
3154 methods (for strings and markers) pass muster -- the string
3155 finalizer doesn't look at anything but its own specially-
3156 created block, and the marker finalizer only looks at live
3157 buffers (which will never be freed) and at the markers before
3158 and after it in the chain (which, by induction, will never be
3159 freed because if so, they would have already removed themselves
3162 /* Put all unmarked strings on free list, free'ing the string chars
3163 of large unmarked strings */
3166 /* Put all unmarked conses on free list */
3169 /* Free all unmarked bit vectors */
3170 sweep_bit_vectors_1 (&all_bit_vectors,
3171 &gc_count_num_bit_vector_used,
3172 &gc_count_bit_vector_total_size,
3173 &gc_count_bit_vector_storage);
3175 /* Free all unmarked compiled-function objects */
3176 sweep_compiled_functions ();
3178 #ifdef LISP_FLOAT_TYPE
3179 /* Put all unmarked floats on free list */
3183 /* Put all unmarked symbols on free list */
3186 /* Put all unmarked extents on free list */
3189 /* Put all unmarked markers on free list.
3190 Dechain each one first from the buffer into which it points. */
3197 /* Clearing for disksave. */
3200 disksave_object_finalization (void)
3202 /* It's important that certain information from the environment not get
3203 dumped with the executable (pathnames, environment variables, etc.).
3204 To make it easier to tell when this has happened with strings(1) we
3205 clear some known-to-be-garbage blocks of memory, so that leftover
3206 results of old evaluation don't look like potential problems.
3207 But first we set some notable variables to nil and do one more GC,
3208 to turn those strings into garbage.
3211 /* Yeah, this list is pretty ad-hoc... */
3212 Vprocess_environment = Qnil;
3213 Vexec_directory = Qnil;
3214 Vdata_directory = Qnil;
3215 Vsite_directory = Qnil;
3216 Vdoc_directory = Qnil;
3217 Vconfigure_info_directory = Qnil;
3220 /* Vdump_load_path = Qnil; */
3221 /* Release hash tables for locate_file */
3222 Flocate_file_clear_hashing (Qt);
3223 uncache_home_directory();
3225 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3226 defined(LOADHIST_BUILTIN))
3227 Vload_history = Qnil;
3229 Vshell_file_name = Qnil;
3231 garbage_collect_1 ();
3233 /* Run the disksave finalization methods of all live objects. */
3234 disksave_object_finalization_1 ();
3236 /* Zero out the uninitialized (really, unused) part of the containers
3237 for the live strings. */
3239 struct string_chars_block *scb;
3240 for (scb = first_string_chars_block; scb; scb = scb->next)
3242 int count = sizeof (scb->string_chars) - scb->pos;
3244 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3246 /* from the block's fill ptr to the end */
3247 memset ((scb->string_chars + scb->pos), 0, count);
3252 /* There, that ought to be enough... */
3258 restore_gc_inhibit (Lisp_Object val)
3260 gc_currently_forbidden = XINT (val);
3264 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3265 static int gc_hooks_inhibited;
3269 garbage_collect_1 (void)
3271 #if MAX_SAVE_STACK > 0
3272 char stack_top_variable;
3273 extern char *stack_bottom;
3278 Lisp_Object pre_gc_cursor;
3279 struct gcpro gcpro1;
3282 || gc_currently_forbidden
3284 || preparing_for_armageddon)
3287 /* We used to call selected_frame() here.
3289 The following functions cannot be called inside GC
3290 so we move to after the above tests. */
3293 Lisp_Object device = Fselected_device (Qnil);
3294 if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3296 frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3298 signal_simple_error ("No frames exist on device", device);
3302 pre_gc_cursor = Qnil;
3305 GCPRO1 (pre_gc_cursor);
3307 /* Very important to prevent GC during any of the following
3308 stuff that might run Lisp code; otherwise, we'll likely
3309 have infinite GC recursion. */
3310 speccount = specpdl_depth ();
3311 record_unwind_protect (restore_gc_inhibit,
3312 make_int (gc_currently_forbidden));
3313 gc_currently_forbidden = 1;
3315 if (!gc_hooks_inhibited)
3316 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3318 /* Now show the GC cursor/message. */
3319 if (!noninteractive)
3321 if (FRAME_WIN_P (f))
3323 Lisp_Object frame = make_frame (f);
3324 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3325 FRAME_SELECTED_WINDOW (f),
3327 pre_gc_cursor = f->pointer;
3328 if (POINTER_IMAGE_INSTANCEP (cursor)
3329 /* don't change if we don't know how to change back. */
3330 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3333 Fset_frame_pointer (frame, cursor);
3337 /* Don't print messages to the stream device. */
3338 if (!cursor_changed && !FRAME_STREAM_P (f))
3340 char *msg = (STRINGP (Vgc_message)
3341 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3343 Lisp_Object args[2], whole_msg;
3344 args[0] = build_string (msg ? msg :
3345 GETTEXT ((CONST char *) gc_default_message));
3346 args[1] = build_string ("...");
3347 whole_msg = Fconcat (2, args);
3348 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3349 Qgarbage_collecting);
3353 /***** Now we actually start the garbage collection. */
3357 gc_generation_number[0]++;
3359 #if MAX_SAVE_STACK > 0
3361 /* Save a copy of the contents of the stack, for debugging. */
3364 /* Static buffer in which we save a copy of the C stack at each GC. */
3365 static char *stack_copy;
3366 static size_t stack_copy_size;
3368 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3369 size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3370 if (stack_size < MAX_SAVE_STACK)
3372 if (stack_copy_size < stack_size)
3374 stack_copy = (char *) xrealloc (stack_copy, stack_size);
3375 stack_copy_size = stack_size;
3379 stack_diff > 0 ? stack_bottom : &stack_top_variable,
3383 #endif /* MAX_SAVE_STACK > 0 */
3385 /* Do some totally ad-hoc resource clearing. */
3386 /* #### generalize this? */
3387 clear_event_resource ();
3388 cleanup_specifiers ();
3390 /* Mark all the special slots that serve as the roots of accessibility. */
3394 for (i = 0; i < staticidx; i++)
3395 mark_object (*(staticvec[i]));
3401 for (tail = gcprolist; tail; tail = tail->next)
3402 for (i = 0; i < tail->nvars; i++)
3403 mark_object (tail->var[i]);
3407 struct specbinding *bind;
3408 for (bind = specpdl; bind != specpdl_ptr; bind++)
3410 mark_object (bind->symbol);
3411 mark_object (bind->old_value);
3416 struct catchtag *catch;
3417 for (catch = catchlist; catch; catch = catch->next)
3419 mark_object (catch->tag);
3420 mark_object (catch->val);
3425 struct backtrace *backlist;
3426 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3428 int nargs = backlist->nargs;
3431 mark_object (*backlist->function);
3432 if (nargs == UNEVALLED || nargs == MANY)
3433 mark_object (backlist->args[0]);
3435 for (i = 0; i < nargs; i++)
3436 mark_object (backlist->args[i]);
3440 mark_redisplay (mark_object);
3441 mark_profiling_info (mark_object);
3443 /* OK, now do the after-mark stuff. This is for things that
3444 are only marked when something else is marked (e.g. weak hash tables).
3445 There may be complex dependencies between such objects -- e.g.
3446 a weak hash table might be unmarked, but after processing a later
3447 weak hash table, the former one might get marked. So we have to
3448 iterate until nothing more gets marked. */
3450 while (finish_marking_weak_hash_tables (marked_p, mark_object) > 0 ||
3451 finish_marking_weak_lists (marked_p, mark_object) > 0)
3454 /* And prune (this needs to be called after everything else has been
3455 marked and before we do any sweeping). */
3456 /* #### this is somewhat ad-hoc and should probably be an object
3458 prune_weak_hash_tables (marked_p);
3459 prune_weak_lists (marked_p);
3460 prune_specifiers (marked_p);
3461 prune_syntax_tables (marked_p);
3465 consing_since_gc = 0;
3466 #ifndef DEBUG_XEMACS
3467 /* Allow you to set it really fucking low if you really want ... */
3468 if (gc_cons_threshold < 10000)
3469 gc_cons_threshold = 10000;
3474 /******* End of garbage collection ********/
3476 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
3478 /* Now remove the GC cursor/message */
3479 if (!noninteractive)
3482 Fset_frame_pointer (make_frame (f), pre_gc_cursor);
3483 else if (!FRAME_STREAM_P (f))
3485 char *msg = (STRINGP (Vgc_message)
3486 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3489 /* Show "...done" only if the echo area would otherwise be empty. */
3490 if (NILP (clear_echo_area (selected_frame (),
3491 Qgarbage_collecting, 0)))
3493 Lisp_Object args[2], whole_msg;
3494 args[0] = build_string (msg ? msg :
3495 GETTEXT ((CONST char *)
3496 gc_default_message));
3497 args[1] = build_string ("... done");
3498 whole_msg = Fconcat (2, args);
3499 echo_area_message (selected_frame (), (Bufbyte *) 0,
3501 Qgarbage_collecting);
3506 /* now stop inhibiting GC */
3507 unbind_to (speccount, Qnil);
3509 if (!breathing_space)
3511 breathing_space = malloc (4096 - MALLOC_OVERHEAD);
3518 /* Debugging aids. */
3521 gc_plist_hack (CONST char *name, int value, Lisp_Object tail)
3523 /* C doesn't have local functions (or closures, or GC, or readable syntax,
3524 or portable numeric datatypes, or bit-vectors, or characters, or
3525 arrays, or exceptions, or ...) */
3526 return cons3 (intern (name), make_int (value), tail);
3529 #define HACK_O_MATIC(type, name, pl) do { \
3531 struct type##_block *x = current_##type##_block; \
3532 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
3533 (pl) = gc_plist_hack ((name), s, (pl)); \
3536 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
3537 Reclaim storage for Lisp objects no longer needed.
3538 Return info on amount of space in use:
3539 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
3540 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
3542 where `PLIST' is a list of alternating keyword/value pairs providing
3543 more detailed information.
3544 Garbage collection happens automatically if you cons more than
3545 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
3549 Lisp_Object pl = Qnil;
3551 int gc_count_vector_total_size = 0;
3553 garbage_collect_1 ();
3555 for (i = 0; i < last_lrecord_type_index_assigned; i++)
3557 if (lcrecord_stats[i].bytes_in_use != 0
3558 || lcrecord_stats[i].bytes_freed != 0
3559 || lcrecord_stats[i].instances_on_free_list != 0)
3562 CONST char *name = lrecord_implementations_table[i]->name;
3563 int len = strlen (name);
3564 /* save this for the FSFmacs-compatible part of the summary */
3565 if (i == *lrecord_vector.lrecord_type_index)
3566 gc_count_vector_total_size =
3567 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
3569 sprintf (buf, "%s-storage", name);
3570 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
3571 /* Okay, simple pluralization check for `symbol-value-varalias' */
3572 if (name[len-1] == 's')
3573 sprintf (buf, "%ses-freed", name);
3575 sprintf (buf, "%ss-freed", name);
3576 if (lcrecord_stats[i].instances_freed != 0)
3577 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
3578 if (name[len-1] == 's')
3579 sprintf (buf, "%ses-on-free-list", name);
3581 sprintf (buf, "%ss-on-free-list", name);
3582 if (lcrecord_stats[i].instances_on_free_list != 0)
3583 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
3585 if (name[len-1] == 's')
3586 sprintf (buf, "%ses-used", name);
3588 sprintf (buf, "%ss-used", name);
3589 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
3593 HACK_O_MATIC (extent, "extent-storage", pl);
3594 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
3595 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
3596 HACK_O_MATIC (event, "event-storage", pl);
3597 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
3598 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
3599 HACK_O_MATIC (marker, "marker-storage", pl);
3600 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
3601 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
3602 #ifdef LISP_FLOAT_TYPE
3603 HACK_O_MATIC (float, "float-storage", pl);
3604 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
3605 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
3606 #endif /* LISP_FLOAT_TYPE */
3607 HACK_O_MATIC (string, "string-header-storage", pl);
3608 pl = gc_plist_hack ("long-strings-total-length",
3609 gc_count_string_total_size
3610 - gc_count_short_string_total_size, pl);
3611 HACK_O_MATIC (string_chars, "short-string-storage", pl);
3612 pl = gc_plist_hack ("short-strings-total-length",
3613 gc_count_short_string_total_size, pl);
3614 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
3615 pl = gc_plist_hack ("long-strings-used",
3616 gc_count_num_string_in_use
3617 - gc_count_num_short_string_in_use, pl);
3618 pl = gc_plist_hack ("short-strings-used",
3619 gc_count_num_short_string_in_use, pl);
3621 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
3622 pl = gc_plist_hack ("compiled-functions-free",
3623 gc_count_num_compiled_function_freelist, pl);
3624 pl = gc_plist_hack ("compiled-functions-used",
3625 gc_count_num_compiled_function_in_use, pl);
3627 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
3628 pl = gc_plist_hack ("bit-vectors-total-length",
3629 gc_count_bit_vector_total_size, pl);
3630 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
3632 HACK_O_MATIC (symbol, "symbol-storage", pl);
3633 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
3634 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
3636 HACK_O_MATIC (cons, "cons-storage", pl);
3637 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
3638 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
3640 /* The things we do for backwards-compatibility */
3642 list6 (Fcons (make_int (gc_count_num_cons_in_use),
3643 make_int (gc_count_num_cons_freelist)),
3644 Fcons (make_int (gc_count_num_symbol_in_use),
3645 make_int (gc_count_num_symbol_freelist)),
3646 Fcons (make_int (gc_count_num_marker_in_use),
3647 make_int (gc_count_num_marker_freelist)),
3648 make_int (gc_count_string_total_size),
3649 make_int (gc_count_vector_total_size),
3654 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
3655 Return the number of bytes consed since the last garbage collection.
3656 \"Consed\" is a misnomer in that this actually counts allocation
3657 of all different kinds of objects, not just conses.
3659 If this value exceeds `gc-cons-threshold', a garbage collection happens.
3663 return make_int (consing_since_gc);
3666 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
3667 Return the address of the last byte Emacs has allocated, divided by 1024.
3668 This may be helpful in debugging Emacs's memory usage.
3669 The value is divided by 1024 to make sure it will fit in a lisp integer.
3673 return make_int ((EMACS_INT) sbrk (0) / 1024);
3679 object_dead_p (Lisp_Object obj)
3681 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
3682 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
3683 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
3684 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
3685 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
3686 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
3687 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
3690 #ifdef MEMORY_USAGE_STATS
3692 /* Attempt to determine the actual amount of space that is used for
3693 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
3695 It seems that the following holds:
3697 1. When using the old allocator (malloc.c):
3699 -- blocks are always allocated in chunks of powers of two. For
3700 each block, there is an overhead of 8 bytes if rcheck is not
3701 defined, 20 bytes if it is defined. In other words, a
3702 one-byte allocation needs 8 bytes of overhead for a total of
3703 9 bytes, and needs to have 16 bytes of memory chunked out for
3706 2. When using the new allocator (gmalloc.c):
3708 -- blocks are always allocated in chunks of powers of two up
3709 to 4096 bytes. Larger blocks are allocated in chunks of
3710 an integral multiple of 4096 bytes. The minimum block
3711 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
3712 is defined. There is no per-block overhead, but there
3713 is an overhead of 3*sizeof (size_t) for each 4096 bytes
3716 3. When using the system malloc, anything goes, but they are
3717 generally slower and more space-efficient than the GNU
3718 allocators. One possibly reasonable assumption to make
3719 for want of better data is that sizeof (void *), or maybe
3720 2 * sizeof (void *), is required as overhead and that
3721 blocks are allocated in the minimum required size except
3722 that some minimum block size is imposed (e.g. 16 bytes). */
3725 malloced_storage_size (void *ptr, size_t claimed_size,
3726 struct overhead_stats *stats)
3728 size_t orig_claimed_size = claimed_size;
3732 if (claimed_size < 2 * sizeof (void *))
3733 claimed_size = 2 * sizeof (void *);
3734 # ifdef SUNOS_LOCALTIME_BUG
3735 if (claimed_size < 16)
3738 if (claimed_size < 4096)
3742 /* compute the log base two, more or less, then use it to compute
3743 the block size needed. */
3745 /* It's big, it's heavy, it's wood! */
3746 while ((claimed_size /= 2) != 0)
3749 /* It's better than bad, it's good! */
3755 /* We have to come up with some average about the amount of
3757 if ((size_t) (rand () & 4095) < claimed_size)
3758 claimed_size += 3 * sizeof (void *);
3762 claimed_size += 4095;
3763 claimed_size &= ~4095;
3764 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
3767 #elif defined (SYSTEM_MALLOC)
3769 if (claimed_size < 16)
3771 claimed_size += 2 * sizeof (void *);
3773 #else /* old GNU allocator */
3775 # ifdef rcheck /* #### may not be defined here */
3783 /* compute the log base two, more or less, then use it to compute
3784 the block size needed. */
3786 /* It's big, it's heavy, it's wood! */
3787 while ((claimed_size /= 2) != 0)
3790 /* It's better than bad, it's good! */
3798 #endif /* old GNU allocator */
3802 stats->was_requested += orig_claimed_size;
3803 stats->malloc_overhead += claimed_size - orig_claimed_size;
3805 return claimed_size;
3809 fixed_type_block_overhead (size_t size)
3811 size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
3812 size_t overhead = 0;
3813 size_t storage_size = malloced_storage_size (0, per_block, 0);
3814 while (size >= per_block)
3817 overhead += sizeof (void *) + per_block - storage_size;
3819 if (rand () % per_block < size)
3820 overhead += sizeof (void *) + per_block - storage_size;
3824 #endif /* MEMORY_USAGE_STATS */
3827 /* Initialization */
3829 init_alloc_once_early (void)
3833 last_lrecord_type_index_assigned = -1;
3834 for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
3836 lrecord_implementations_table[iii] = 0;
3841 * defined subr lrecords were initialized with lheader->type == 0.
3842 * See subr_lheader_initializer in lisp.h. Force type index 0 to be
3843 * assigned to lrecord_subr so that those predefined indexes match
3846 lrecord_type_index (&lrecord_subr);
3847 assert (*(lrecord_subr.lrecord_type_index) == 0);
3849 * The same is true for symbol_value_forward objects, except the
3852 lrecord_type_index (&lrecord_symbol_value_forward);
3853 assert (*(lrecord_symbol_value_forward.lrecord_type_index) == 1);
3855 gc_generation_number[0] = 0;
3856 /* purify_flag 1 is correct even if CANNOT_DUMP.
3857 * loadup.el will set to nil at end. */
3859 breathing_space = 0;
3860 XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
3861 XSETINT (Vgc_message, 0);
3863 ignore_malloc_warnings = 1;
3864 #ifdef DOUG_LEA_MALLOC
3865 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
3866 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
3867 #if 0 /* Moved to emacs.c */
3868 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
3871 init_string_alloc ();
3872 init_string_chars_alloc ();
3874 init_symbol_alloc ();
3875 init_compiled_function_alloc ();
3876 #ifdef LISP_FLOAT_TYPE
3877 init_float_alloc ();
3878 #endif /* LISP_FLOAT_TYPE */
3879 init_marker_alloc ();
3880 init_extent_alloc ();
3881 init_event_alloc ();
3883 ignore_malloc_warnings = 0;
3885 consing_since_gc = 0;
3887 gc_cons_threshold = 500000; /* XEmacs change */
3889 gc_cons_threshold = 15000; /* debugging */
3891 #ifdef VIRT_ADDR_VARIES
3892 malloc_sbrk_unused = 1<<22; /* A large number */
3893 malloc_sbrk_used = 100000; /* as reasonable as any number */
3894 #endif /* VIRT_ADDR_VARIES */
3895 lrecord_uid_counter = 259;
3896 debug_string_purity = 0;
3899 gc_currently_forbidden = 0;
3900 gc_hooks_inhibited = 0;
3902 #ifdef ERROR_CHECK_TYPECHECK
3903 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3906 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
3908 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
3910 #endif /* ERROR_CHECK_TYPECHECK */
3913 int pure_bytes_used = 0;
3922 syms_of_alloc (void)
3924 defsymbol (&Qpre_gc_hook, "pre-gc-hook");
3925 defsymbol (&Qpost_gc_hook, "post-gc-hook");
3926 defsymbol (&Qgarbage_collecting, "garbage-collecting");
3931 DEFSUBR (Fbit_vector);
3932 DEFSUBR (Fmake_byte_code);
3933 DEFSUBR (Fmake_list);
3934 DEFSUBR (Fmake_vector);
3935 DEFSUBR (Fmake_bit_vector);
3936 DEFSUBR (Fmake_string);
3938 DEFSUBR (Fmake_symbol);
3939 DEFSUBR (Fmake_marker);
3940 DEFSUBR (Fpurecopy);
3941 DEFSUBR (Fgarbage_collect);
3942 DEFSUBR (Fmemory_limit);
3943 DEFSUBR (Fconsing_since_gc);
3947 vars_of_alloc (void)
3949 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
3950 *Number of bytes of consing between garbage collections.
3951 \"Consing\" is a misnomer in that this actually counts allocation
3952 of all different kinds of objects, not just conses.
3953 Garbage collection can happen automatically once this many bytes have been
3954 allocated since the last garbage collection. All data types count.
3956 Garbage collection happens automatically when `eval' or `funcall' are
3957 called. (Note that `funcall' is called implicitly as part of evaluation.)
3958 By binding this temporarily to a large number, you can effectively
3959 prevent garbage collection during a part of the program.
3961 See also `consing-since-gc'.
3964 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
3965 Number of bytes of sharable Lisp data allocated so far.
3969 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
3970 Number of bytes of unshared memory allocated in this session.
3973 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
3974 Number of bytes of unshared memory remaining available in this session.
3979 DEFVAR_INT ("debug-allocation", &debug_allocation /*
3980 If non-zero, print out information to stderr about all objects allocated.
3981 See also `debug-allocation-backtrace-length'.
3983 debug_allocation = 0;
3985 DEFVAR_INT ("debug-allocation-backtrace-length",
3986 &debug_allocation_backtrace_length /*
3987 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
3989 debug_allocation_backtrace_length = 2;
3992 DEFVAR_BOOL ("purify-flag", &purify_flag /*
3993 Non-nil means loading Lisp code in order to dump an executable.
3994 This means that certain objects should be allocated in readonly space.
3997 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
3998 Function or functions to be run just before each garbage collection.
3999 Interrupts, garbage collection, and errors are inhibited while this hook
4000 runs, so be extremely careful in what you add here. In particular, avoid
4001 consing, and do not interact with the user.
4003 Vpre_gc_hook = Qnil;
4005 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
4006 Function or functions to be run just after each garbage collection.
4007 Interrupts, garbage collection, and errors are inhibited while this hook
4008 runs, so be extremely careful in what you add here. In particular, avoid
4009 consing, and do not interact with the user.
4011 Vpost_gc_hook = Qnil;
4013 DEFVAR_LISP ("gc-message", &Vgc_message /*
4014 String to print to indicate that a garbage collection is in progress.
4015 This is printed in the echo area. If the selected frame is on a
4016 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
4017 image instance) in the domain of the selected frame, the mouse pointer
4018 will change instead of this message being printed.
4020 Vgc_message = make_string_nocopy ((CONST Bufbyte *) gc_default_message,
4021 countof (gc_default_message) - 1);
4023 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
4024 Pointer glyph used to indicate that a garbage collection is in progress.
4025 If the selected window is on a window system and this glyph specifies a
4026 value (i.e. a pointer image instance) in the domain of the selected
4027 window, the pointer will be changed as specified during garbage collection.
4028 Otherwise, a message will be printed in the echo area, as controlled
4034 complex_vars_of_alloc (void)
4036 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);