1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999,
3 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
20 Boston, MA 02110-1301, USA. */
24 #include <limits.h> /* For CHAR_BIT. */
30 /* Note that this declares bzero on OSF/1. How dumb. */
34 #ifdef HAVE_GTK_AND_PTHREAD
38 /* This file is part of the core Lisp implementation, and thus must
39 deal with the real data structures. If the Lisp implementation is
40 replaced, this file likely will not be used. */
42 #undef HIDE_LISP_IMPLEMENTATION
45 #include "intervals.h"
51 #include "blockinput.h"
53 #include "syssignal.h"
56 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
57 memory. Can do this only if using gmalloc.c. */
59 #if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
60 #undef GC_MALLOC_CHECK
66 extern POINTER_TYPE
*sbrk ();
70 #define INCLUDED_FCNTL
77 #ifdef DOUG_LEA_MALLOC
80 /* malloc.h #defines this as size_t, at least in glibc2. */
81 #ifndef __malloc_size_t
82 #define __malloc_size_t int
85 /* Specify maximum number of areas to mmap. It would be nice to use a
86 value that explicitly means "no limit". */
88 #define MMAP_MAX_AREAS 100000000
90 #else /* not DOUG_LEA_MALLOC */
92 /* The following come from gmalloc.c. */
94 #define __malloc_size_t size_t
95 extern __malloc_size_t _bytes_used
;
96 extern __malloc_size_t __malloc_extra_blocks
;
98 #endif /* not DOUG_LEA_MALLOC */
100 #if ! defined (SYSTEM_MALLOC) && defined (HAVE_GTK_AND_PTHREAD)
102 /* When GTK uses the file chooser dialog, different backends can be loaded
103 dynamically. One such a backend is the Gnome VFS backend that gets loaded
104 if you run Gnome. That backend creates several threads and also allocates
107 If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
108 functions below are called from malloc, there is a chance that one
109 of these threads preempts the Emacs main thread and the hook variables
110 end up in an inconsistent state. So we have a mutex to prevent that (note
111 that the backend handles concurrent access to malloc within its own threads
112 but Emacs code running in the main thread is not included in that control).
114 When UNBLOCK_INPUT is called, reinvoke_input_signal may be called. If this
115 happens in one of the backend threads we will have two threads that tries
116 to run Emacs code at once, and the code is not prepared for that.
117 To prevent that, we only call BLOCK/UNBLOCK from the main thread. */
119 static pthread_mutex_t alloc_mutex
;
121 #define BLOCK_INPUT_ALLOC \
124 pthread_mutex_lock (&alloc_mutex); \
125 if (pthread_self () == main_thread) \
129 #define UNBLOCK_INPUT_ALLOC \
132 if (pthread_self () == main_thread) \
134 pthread_mutex_unlock (&alloc_mutex); \
138 #else /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
140 #define BLOCK_INPUT_ALLOC BLOCK_INPUT
141 #define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
143 #endif /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
145 /* Value of _bytes_used, when spare_memory was freed. */
147 static __malloc_size_t bytes_used_when_full
;
149 static __malloc_size_t bytes_used_when_reconsidered
;
151 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
152 to a struct Lisp_String. */
154 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
155 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
156 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
158 #define VECTOR_MARK(V) ((V)->size |= ARRAY_MARK_FLAG)
159 #define VECTOR_UNMARK(V) ((V)->size &= ~ARRAY_MARK_FLAG)
160 #define VECTOR_MARKED_P(V) (((V)->size & ARRAY_MARK_FLAG) != 0)
162 /* Value is the number of bytes/chars of S, a pointer to a struct
163 Lisp_String. This must be used instead of STRING_BYTES (S) or
164 S->size during GC, because S->size contains the mark bit for
167 #define GC_STRING_BYTES(S) (STRING_BYTES (S))
168 #define GC_STRING_CHARS(S) ((S)->size & ~ARRAY_MARK_FLAG)
170 /* Number of bytes of consing done since the last gc. */
172 int consing_since_gc
;
174 /* Count the amount of consing of various sorts of space. */
176 EMACS_INT cons_cells_consed
;
177 EMACS_INT floats_consed
;
178 EMACS_INT vector_cells_consed
;
179 EMACS_INT symbols_consed
;
180 EMACS_INT string_chars_consed
;
181 EMACS_INT misc_objects_consed
;
182 EMACS_INT intervals_consed
;
183 EMACS_INT strings_consed
;
185 /* Minimum number of bytes of consing since GC before next GC. */
187 EMACS_INT gc_cons_threshold
;
189 /* Similar minimum, computed from Vgc_cons_percentage. */
191 EMACS_INT gc_relative_threshold
;
193 static Lisp_Object Vgc_cons_percentage
;
195 /* Minimum number of bytes of consing since GC before next GC,
196 when memory is full. */
198 EMACS_INT memory_full_cons_threshold
;
200 /* Nonzero during GC. */
204 /* Nonzero means abort if try to GC.
205 This is for code which is written on the assumption that
206 no GC will happen, so as to verify that assumption. */
210 /* Nonzero means display messages at beginning and end of GC. */
212 int garbage_collection_messages
;
214 #ifndef VIRT_ADDR_VARIES
216 #endif /* VIRT_ADDR_VARIES */
217 int malloc_sbrk_used
;
219 #ifndef VIRT_ADDR_VARIES
221 #endif /* VIRT_ADDR_VARIES */
222 int malloc_sbrk_unused
;
224 /* Number of live and free conses etc. */
226 static int total_conses
, total_markers
, total_symbols
, total_vector_size
;
227 static int total_free_conses
, total_free_markers
, total_free_symbols
;
228 static int total_free_floats
, total_floats
;
230 /* Points to memory space allocated as "spare", to be freed if we run
231 out of memory. We keep one large block, four cons-blocks, and
232 two string blocks. */
234 char *spare_memory
[7];
236 /* Amount of spare memory to keep in large reserve block. */
238 #define SPARE_MEMORY (1 << 14)
240 /* Number of extra blocks malloc should get when it needs more core. */
242 static int malloc_hysteresis
;
244 /* Non-nil means defun should do purecopy on the function definition. */
246 Lisp_Object Vpurify_flag
;
248 /* Non-nil means we are handling a memory-full error. */
250 Lisp_Object Vmemory_full
;
254 /* Initialize it to a nonzero value to force it into data space
255 (rather than bss space). That way unexec will remap it into text
256 space (pure), on some systems. We have not implemented the
257 remapping on more recent systems because this is less important
258 nowadays than in the days of small memories and timesharing. */
260 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {1,};
261 #define PUREBEG (char *) pure
265 #define pure PURE_SEG_BITS /* Use shared memory segment */
266 #define PUREBEG (char *)PURE_SEG_BITS
268 #endif /* HAVE_SHM */
270 /* Pointer to the pure area, and its size. */
272 static char *purebeg
;
273 static size_t pure_size
;
275 /* Number of bytes of pure storage used before pure storage overflowed.
276 If this is non-zero, this implies that an overflow occurred. */
278 static size_t pure_bytes_used_before_overflow
;
280 /* Value is non-zero if P points into pure space. */
282 #define PURE_POINTER_P(P) \
283 (((PNTR_COMPARISON_TYPE) (P) \
284 < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size)) \
285 && ((PNTR_COMPARISON_TYPE) (P) \
286 >= (PNTR_COMPARISON_TYPE) purebeg))
288 /* Index in pure at which next pure object will be allocated.. */
290 EMACS_INT pure_bytes_used
;
292 /* If nonzero, this is a warning delivered by malloc and not yet
295 char *pending_malloc_warning
;
297 /* Pre-computed signal argument for use when memory is exhausted. */
299 Lisp_Object Vmemory_signal_data
;
301 /* Maximum amount of C stack to save when a GC happens. */
303 #ifndef MAX_SAVE_STACK
304 #define MAX_SAVE_STACK 16000
307 /* Buffer in which we save a copy of the C stack at each GC. */
312 /* Non-zero means ignore malloc warnings. Set during initialization.
313 Currently not used. */
317 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
319 /* Hook run after GC has finished. */
321 Lisp_Object Vpost_gc_hook
, Qpost_gc_hook
;
323 Lisp_Object Vgc_elapsed
; /* accumulated elapsed time in GC */
324 EMACS_INT gcs_done
; /* accumulated GCs */
326 static void mark_buffer
P_ ((Lisp_Object
));
327 extern void mark_kboards
P_ ((void));
328 extern void mark_backtrace
P_ ((void));
329 static void gc_sweep
P_ ((void));
330 static void mark_glyph_matrix
P_ ((struct glyph_matrix
*));
331 static void mark_face_cache
P_ ((struct face_cache
*));
333 #ifdef HAVE_WINDOW_SYSTEM
334 extern void mark_fringe_data
P_ ((void));
335 static void mark_image
P_ ((struct image
*));
336 static void mark_image_cache
P_ ((struct frame
*));
337 #endif /* HAVE_WINDOW_SYSTEM */
339 static struct Lisp_String
*allocate_string
P_ ((void));
340 static void compact_small_strings
P_ ((void));
341 static void free_large_strings
P_ ((void));
342 static void sweep_strings
P_ ((void));
344 extern int message_enable_multibyte
;
346 /* When scanning the C stack for live Lisp objects, Emacs keeps track
347 of what memory allocated via lisp_malloc is intended for what
348 purpose. This enumeration specifies the type of memory. */
359 /* Keep the following vector-like types together, with
360 MEM_TYPE_WINDOW being the last, and MEM_TYPE_VECTOR the
361 first. Or change the code of live_vector_p, for instance. */
369 static POINTER_TYPE
*lisp_align_malloc
P_ ((size_t, enum mem_type
));
370 static POINTER_TYPE
*lisp_malloc
P_ ((size_t, enum mem_type
));
371 void refill_memory_reserve ();
374 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
376 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
377 #include <stdio.h> /* For fprintf. */
380 /* A unique object in pure space used to make some Lisp objects
381 on free lists recognizable in O(1). */
385 #ifdef GC_MALLOC_CHECK
387 enum mem_type allocated_mem_type
;
388 int dont_register_blocks
;
390 #endif /* GC_MALLOC_CHECK */
392 /* A node in the red-black tree describing allocated memory containing
393 Lisp data. Each such block is recorded with its start and end
394 address when it is allocated, and removed from the tree when it
397 A red-black tree is a balanced binary tree with the following
400 1. Every node is either red or black.
401 2. Every leaf is black.
402 3. If a node is red, then both of its children are black.
403 4. Every simple path from a node to a descendant leaf contains
404 the same number of black nodes.
405 5. The root is always black.
407 When nodes are inserted into the tree, or deleted from the tree,
408 the tree is "fixed" so that these properties are always true.
410 A red-black tree with N internal nodes has height at most 2
411 log(N+1). Searches, insertions and deletions are done in O(log N).
412 Please see a text book about data structures for a detailed
413 description of red-black trees. Any book worth its salt should
418 /* Children of this node. These pointers are never NULL. When there
419 is no child, the value is MEM_NIL, which points to a dummy node. */
420 struct mem_node
*left
, *right
;
422 /* The parent of this node. In the root node, this is NULL. */
423 struct mem_node
*parent
;
425 /* Start and end of allocated region. */
429 enum {MEM_BLACK
, MEM_RED
} color
;
435 /* Base address of stack. Set in main. */
437 Lisp_Object
*stack_base
;
439 /* Root of the tree describing allocated Lisp memory. */
441 static struct mem_node
*mem_root
;
443 /* Lowest and highest known address in the heap. */
445 static void *min_heap_address
, *max_heap_address
;
447 /* Sentinel node of the tree. */
449 static struct mem_node mem_z
;
450 #define MEM_NIL &mem_z
452 static POINTER_TYPE
*lisp_malloc
P_ ((size_t, enum mem_type
));
453 static struct Lisp_Vector
*allocate_vectorlike
P_ ((EMACS_INT
, enum mem_type
));
454 static void lisp_free
P_ ((POINTER_TYPE
*));
455 static void mark_stack
P_ ((void));
456 static int live_vector_p
P_ ((struct mem_node
*, void *));
457 static int live_buffer_p
P_ ((struct mem_node
*, void *));
458 static int live_string_p
P_ ((struct mem_node
*, void *));
459 static int live_cons_p
P_ ((struct mem_node
*, void *));
460 static int live_symbol_p
P_ ((struct mem_node
*, void *));
461 static int live_float_p
P_ ((struct mem_node
*, void *));
462 static int live_misc_p
P_ ((struct mem_node
*, void *));
463 static void mark_maybe_object
P_ ((Lisp_Object
));
464 static void mark_memory
P_ ((void *, void *));
465 static void mem_init
P_ ((void));
466 static struct mem_node
*mem_insert
P_ ((void *, void *, enum mem_type
));
467 static void mem_insert_fixup
P_ ((struct mem_node
*));
468 static void mem_rotate_left
P_ ((struct mem_node
*));
469 static void mem_rotate_right
P_ ((struct mem_node
*));
470 static void mem_delete
P_ ((struct mem_node
*));
471 static void mem_delete_fixup
P_ ((struct mem_node
*));
472 static INLINE
struct mem_node
*mem_find
P_ ((void *));
475 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
476 static void check_gcpros
P_ ((void));
479 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
481 /* Recording what needs to be marked for gc. */
483 struct gcpro
*gcprolist
;
485 /* Addresses of staticpro'd variables. Initialize it to a nonzero
486 value; otherwise some compilers put it into BSS. */
488 #define NSTATICS 1280
489 Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
491 /* Index of next unused slot in staticvec. */
495 static POINTER_TYPE
*pure_alloc
P_ ((size_t, int));
498 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
499 ALIGNMENT must be a power of 2. */
501 #define ALIGN(ptr, ALIGNMENT) \
502 ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
503 & ~((ALIGNMENT) - 1)))
507 /************************************************************************
509 ************************************************************************/
511 /* Function malloc calls this if it finds we are near exhausting storage. */
517 pending_malloc_warning
= str
;
521 /* Display an already-pending malloc warning. */
524 display_malloc_warning ()
526 call3 (intern ("display-warning"),
528 build_string (pending_malloc_warning
),
529 intern ("emergency"));
530 pending_malloc_warning
= 0;
534 #ifdef DOUG_LEA_MALLOC
535 # define BYTES_USED (mallinfo ().uordblks)
537 # define BYTES_USED _bytes_used
540 /* Called if we can't allocate relocatable space for a buffer. */
543 buffer_memory_full ()
545 /* If buffers use the relocating allocator, no need to free
546 spare_memory, because we may have plenty of malloc space left
547 that we could get, and if we don't, the malloc that fails will
548 itself cause spare_memory to be freed. If buffers don't use the
549 relocating allocator, treat this like any other failing
556 /* This used to call error, but if we've run out of memory, we could
557 get infinite recursion trying to build the string. */
559 Fsignal (Qnil
, Vmemory_signal_data
);
563 #ifdef XMALLOC_OVERRUN_CHECK
565 /* Check for overrun in malloc'ed buffers by wrapping a 16 byte header
566 and a 16 byte trailer around each block.
568 The header consists of 12 fixed bytes + a 4 byte integer contaning the
569 original block size, while the trailer consists of 16 fixed bytes.
571 The header is used to detect whether this block has been allocated
572 through these functions -- as it seems that some low-level libc
573 functions may bypass the malloc hooks.
577 #define XMALLOC_OVERRUN_CHECK_SIZE 16
579 static char xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
-4] =
580 { 0x9a, 0x9b, 0xae, 0xaf,
581 0xbf, 0xbe, 0xce, 0xcf,
582 0xea, 0xeb, 0xec, 0xed };
584 static char xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
585 { 0xaa, 0xab, 0xac, 0xad,
586 0xba, 0xbb, 0xbc, 0xbd,
587 0xca, 0xcb, 0xcc, 0xcd,
588 0xda, 0xdb, 0xdc, 0xdd };
590 /* Macros to insert and extract the block size in the header. */
592 #define XMALLOC_PUT_SIZE(ptr, size) \
593 (ptr[-1] = (size & 0xff), \
594 ptr[-2] = ((size >> 8) & 0xff), \
595 ptr[-3] = ((size >> 16) & 0xff), \
596 ptr[-4] = ((size >> 24) & 0xff))
598 #define XMALLOC_GET_SIZE(ptr) \
599 (size_t)((unsigned)(ptr[-1]) | \
600 ((unsigned)(ptr[-2]) << 8) | \
601 ((unsigned)(ptr[-3]) << 16) | \
602 ((unsigned)(ptr[-4]) << 24))
605 /* The call depth in overrun_check functions. For example, this might happen:
607 overrun_check_malloc()
608 -> malloc -> (via hook)_-> emacs_blocked_malloc
609 -> overrun_check_malloc
610 call malloc (hooks are NULL, so real malloc is called).
611 malloc returns 10000.
612 add overhead, return 10016.
613 <- (back in overrun_check_malloc)
614 add overhead again, return 10032
615 xmalloc returns 10032.
620 overrun_check_free(10032)
622 free(10016) <- crash, because 10000 is the original pointer. */
624 static int check_depth
;
626 /* Like malloc, but wraps allocated block with header and trailer. */
629 overrun_check_malloc (size
)
632 register unsigned char *val
;
633 size_t overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_SIZE
*2 : 0;
635 val
= (unsigned char *) malloc (size
+ overhead
);
636 if (val
&& check_depth
== 1)
638 bcopy (xmalloc_overrun_check_header
, val
, XMALLOC_OVERRUN_CHECK_SIZE
- 4);
639 val
+= XMALLOC_OVERRUN_CHECK_SIZE
;
640 XMALLOC_PUT_SIZE(val
, size
);
641 bcopy (xmalloc_overrun_check_trailer
, val
+ size
, XMALLOC_OVERRUN_CHECK_SIZE
);
644 return (POINTER_TYPE
*)val
;
648 /* Like realloc, but checks old block for overrun, and wraps new block
649 with header and trailer. */
652 overrun_check_realloc (block
, size
)
656 register unsigned char *val
= (unsigned char *)block
;
657 size_t overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_SIZE
*2 : 0;
661 && bcmp (xmalloc_overrun_check_header
,
662 val
- XMALLOC_OVERRUN_CHECK_SIZE
,
663 XMALLOC_OVERRUN_CHECK_SIZE
- 4) == 0)
665 size_t osize
= XMALLOC_GET_SIZE (val
);
666 if (bcmp (xmalloc_overrun_check_trailer
,
668 XMALLOC_OVERRUN_CHECK_SIZE
))
670 bzero (val
+ osize
, XMALLOC_OVERRUN_CHECK_SIZE
);
671 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
672 bzero (val
, XMALLOC_OVERRUN_CHECK_SIZE
);
675 val
= (unsigned char *) realloc ((POINTER_TYPE
*)val
, size
+ overhead
);
677 if (val
&& check_depth
== 1)
679 bcopy (xmalloc_overrun_check_header
, val
, XMALLOC_OVERRUN_CHECK_SIZE
- 4);
680 val
+= XMALLOC_OVERRUN_CHECK_SIZE
;
681 XMALLOC_PUT_SIZE(val
, size
);
682 bcopy (xmalloc_overrun_check_trailer
, val
+ size
, XMALLOC_OVERRUN_CHECK_SIZE
);
685 return (POINTER_TYPE
*)val
;
688 /* Like free, but checks block for overrun. */
691 overrun_check_free (block
)
694 unsigned char *val
= (unsigned char *)block
;
699 && bcmp (xmalloc_overrun_check_header
,
700 val
- XMALLOC_OVERRUN_CHECK_SIZE
,
701 XMALLOC_OVERRUN_CHECK_SIZE
- 4) == 0)
703 size_t osize
= XMALLOC_GET_SIZE (val
);
704 if (bcmp (xmalloc_overrun_check_trailer
,
706 XMALLOC_OVERRUN_CHECK_SIZE
))
708 #ifdef XMALLOC_CLEAR_FREE_MEMORY
709 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
710 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_SIZE
*2);
712 bzero (val
+ osize
, XMALLOC_OVERRUN_CHECK_SIZE
);
713 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
714 bzero (val
, XMALLOC_OVERRUN_CHECK_SIZE
);
725 #define malloc overrun_check_malloc
726 #define realloc overrun_check_realloc
727 #define free overrun_check_free
731 /* Like malloc but check for no memory and block interrupt input.. */
737 register POINTER_TYPE
*val
;
740 val
= (POINTER_TYPE
*) malloc (size
);
749 /* Like realloc but check for no memory and block interrupt input.. */
752 xrealloc (block
, size
)
756 register POINTER_TYPE
*val
;
759 /* We must call malloc explicitly when BLOCK is 0, since some
760 reallocs don't do this. */
762 val
= (POINTER_TYPE
*) malloc (size
);
764 val
= (POINTER_TYPE
*) realloc (block
, size
);
767 if (!val
&& size
) memory_full ();
772 /* Like free but block interrupt input. */
781 /* We don't call refill_memory_reserve here
782 because that duplicates doing so in emacs_blocked_free
783 and the criterion should go there. */
787 /* Like strdup, but uses xmalloc. */
793 size_t len
= strlen (s
) + 1;
794 char *p
= (char *) xmalloc (len
);
800 /* Unwind for SAFE_ALLOCA */
803 safe_alloca_unwind (arg
)
806 register struct Lisp_Save_Value
*p
= XSAVE_VALUE (arg
);
816 /* Like malloc but used for allocating Lisp data. NBYTES is the
817 number of bytes to allocate, TYPE describes the intended use of the
818 allcated memory block (for strings, for conses, ...). */
821 static void *lisp_malloc_loser
;
824 static POINTER_TYPE
*
825 lisp_malloc (nbytes
, type
)
833 #ifdef GC_MALLOC_CHECK
834 allocated_mem_type
= type
;
837 val
= (void *) malloc (nbytes
);
840 /* If the memory just allocated cannot be addressed thru a Lisp
841 object's pointer, and it needs to be,
842 that's equivalent to running out of memory. */
843 if (val
&& type
!= MEM_TYPE_NON_LISP
)
846 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
847 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
849 lisp_malloc_loser
= val
;
856 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
857 if (val
&& type
!= MEM_TYPE_NON_LISP
)
858 mem_insert (val
, (char *) val
+ nbytes
, type
);
867 /* Free BLOCK. This must be called to free memory allocated with a
868 call to lisp_malloc. */
876 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
877 mem_delete (mem_find (block
));
882 /* Allocation of aligned blocks of memory to store Lisp data. */
883 /* The entry point is lisp_align_malloc which returns blocks of at most */
884 /* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
887 /* BLOCK_ALIGN has to be a power of 2. */
888 #define BLOCK_ALIGN (1 << 10)
890 /* Padding to leave at the end of a malloc'd block. This is to give
891 malloc a chance to minimize the amount of memory wasted to alignment.
892 It should be tuned to the particular malloc library used.
893 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
894 posix_memalign on the other hand would ideally prefer a value of 4
895 because otherwise, there's 1020 bytes wasted between each ablocks.
896 In Emacs, testing shows that those 1020 can most of the time be
897 efficiently used by malloc to place other objects, so a value of 0 can
898 still preferable unless you have a lot of aligned blocks and virtually
900 #define BLOCK_PADDING 0
901 #define BLOCK_BYTES \
902 (BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
904 /* Internal data structures and constants. */
906 #define ABLOCKS_SIZE 16
908 /* An aligned block of memory. */
913 char payload
[BLOCK_BYTES
];
914 struct ablock
*next_free
;
916 /* `abase' is the aligned base of the ablocks. */
917 /* It is overloaded to hold the virtual `busy' field that counts
918 the number of used ablock in the parent ablocks.
919 The first ablock has the `busy' field, the others have the `abase'
920 field. To tell the difference, we assume that pointers will have
921 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
922 is used to tell whether the real base of the parent ablocks is `abase'
923 (if not, the word before the first ablock holds a pointer to the
925 struct ablocks
*abase
;
926 /* The padding of all but the last ablock is unused. The padding of
927 the last ablock in an ablocks is not allocated. */
929 char padding
[BLOCK_PADDING
];
933 /* A bunch of consecutive aligned blocks. */
936 struct ablock blocks
[ABLOCKS_SIZE
];
939 /* Size of the block requested from malloc or memalign. */
940 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
942 #define ABLOCK_ABASE(block) \
943 (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
944 ? (struct ablocks *)(block) \
947 /* Virtual `busy' field. */
948 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
950 /* Pointer to the (not necessarily aligned) malloc block. */
951 #ifdef HAVE_POSIX_MEMALIGN
952 #define ABLOCKS_BASE(abase) (abase)
954 #define ABLOCKS_BASE(abase) \
955 (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
958 /* The list of free ablock. */
959 static struct ablock
*free_ablock
;
961 /* Allocate an aligned block of nbytes.
962 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
963 smaller or equal to BLOCK_BYTES. */
964 static POINTER_TYPE
*
965 lisp_align_malloc (nbytes
, type
)
970 struct ablocks
*abase
;
972 eassert (nbytes
<= BLOCK_BYTES
);
976 #ifdef GC_MALLOC_CHECK
977 allocated_mem_type
= type
;
983 EMACS_INT aligned
; /* int gets warning casting to 64-bit pointer. */
985 #ifdef DOUG_LEA_MALLOC
986 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
987 because mapped region contents are not preserved in
989 mallopt (M_MMAP_MAX
, 0);
992 #ifdef HAVE_POSIX_MEMALIGN
994 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
1000 base
= malloc (ABLOCKS_BYTES
);
1001 abase
= ALIGN (base
, BLOCK_ALIGN
);
1010 aligned
= (base
== abase
);
1012 ((void**)abase
)[-1] = base
;
1014 #ifdef DOUG_LEA_MALLOC
1015 /* Back to a reasonable maximum of mmap'ed areas. */
1016 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1020 /* If the memory just allocated cannot be addressed thru a Lisp
1021 object's pointer, and it needs to be, that's equivalent to
1022 running out of memory. */
1023 if (type
!= MEM_TYPE_NON_LISP
)
1026 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1027 XSETCONS (tem
, end
);
1028 if ((char *) XCONS (tem
) != end
)
1030 lisp_malloc_loser
= base
;
1038 /* Initialize the blocks and put them on the free list.
1039 Is `base' was not properly aligned, we can't use the last block. */
1040 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1042 abase
->blocks
[i
].abase
= abase
;
1043 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1044 free_ablock
= &abase
->blocks
[i
];
1046 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (long) aligned
;
1048 eassert (0 == ((EMACS_UINT
)abase
) % BLOCK_ALIGN
);
1049 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1050 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1051 eassert (ABLOCKS_BASE (abase
) == base
);
1052 eassert (aligned
== (long) ABLOCKS_BUSY (abase
));
1055 abase
= ABLOCK_ABASE (free_ablock
);
1056 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (2 + (long) ABLOCKS_BUSY (abase
));
1058 free_ablock
= free_ablock
->x
.next_free
;
1060 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1061 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1062 mem_insert (val
, (char *) val
+ nbytes
, type
);
1069 eassert (0 == ((EMACS_UINT
)val
) % BLOCK_ALIGN
);
1074 lisp_align_free (block
)
1075 POINTER_TYPE
*block
;
1077 struct ablock
*ablock
= block
;
1078 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1081 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1082 mem_delete (mem_find (block
));
1084 /* Put on free list. */
1085 ablock
->x
.next_free
= free_ablock
;
1086 free_ablock
= ablock
;
1087 /* Update busy count. */
1088 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (-2 + (long) ABLOCKS_BUSY (abase
));
1090 if (2 > (long) ABLOCKS_BUSY (abase
))
1091 { /* All the blocks are free. */
1092 int i
= 0, aligned
= (long) ABLOCKS_BUSY (abase
);
1093 struct ablock
**tem
= &free_ablock
;
1094 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1098 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1101 *tem
= (*tem
)->x
.next_free
;
1104 tem
= &(*tem
)->x
.next_free
;
1106 eassert ((aligned
& 1) == aligned
);
1107 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1108 #ifdef HAVE_POSIX_MEMALIGN
1109 eassert ((unsigned long)ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1111 free (ABLOCKS_BASE (abase
));
1116 /* Return a new buffer structure allocated from the heap with
1117 a call to lisp_malloc. */
1123 = (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
1129 #ifndef SYSTEM_MALLOC
1131 /* Arranging to disable input signals while we're in malloc.
1133 This only works with GNU malloc. To help out systems which can't
1134 use GNU malloc, all the calls to malloc, realloc, and free
1135 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
1136 pair; unfortunately, we have no idea what C library functions
1137 might call malloc, so we can't really protect them unless you're
1138 using GNU malloc. Fortunately, most of the major operating systems
1139 can use GNU malloc. */
1143 #ifndef DOUG_LEA_MALLOC
1144 extern void * (*__malloc_hook
) P_ ((size_t, const void *));
1145 extern void * (*__realloc_hook
) P_ ((void *, size_t, const void *));
1146 extern void (*__free_hook
) P_ ((void *, const void *));
1147 /* Else declared in malloc.h, perhaps with an extra arg. */
1148 #endif /* DOUG_LEA_MALLOC */
1149 static void * (*old_malloc_hook
) P_ ((size_t, const void *));
1150 static void * (*old_realloc_hook
) P_ ((void *, size_t, const void*));
1151 static void (*old_free_hook
) P_ ((void*, const void*));
1153 /* This function is used as the hook for free to call. */
1156 emacs_blocked_free (ptr
, ptr2
)
1160 EMACS_INT bytes_used_now
;
1164 #ifdef GC_MALLOC_CHECK
1170 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1173 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
1178 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
1182 #endif /* GC_MALLOC_CHECK */
1184 __free_hook
= old_free_hook
;
1187 /* If we released our reserve (due to running out of memory),
1188 and we have a fair amount free once again,
1189 try to set aside another reserve in case we run out once more. */
1190 if (! NILP (Vmemory_full
)
1191 /* Verify there is enough space that even with the malloc
1192 hysteresis this call won't run out again.
1193 The code here is correct as long as SPARE_MEMORY
1194 is substantially larger than the block size malloc uses. */
1195 && (bytes_used_when_full
1196 > ((bytes_used_when_reconsidered
= BYTES_USED
)
1197 + max (malloc_hysteresis
, 4) * SPARE_MEMORY
)))
1198 refill_memory_reserve ();
1200 __free_hook
= emacs_blocked_free
;
1201 UNBLOCK_INPUT_ALLOC
;
1205 /* This function is the malloc hook that Emacs uses. */
1208 emacs_blocked_malloc (size
, ptr
)
1215 __malloc_hook
= old_malloc_hook
;
1216 #ifdef DOUG_LEA_MALLOC
1217 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
1219 __malloc_extra_blocks
= malloc_hysteresis
;
1222 value
= (void *) malloc (size
);
1224 #ifdef GC_MALLOC_CHECK
1226 struct mem_node
*m
= mem_find (value
);
1229 fprintf (stderr
, "Malloc returned %p which is already in use\n",
1231 fprintf (stderr
, "Region in use is %p...%p, %u bytes, type %d\n",
1232 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
1237 if (!dont_register_blocks
)
1239 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
1240 allocated_mem_type
= MEM_TYPE_NON_LISP
;
1243 #endif /* GC_MALLOC_CHECK */
1245 __malloc_hook
= emacs_blocked_malloc
;
1246 UNBLOCK_INPUT_ALLOC
;
1248 /* fprintf (stderr, "%p malloc\n", value); */
1253 /* This function is the realloc hook that Emacs uses. */
1256 emacs_blocked_realloc (ptr
, size
, ptr2
)
1264 __realloc_hook
= old_realloc_hook
;
1266 #ifdef GC_MALLOC_CHECK
1269 struct mem_node
*m
= mem_find (ptr
);
1270 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1273 "Realloc of %p which wasn't allocated with malloc\n",
1281 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1283 /* Prevent malloc from registering blocks. */
1284 dont_register_blocks
= 1;
1285 #endif /* GC_MALLOC_CHECK */
1287 value
= (void *) realloc (ptr
, size
);
1289 #ifdef GC_MALLOC_CHECK
1290 dont_register_blocks
= 0;
1293 struct mem_node
*m
= mem_find (value
);
1296 fprintf (stderr
, "Realloc returns memory that is already in use\n");
1300 /* Can't handle zero size regions in the red-black tree. */
1301 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
1304 /* fprintf (stderr, "%p <- realloc\n", value); */
1305 #endif /* GC_MALLOC_CHECK */
1307 __realloc_hook
= emacs_blocked_realloc
;
1308 UNBLOCK_INPUT_ALLOC
;
1314 #ifdef HAVE_GTK_AND_PTHREAD
1315 /* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
1316 normal malloc. Some thread implementations need this as they call
1317 malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
1318 calls malloc because it is the first call, and we have an endless loop. */
1321 reset_malloc_hooks ()
1327 #endif /* HAVE_GTK_AND_PTHREAD */
1330 /* Called from main to set up malloc to use our hooks. */
1333 uninterrupt_malloc ()
1335 #ifdef HAVE_GTK_AND_PTHREAD
1336 pthread_mutexattr_t attr
;
1338 /* GLIBC has a faster way to do this, but lets keep it portable.
1339 This is according to the Single UNIX Specification. */
1340 pthread_mutexattr_init (&attr
);
1341 pthread_mutexattr_settype (&attr
, PTHREAD_MUTEX_RECURSIVE
);
1342 pthread_mutex_init (&alloc_mutex
, &attr
);
1343 #endif /* HAVE_GTK_AND_PTHREAD */
1345 if (__free_hook
!= emacs_blocked_free
)
1346 old_free_hook
= __free_hook
;
1347 __free_hook
= emacs_blocked_free
;
1349 if (__malloc_hook
!= emacs_blocked_malloc
)
1350 old_malloc_hook
= __malloc_hook
;
1351 __malloc_hook
= emacs_blocked_malloc
;
1353 if (__realloc_hook
!= emacs_blocked_realloc
)
1354 old_realloc_hook
= __realloc_hook
;
1355 __realloc_hook
= emacs_blocked_realloc
;
1358 #endif /* not SYNC_INPUT */
1359 #endif /* not SYSTEM_MALLOC */
1363 /***********************************************************************
1365 ***********************************************************************/
1367 /* Number of intervals allocated in an interval_block structure.
1368 The 1020 is 1024 minus malloc overhead. */
1370 #define INTERVAL_BLOCK_SIZE \
1371 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1373 /* Intervals are allocated in chunks in form of an interval_block
1376 struct interval_block
1378 /* Place `intervals' first, to preserve alignment. */
1379 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1380 struct interval_block
*next
;
1383 /* Current interval block. Its `next' pointer points to older
1386 struct interval_block
*interval_block
;
1388 /* Index in interval_block above of the next unused interval
1391 static int interval_block_index
;
1393 /* Number of free and live intervals. */
1395 static int total_free_intervals
, total_intervals
;
1397 /* List of free intervals. */
1399 INTERVAL interval_free_list
;
1401 /* Total number of interval blocks now in use. */
1403 int n_interval_blocks
;
1406 /* Initialize interval allocation. */
1411 interval_block
= NULL
;
1412 interval_block_index
= INTERVAL_BLOCK_SIZE
;
1413 interval_free_list
= 0;
1414 n_interval_blocks
= 0;
1418 /* Return a new interval. */
1425 eassert (!handling_signal
);
1427 if (interval_free_list
)
1429 val
= interval_free_list
;
1430 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1434 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1436 register struct interval_block
*newi
;
1438 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
1441 newi
->next
= interval_block
;
1442 interval_block
= newi
;
1443 interval_block_index
= 0;
1444 n_interval_blocks
++;
1446 val
= &interval_block
->intervals
[interval_block_index
++];
1448 consing_since_gc
+= sizeof (struct interval
);
1450 RESET_INTERVAL (val
);
1456 /* Mark Lisp objects in interval I. */
1459 mark_interval (i
, dummy
)
1460 register INTERVAL i
;
1463 eassert (!i
->gcmarkbit
); /* Intervals are never shared. */
1465 mark_object (i
->plist
);
1469 /* Mark the interval tree rooted in TREE. Don't call this directly;
1470 use the macro MARK_INTERVAL_TREE instead. */
1473 mark_interval_tree (tree
)
1474 register INTERVAL tree
;
1476 /* No need to test if this tree has been marked already; this
1477 function is always called through the MARK_INTERVAL_TREE macro,
1478 which takes care of that. */
1480 traverse_intervals_noorder (tree
, mark_interval
, Qnil
);
1484 /* Mark the interval tree rooted in I. */
1486 #define MARK_INTERVAL_TREE(i) \
1488 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
1489 mark_interval_tree (i); \
1493 #define UNMARK_BALANCE_INTERVALS(i) \
1495 if (! NULL_INTERVAL_P (i)) \
1496 (i) = balance_intervals (i); \
1500 /* Number support. If NO_UNION_TYPE isn't in effect, we
1501 can't create number objects in macros. */
1509 obj
.s
.type
= Lisp_Int
;
1514 /***********************************************************************
1516 ***********************************************************************/
1518 /* Lisp_Strings are allocated in string_block structures. When a new
1519 string_block is allocated, all the Lisp_Strings it contains are
1520 added to a free-list string_free_list. When a new Lisp_String is
1521 needed, it is taken from that list. During the sweep phase of GC,
1522 string_blocks that are entirely free are freed, except two which
1525 String data is allocated from sblock structures. Strings larger
1526 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1527 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1529 Sblocks consist internally of sdata structures, one for each
1530 Lisp_String. The sdata structure points to the Lisp_String it
1531 belongs to. The Lisp_String points back to the `u.data' member of
1532 its sdata structure.
1534 When a Lisp_String is freed during GC, it is put back on
1535 string_free_list, and its `data' member and its sdata's `string'
1536 pointer is set to null. The size of the string is recorded in the
1537 `u.nbytes' member of the sdata. So, sdata structures that are no
1538 longer used, can be easily recognized, and it's easy to compact the
1539 sblocks of small strings which we do in compact_small_strings. */
1541 /* Size in bytes of an sblock structure used for small strings. This
1542 is 8192 minus malloc overhead. */
1544 #define SBLOCK_SIZE 8188
1546 /* Strings larger than this are considered large strings. String data
1547 for large strings is allocated from individual sblocks. */
1549 #define LARGE_STRING_BYTES 1024
1551 /* Structure describing string memory sub-allocated from an sblock.
1552 This is where the contents of Lisp strings are stored. */
1556 /* Back-pointer to the string this sdata belongs to. If null, this
1557 structure is free, and the NBYTES member of the union below
1558 contains the string's byte size (the same value that STRING_BYTES
1559 would return if STRING were non-null). If non-null, STRING_BYTES
1560 (STRING) is the size of the data, and DATA contains the string's
1562 struct Lisp_String
*string
;
1564 #ifdef GC_CHECK_STRING_BYTES
1567 unsigned char data
[1];
1569 #define SDATA_NBYTES(S) (S)->nbytes
1570 #define SDATA_DATA(S) (S)->data
1572 #else /* not GC_CHECK_STRING_BYTES */
1576 /* When STRING in non-null. */
1577 unsigned char data
[1];
1579 /* When STRING is null. */
1584 #define SDATA_NBYTES(S) (S)->u.nbytes
1585 #define SDATA_DATA(S) (S)->u.data
1587 #endif /* not GC_CHECK_STRING_BYTES */
1591 /* Structure describing a block of memory which is sub-allocated to
1592 obtain string data memory for strings. Blocks for small strings
1593 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1594 as large as needed. */
1599 struct sblock
*next
;
1601 /* Pointer to the next free sdata block. This points past the end
1602 of the sblock if there isn't any space left in this block. */
1603 struct sdata
*next_free
;
1605 /* Start of data. */
1606 struct sdata first_data
;
1609 /* Number of Lisp strings in a string_block structure. The 1020 is
1610 1024 minus malloc overhead. */
1612 #define STRING_BLOCK_SIZE \
1613 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1615 /* Structure describing a block from which Lisp_String structures
1620 /* Place `strings' first, to preserve alignment. */
1621 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1622 struct string_block
*next
;
1625 /* Head and tail of the list of sblock structures holding Lisp string
1626 data. We always allocate from current_sblock. The NEXT pointers
1627 in the sblock structures go from oldest_sblock to current_sblock. */
1629 static struct sblock
*oldest_sblock
, *current_sblock
;
1631 /* List of sblocks for large strings. */
1633 static struct sblock
*large_sblocks
;
1635 /* List of string_block structures, and how many there are. */
1637 static struct string_block
*string_blocks
;
1638 static int n_string_blocks
;
1640 /* Free-list of Lisp_Strings. */
1642 static struct Lisp_String
*string_free_list
;
1644 /* Number of live and free Lisp_Strings. */
1646 static int total_strings
, total_free_strings
;
1648 /* Number of bytes used by live strings. */
1650 static int total_string_size
;
1652 /* Given a pointer to a Lisp_String S which is on the free-list
1653 string_free_list, return a pointer to its successor in the
1656 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1658 /* Return a pointer to the sdata structure belonging to Lisp string S.
1659 S must be live, i.e. S->data must not be null. S->data is actually
1660 a pointer to the `u.data' member of its sdata structure; the
1661 structure starts at a constant offset in front of that. */
1663 #ifdef GC_CHECK_STRING_BYTES
1665 #define SDATA_OF_STRING(S) \
1666 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
1667 - sizeof (EMACS_INT)))
1669 #else /* not GC_CHECK_STRING_BYTES */
1671 #define SDATA_OF_STRING(S) \
1672 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
1674 #endif /* not GC_CHECK_STRING_BYTES */
1677 #ifdef GC_CHECK_STRING_OVERRUN
1679 /* We check for overrun in string data blocks by appending a small
1680 "cookie" after each allocated string data block, and check for the
1681 presence of this cookie during GC. */
1683 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1684 static char string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1685 { 0xde, 0xad, 0xbe, 0xef };
1688 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1691 /* Value is the size of an sdata structure large enough to hold NBYTES
1692 bytes of string data. The value returned includes a terminating
1693 NUL byte, the size of the sdata structure, and padding. */
1695 #ifdef GC_CHECK_STRING_BYTES
1697 #define SDATA_SIZE(NBYTES) \
1698 ((sizeof (struct Lisp_String *) \
1700 + sizeof (EMACS_INT) \
1701 + sizeof (EMACS_INT) - 1) \
1702 & ~(sizeof (EMACS_INT) - 1))
1704 #else /* not GC_CHECK_STRING_BYTES */
1706 #define SDATA_SIZE(NBYTES) \
1707 ((sizeof (struct Lisp_String *) \
1709 + sizeof (EMACS_INT) - 1) \
1710 & ~(sizeof (EMACS_INT) - 1))
1712 #endif /* not GC_CHECK_STRING_BYTES */
1714 /* Extra bytes to allocate for each string. */
1716 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1718 /* Initialize string allocation. Called from init_alloc_once. */
1723 total_strings
= total_free_strings
= total_string_size
= 0;
1724 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1725 string_blocks
= NULL
;
1726 n_string_blocks
= 0;
1727 string_free_list
= NULL
;
1731 #ifdef GC_CHECK_STRING_BYTES
1733 static int check_string_bytes_count
;
1735 void check_string_bytes
P_ ((int));
1736 void check_sblock
P_ ((struct sblock
*));
1738 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1741 /* Like GC_STRING_BYTES, but with debugging check. */
1745 struct Lisp_String
*s
;
1747 int nbytes
= (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1748 if (!PURE_POINTER_P (s
)
1750 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1755 /* Check validity of Lisp strings' string_bytes member in B. */
1761 struct sdata
*from
, *end
, *from_end
;
1765 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1767 /* Compute the next FROM here because copying below may
1768 overwrite data we need to compute it. */
1771 /* Check that the string size recorded in the string is the
1772 same as the one recorded in the sdata structure. */
1774 CHECK_STRING_BYTES (from
->string
);
1777 nbytes
= GC_STRING_BYTES (from
->string
);
1779 nbytes
= SDATA_NBYTES (from
);
1781 nbytes
= SDATA_SIZE (nbytes
);
1782 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1787 /* Check validity of Lisp strings' string_bytes member. ALL_P
1788 non-zero means check all strings, otherwise check only most
1789 recently allocated strings. Used for hunting a bug. */
1792 check_string_bytes (all_p
)
1799 for (b
= large_sblocks
; b
; b
= b
->next
)
1801 struct Lisp_String
*s
= b
->first_data
.string
;
1803 CHECK_STRING_BYTES (s
);
1806 for (b
= oldest_sblock
; b
; b
= b
->next
)
1810 check_sblock (current_sblock
);
1813 #endif /* GC_CHECK_STRING_BYTES */
1815 #ifdef GC_CHECK_STRING_FREE_LIST
1817 /* Walk through the string free list looking for bogus next pointers.
1818 This may catch buffer overrun from a previous string. */
1821 check_string_free_list ()
1823 struct Lisp_String
*s
;
1825 /* Pop a Lisp_String off the free-list. */
1826 s
= string_free_list
;
1829 if ((unsigned)s
< 1024)
1831 s
= NEXT_FREE_LISP_STRING (s
);
1835 #define check_string_free_list()
1838 /* Return a new Lisp_String. */
1840 static struct Lisp_String
*
1843 struct Lisp_String
*s
;
1845 eassert (!handling_signal
);
1847 /* If the free-list is empty, allocate a new string_block, and
1848 add all the Lisp_Strings in it to the free-list. */
1849 if (string_free_list
== NULL
)
1851 struct string_block
*b
;
1854 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1855 bzero (b
, sizeof *b
);
1856 b
->next
= string_blocks
;
1860 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1863 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1864 string_free_list
= s
;
1867 total_free_strings
+= STRING_BLOCK_SIZE
;
1870 check_string_free_list ();
1872 /* Pop a Lisp_String off the free-list. */
1873 s
= string_free_list
;
1874 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1876 /* Probably not strictly necessary, but play it safe. */
1877 bzero (s
, sizeof *s
);
1879 --total_free_strings
;
1882 consing_since_gc
+= sizeof *s
;
1884 #ifdef GC_CHECK_STRING_BYTES
1891 if (++check_string_bytes_count
== 200)
1893 check_string_bytes_count
= 0;
1894 check_string_bytes (1);
1897 check_string_bytes (0);
1899 #endif /* GC_CHECK_STRING_BYTES */
1905 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1906 plus a NUL byte at the end. Allocate an sdata structure for S, and
1907 set S->data to its `u.data' member. Store a NUL byte at the end of
1908 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1909 S->data if it was initially non-null. */
1912 allocate_string_data (s
, nchars
, nbytes
)
1913 struct Lisp_String
*s
;
1916 struct sdata
*data
, *old_data
;
1918 int needed
, old_nbytes
;
1920 /* Determine the number of bytes needed to store NBYTES bytes
1922 needed
= SDATA_SIZE (nbytes
);
1924 if (nbytes
> LARGE_STRING_BYTES
)
1926 size_t size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1928 #ifdef DOUG_LEA_MALLOC
1929 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1930 because mapped region contents are not preserved in
1933 In case you think of allowing it in a dumped Emacs at the
1934 cost of not being able to re-dump, there's another reason:
1935 mmap'ed data typically have an address towards the top of the
1936 address space, which won't fit into an EMACS_INT (at least on
1937 32-bit systems with the current tagging scheme). --fx */
1939 mallopt (M_MMAP_MAX
, 0);
1943 b
= (struct sblock
*) lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1945 #ifdef DOUG_LEA_MALLOC
1946 /* Back to a reasonable maximum of mmap'ed areas. */
1948 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1952 b
->next_free
= &b
->first_data
;
1953 b
->first_data
.string
= NULL
;
1954 b
->next
= large_sblocks
;
1957 else if (current_sblock
== NULL
1958 || (((char *) current_sblock
+ SBLOCK_SIZE
1959 - (char *) current_sblock
->next_free
)
1960 < (needed
+ GC_STRING_EXTRA
)))
1962 /* Not enough room in the current sblock. */
1963 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1964 b
->next_free
= &b
->first_data
;
1965 b
->first_data
.string
= NULL
;
1969 current_sblock
->next
= b
;
1977 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
1978 old_nbytes
= GC_STRING_BYTES (s
);
1980 data
= b
->next_free
;
1982 s
->data
= SDATA_DATA (data
);
1983 #ifdef GC_CHECK_STRING_BYTES
1984 SDATA_NBYTES (data
) = nbytes
;
1987 s
->size_byte
= nbytes
;
1988 s
->data
[nbytes
] = '\0';
1989 #ifdef GC_CHECK_STRING_OVERRUN
1990 bcopy (string_overrun_cookie
, (char *) data
+ needed
,
1991 GC_STRING_OVERRUN_COOKIE_SIZE
);
1993 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1995 /* If S had already data assigned, mark that as free by setting its
1996 string back-pointer to null, and recording the size of the data
2000 SDATA_NBYTES (old_data
) = old_nbytes
;
2001 old_data
->string
= NULL
;
2004 consing_since_gc
+= needed
;
2008 /* Sweep and compact strings. */
2013 struct string_block
*b
, *next
;
2014 struct string_block
*live_blocks
= NULL
;
2016 string_free_list
= NULL
;
2017 total_strings
= total_free_strings
= 0;
2018 total_string_size
= 0;
2020 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2021 for (b
= string_blocks
; b
; b
= next
)
2024 struct Lisp_String
*free_list_before
= string_free_list
;
2028 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
2030 struct Lisp_String
*s
= b
->strings
+ i
;
2034 /* String was not on free-list before. */
2035 if (STRING_MARKED_P (s
))
2037 /* String is live; unmark it and its intervals. */
2040 if (!NULL_INTERVAL_P (s
->intervals
))
2041 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2044 total_string_size
+= STRING_BYTES (s
);
2048 /* String is dead. Put it on the free-list. */
2049 struct sdata
*data
= SDATA_OF_STRING (s
);
2051 /* Save the size of S in its sdata so that we know
2052 how large that is. Reset the sdata's string
2053 back-pointer so that we know it's free. */
2054 #ifdef GC_CHECK_STRING_BYTES
2055 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
2058 data
->u
.nbytes
= GC_STRING_BYTES (s
);
2060 data
->string
= NULL
;
2062 /* Reset the strings's `data' member so that we
2066 /* Put the string on the free-list. */
2067 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2068 string_free_list
= s
;
2074 /* S was on the free-list before. Put it there again. */
2075 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2076 string_free_list
= s
;
2081 /* Free blocks that contain free Lisp_Strings only, except
2082 the first two of them. */
2083 if (nfree
== STRING_BLOCK_SIZE
2084 && total_free_strings
> STRING_BLOCK_SIZE
)
2088 string_free_list
= free_list_before
;
2092 total_free_strings
+= nfree
;
2093 b
->next
= live_blocks
;
2098 check_string_free_list ();
2100 string_blocks
= live_blocks
;
2101 free_large_strings ();
2102 compact_small_strings ();
2104 check_string_free_list ();
2108 /* Free dead large strings. */
2111 free_large_strings ()
2113 struct sblock
*b
, *next
;
2114 struct sblock
*live_blocks
= NULL
;
2116 for (b
= large_sblocks
; b
; b
= next
)
2120 if (b
->first_data
.string
== NULL
)
2124 b
->next
= live_blocks
;
2129 large_sblocks
= live_blocks
;
2133 /* Compact data of small strings. Free sblocks that don't contain
2134 data of live strings after compaction. */
2137 compact_small_strings ()
2139 struct sblock
*b
, *tb
, *next
;
2140 struct sdata
*from
, *to
, *end
, *tb_end
;
2141 struct sdata
*to_end
, *from_end
;
2143 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2144 to, and TB_END is the end of TB. */
2146 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2147 to
= &tb
->first_data
;
2149 /* Step through the blocks from the oldest to the youngest. We
2150 expect that old blocks will stabilize over time, so that less
2151 copying will happen this way. */
2152 for (b
= oldest_sblock
; b
; b
= b
->next
)
2155 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2157 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
2159 /* Compute the next FROM here because copying below may
2160 overwrite data we need to compute it. */
2163 #ifdef GC_CHECK_STRING_BYTES
2164 /* Check that the string size recorded in the string is the
2165 same as the one recorded in the sdata structure. */
2167 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
2169 #endif /* GC_CHECK_STRING_BYTES */
2172 nbytes
= GC_STRING_BYTES (from
->string
);
2174 nbytes
= SDATA_NBYTES (from
);
2176 if (nbytes
> LARGE_STRING_BYTES
)
2179 nbytes
= SDATA_SIZE (nbytes
);
2180 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
2182 #ifdef GC_CHECK_STRING_OVERRUN
2183 if (bcmp (string_overrun_cookie
,
2184 ((char *) from_end
) - GC_STRING_OVERRUN_COOKIE_SIZE
,
2185 GC_STRING_OVERRUN_COOKIE_SIZE
))
2189 /* FROM->string non-null means it's alive. Copy its data. */
2192 /* If TB is full, proceed with the next sblock. */
2193 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2194 if (to_end
> tb_end
)
2198 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2199 to
= &tb
->first_data
;
2200 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2203 /* Copy, and update the string's `data' pointer. */
2206 xassert (tb
!= b
|| to
<= from
);
2207 safe_bcopy ((char *) from
, (char *) to
, nbytes
+ GC_STRING_EXTRA
);
2208 to
->string
->data
= SDATA_DATA (to
);
2211 /* Advance past the sdata we copied to. */
2217 /* The rest of the sblocks following TB don't contain live data, so
2218 we can free them. */
2219 for (b
= tb
->next
; b
; b
= next
)
2227 current_sblock
= tb
;
2231 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2232 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2233 LENGTH must be an integer.
2234 INIT must be an integer that represents a character. */)
2236 Lisp_Object length
, init
;
2238 register Lisp_Object val
;
2239 register unsigned char *p
, *end
;
2242 CHECK_NATNUM (length
);
2243 CHECK_NUMBER (init
);
2246 if (SINGLE_BYTE_CHAR_P (c
))
2248 nbytes
= XINT (length
);
2249 val
= make_uninit_string (nbytes
);
2251 end
= p
+ SCHARS (val
);
2257 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2258 int len
= CHAR_STRING (c
, str
);
2260 nbytes
= len
* XINT (length
);
2261 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
2266 bcopy (str
, p
, len
);
2276 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2277 doc
: /* Return a new bool-vector of length LENGTH, using INIT for as each element.
2278 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2280 Lisp_Object length
, init
;
2282 register Lisp_Object val
;
2283 struct Lisp_Bool_Vector
*p
;
2285 int length_in_chars
, length_in_elts
, bits_per_value
;
2287 CHECK_NATNUM (length
);
2289 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2291 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2292 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2293 / BOOL_VECTOR_BITS_PER_CHAR
);
2295 /* We must allocate one more elements than LENGTH_IN_ELTS for the
2296 slot `size' of the struct Lisp_Bool_Vector. */
2297 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
2298 p
= XBOOL_VECTOR (val
);
2300 /* Get rid of any bits that would cause confusion. */
2302 XSETBOOL_VECTOR (val
, p
);
2303 p
->size
= XFASTINT (length
);
2305 real_init
= (NILP (init
) ? 0 : -1);
2306 for (i
= 0; i
< length_in_chars
; i
++)
2307 p
->data
[i
] = real_init
;
2309 /* Clear the extraneous bits in the last byte. */
2310 if (XINT (length
) != length_in_chars
* BOOL_VECTOR_BITS_PER_CHAR
)
2311 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
2312 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2318 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2319 of characters from the contents. This string may be unibyte or
2320 multibyte, depending on the contents. */
2323 make_string (contents
, nbytes
)
2324 const char *contents
;
2327 register Lisp_Object val
;
2328 int nchars
, multibyte_nbytes
;
2330 parse_str_as_multibyte (contents
, nbytes
, &nchars
, &multibyte_nbytes
);
2331 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2332 /* CONTENTS contains no multibyte sequences or contains an invalid
2333 multibyte sequence. We must make unibyte string. */
2334 val
= make_unibyte_string (contents
, nbytes
);
2336 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2341 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2344 make_unibyte_string (contents
, length
)
2345 const char *contents
;
2348 register Lisp_Object val
;
2349 val
= make_uninit_string (length
);
2350 bcopy (contents
, SDATA (val
), length
);
2351 STRING_SET_UNIBYTE (val
);
2356 /* Make a multibyte string from NCHARS characters occupying NBYTES
2357 bytes at CONTENTS. */
2360 make_multibyte_string (contents
, nchars
, nbytes
)
2361 const char *contents
;
2364 register Lisp_Object val
;
2365 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2366 bcopy (contents
, SDATA (val
), nbytes
);
2371 /* Make a string from NCHARS characters occupying NBYTES bytes at
2372 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2375 make_string_from_bytes (contents
, nchars
, nbytes
)
2376 const char *contents
;
2379 register Lisp_Object val
;
2380 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2381 bcopy (contents
, SDATA (val
), nbytes
);
2382 if (SBYTES (val
) == SCHARS (val
))
2383 STRING_SET_UNIBYTE (val
);
2388 /* Make a string from NCHARS characters occupying NBYTES bytes at
2389 CONTENTS. The argument MULTIBYTE controls whether to label the
2390 string as multibyte. If NCHARS is negative, it counts the number of
2391 characters by itself. */
2394 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
2395 const char *contents
;
2399 register Lisp_Object val
;
2404 nchars
= multibyte_chars_in_text (contents
, nbytes
);
2408 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2409 bcopy (contents
, SDATA (val
), nbytes
);
2411 STRING_SET_UNIBYTE (val
);
2416 /* Make a string from the data at STR, treating it as multibyte if the
2423 return make_string (str
, strlen (str
));
2427 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2428 occupying LENGTH bytes. */
2431 make_uninit_string (length
)
2435 val
= make_uninit_multibyte_string (length
, length
);
2436 STRING_SET_UNIBYTE (val
);
2441 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2442 which occupy NBYTES bytes. */
2445 make_uninit_multibyte_string (nchars
, nbytes
)
2449 struct Lisp_String
*s
;
2454 s
= allocate_string ();
2455 allocate_string_data (s
, nchars
, nbytes
);
2456 XSETSTRING (string
, s
);
2457 string_chars_consed
+= nbytes
;
2463 /***********************************************************************
2465 ***********************************************************************/
2467 /* We store float cells inside of float_blocks, allocating a new
2468 float_block with malloc whenever necessary. Float cells reclaimed
2469 by GC are put on a free list to be reallocated before allocating
2470 any new float cells from the latest float_block. */
2472 #define FLOAT_BLOCK_SIZE \
2473 (((BLOCK_BYTES - sizeof (struct float_block *) \
2474 /* The compiler might add padding at the end. */ \
2475 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2476 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2478 #define GETMARKBIT(block,n) \
2479 (((block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2480 >> ((n) % (sizeof(int) * CHAR_BIT))) \
2483 #define SETMARKBIT(block,n) \
2484 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2485 |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
2487 #define UNSETMARKBIT(block,n) \
2488 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2489 &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
2491 #define FLOAT_BLOCK(fptr) \
2492 ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2494 #define FLOAT_INDEX(fptr) \
2495 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2499 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2500 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2501 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2502 struct float_block
*next
;
2505 #define FLOAT_MARKED_P(fptr) \
2506 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2508 #define FLOAT_MARK(fptr) \
2509 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2511 #define FLOAT_UNMARK(fptr) \
2512 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2514 /* Current float_block. */
2516 struct float_block
*float_block
;
2518 /* Index of first unused Lisp_Float in the current float_block. */
2520 int float_block_index
;
2522 /* Total number of float blocks now in use. */
2526 /* Free-list of Lisp_Floats. */
2528 struct Lisp_Float
*float_free_list
;
2531 /* Initialize float allocation. */
2537 float_block_index
= FLOAT_BLOCK_SIZE
; /* Force alloc of new float_block. */
2538 float_free_list
= 0;
2543 /* Explicitly free a float cell by putting it on the free-list. */
2547 struct Lisp_Float
*ptr
;
2549 ptr
->u
.chain
= float_free_list
;
2550 float_free_list
= ptr
;
2554 /* Return a new float object with value FLOAT_VALUE. */
2557 make_float (float_value
)
2560 register Lisp_Object val
;
2562 eassert (!handling_signal
);
2564 if (float_free_list
)
2566 /* We use the data field for chaining the free list
2567 so that we won't use the same field that has the mark bit. */
2568 XSETFLOAT (val
, float_free_list
);
2569 float_free_list
= float_free_list
->u
.chain
;
2573 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2575 register struct float_block
*new;
2577 new = (struct float_block
*) lisp_align_malloc (sizeof *new,
2579 new->next
= float_block
;
2580 bzero ((char *) new->gcmarkbits
, sizeof new->gcmarkbits
);
2582 float_block_index
= 0;
2585 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2586 float_block_index
++;
2589 XFLOAT_DATA (val
) = float_value
;
2590 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2591 consing_since_gc
+= sizeof (struct Lisp_Float
);
2598 /***********************************************************************
2600 ***********************************************************************/
2602 /* We store cons cells inside of cons_blocks, allocating a new
2603 cons_block with malloc whenever necessary. Cons cells reclaimed by
2604 GC are put on a free list to be reallocated before allocating
2605 any new cons cells from the latest cons_block. */
2607 #define CONS_BLOCK_SIZE \
2608 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2609 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2611 #define CONS_BLOCK(fptr) \
2612 ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2614 #define CONS_INDEX(fptr) \
2615 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2619 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2620 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2621 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2622 struct cons_block
*next
;
2625 #define CONS_MARKED_P(fptr) \
2626 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2628 #define CONS_MARK(fptr) \
2629 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2631 #define CONS_UNMARK(fptr) \
2632 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2634 /* Current cons_block. */
2636 struct cons_block
*cons_block
;
2638 /* Index of first unused Lisp_Cons in the current block. */
2640 int cons_block_index
;
2642 /* Free-list of Lisp_Cons structures. */
2644 struct Lisp_Cons
*cons_free_list
;
2646 /* Total number of cons blocks now in use. */
2651 /* Initialize cons allocation. */
2657 cons_block_index
= CONS_BLOCK_SIZE
; /* Force alloc of new cons_block. */
2663 /* Explicitly free a cons cell by putting it on the free-list. */
2667 struct Lisp_Cons
*ptr
;
2669 ptr
->u
.chain
= cons_free_list
;
2673 cons_free_list
= ptr
;
2676 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2677 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2679 Lisp_Object car
, cdr
;
2681 register Lisp_Object val
;
2683 eassert (!handling_signal
);
2687 /* We use the cdr for chaining the free list
2688 so that we won't use the same field that has the mark bit. */
2689 XSETCONS (val
, cons_free_list
);
2690 cons_free_list
= cons_free_list
->u
.chain
;
2694 if (cons_block_index
== CONS_BLOCK_SIZE
)
2696 register struct cons_block
*new;
2697 new = (struct cons_block
*) lisp_align_malloc (sizeof *new,
2699 bzero ((char *) new->gcmarkbits
, sizeof new->gcmarkbits
);
2700 new->next
= cons_block
;
2702 cons_block_index
= 0;
2705 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2711 eassert (!CONS_MARKED_P (XCONS (val
)));
2712 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2713 cons_cells_consed
++;
2717 /* Get an error now if there's any junk in the cons free list. */
2721 #ifdef GC_CHECK_CONS_LIST
2722 struct Lisp_Cons
*tail
= cons_free_list
;
2725 tail
= tail
->u
.chain
;
2729 /* Make a list of 2, 3, 4 or 5 specified objects. */
2733 Lisp_Object arg1
, arg2
;
2735 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2740 list3 (arg1
, arg2
, arg3
)
2741 Lisp_Object arg1
, arg2
, arg3
;
2743 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2748 list4 (arg1
, arg2
, arg3
, arg4
)
2749 Lisp_Object arg1
, arg2
, arg3
, arg4
;
2751 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2756 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
2757 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
2759 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2760 Fcons (arg5
, Qnil
)))));
2764 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2765 doc
: /* Return a newly created list with specified arguments as elements.
2766 Any number of arguments, even zero arguments, are allowed.
2767 usage: (list &rest OBJECTS) */)
2770 register Lisp_Object
*args
;
2772 register Lisp_Object val
;
2778 val
= Fcons (args
[nargs
], val
);
2784 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2785 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2787 register Lisp_Object length
, init
;
2789 register Lisp_Object val
;
2792 CHECK_NATNUM (length
);
2793 size
= XFASTINT (length
);
2798 val
= Fcons (init
, val
);
2803 val
= Fcons (init
, val
);
2808 val
= Fcons (init
, val
);
2813 val
= Fcons (init
, val
);
2818 val
= Fcons (init
, val
);
2833 /***********************************************************************
2835 ***********************************************************************/
2837 /* Singly-linked list of all vectors. */
2839 struct Lisp_Vector
*all_vectors
;
2841 /* Total number of vector-like objects now in use. */
2846 /* Value is a pointer to a newly allocated Lisp_Vector structure
2847 with room for LEN Lisp_Objects. */
2849 static struct Lisp_Vector
*
2850 allocate_vectorlike (len
, type
)
2854 struct Lisp_Vector
*p
;
2857 #ifdef DOUG_LEA_MALLOC
2858 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2859 because mapped region contents are not preserved in
2862 mallopt (M_MMAP_MAX
, 0);
2866 /* This gets triggered by code which I haven't bothered to fix. --Stef */
2867 /* eassert (!handling_signal); */
2869 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
2870 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, type
);
2872 #ifdef DOUG_LEA_MALLOC
2873 /* Back to a reasonable maximum of mmap'ed areas. */
2875 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2879 consing_since_gc
+= nbytes
;
2880 vector_cells_consed
+= len
;
2882 p
->next
= all_vectors
;
2889 /* Allocate a vector with NSLOTS slots. */
2891 struct Lisp_Vector
*
2892 allocate_vector (nslots
)
2895 struct Lisp_Vector
*v
= allocate_vectorlike (nslots
, MEM_TYPE_VECTOR
);
2901 /* Allocate other vector-like structures. */
2903 struct Lisp_Hash_Table
*
2904 allocate_hash_table ()
2906 EMACS_INT len
= VECSIZE (struct Lisp_Hash_Table
);
2907 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_HASH_TABLE
);
2911 for (i
= 0; i
< len
; ++i
)
2912 v
->contents
[i
] = Qnil
;
2914 return (struct Lisp_Hash_Table
*) v
;
2921 EMACS_INT len
= VECSIZE (struct window
);
2922 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_WINDOW
);
2925 for (i
= 0; i
< len
; ++i
)
2926 v
->contents
[i
] = Qnil
;
2929 return (struct window
*) v
;
2936 EMACS_INT len
= VECSIZE (struct frame
);
2937 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_FRAME
);
2940 for (i
= 0; i
< len
; ++i
)
2941 v
->contents
[i
] = make_number (0);
2943 return (struct frame
*) v
;
2947 struct Lisp_Process
*
2950 EMACS_INT len
= VECSIZE (struct Lisp_Process
);
2951 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_PROCESS
);
2954 for (i
= 0; i
< len
; ++i
)
2955 v
->contents
[i
] = Qnil
;
2958 return (struct Lisp_Process
*) v
;
2962 struct Lisp_Vector
*
2963 allocate_other_vector (len
)
2966 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_VECTOR
);
2969 for (i
= 0; i
< len
; ++i
)
2970 v
->contents
[i
] = Qnil
;
2977 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
2978 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
2979 See also the function `vector'. */)
2981 register Lisp_Object length
, init
;
2984 register EMACS_INT sizei
;
2986 register struct Lisp_Vector
*p
;
2988 CHECK_NATNUM (length
);
2989 sizei
= XFASTINT (length
);
2991 p
= allocate_vector (sizei
);
2992 for (index
= 0; index
< sizei
; index
++)
2993 p
->contents
[index
] = init
;
2995 XSETVECTOR (vector
, p
);
3000 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
3001 doc
: /* Return a newly created char-table, with purpose PURPOSE.
3002 Each element is initialized to INIT, which defaults to nil.
3003 PURPOSE should be a symbol which has a `char-table-extra-slots' property.
3004 The property's value should be an integer between 0 and 10. */)
3006 register Lisp_Object purpose
, init
;
3010 CHECK_SYMBOL (purpose
);
3011 n
= Fget (purpose
, Qchar_table_extra_slots
);
3013 if (XINT (n
) < 0 || XINT (n
) > 10)
3014 args_out_of_range (n
, Qnil
);
3015 /* Add 2 to the size for the defalt and parent slots. */
3016 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
3018 XCHAR_TABLE (vector
)->top
= Qt
;
3019 XCHAR_TABLE (vector
)->parent
= Qnil
;
3020 XCHAR_TABLE (vector
)->purpose
= purpose
;
3021 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
3026 /* Return a newly created sub char table with slots initialized by INIT.
3027 Since a sub char table does not appear as a top level Emacs Lisp
3028 object, we don't need a Lisp interface to make it. */
3031 make_sub_char_table (init
)
3035 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), init
);
3036 XCHAR_TABLE (vector
)->top
= Qnil
;
3037 XCHAR_TABLE (vector
)->defalt
= Qnil
;
3038 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
3043 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3044 doc
: /* Return a newly created vector with specified arguments as elements.
3045 Any number of arguments, even zero arguments, are allowed.
3046 usage: (vector &rest OBJECTS) */)
3051 register Lisp_Object len
, val
;
3053 register struct Lisp_Vector
*p
;
3055 XSETFASTINT (len
, nargs
);
3056 val
= Fmake_vector (len
, Qnil
);
3058 for (index
= 0; index
< nargs
; index
++)
3059 p
->contents
[index
] = args
[index
];
3064 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3065 doc
: /* Create a byte-code object with specified arguments as elements.
3066 The arguments should be the arglist, bytecode-string, constant vector,
3067 stack size, (optional) doc string, and (optional) interactive spec.
3068 The first four arguments are required; at most six have any
3070 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3075 register Lisp_Object len
, val
;
3077 register struct Lisp_Vector
*p
;
3079 XSETFASTINT (len
, nargs
);
3080 if (!NILP (Vpurify_flag
))
3081 val
= make_pure_vector ((EMACS_INT
) nargs
);
3083 val
= Fmake_vector (len
, Qnil
);
3085 if (STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
3086 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3087 earlier because they produced a raw 8-bit string for byte-code
3088 and now such a byte-code string is loaded as multibyte while
3089 raw 8-bit characters converted to multibyte form. Thus, now we
3090 must convert them back to the original unibyte form. */
3091 args
[1] = Fstring_as_unibyte (args
[1]);
3094 for (index
= 0; index
< nargs
; index
++)
3096 if (!NILP (Vpurify_flag
))
3097 args
[index
] = Fpurecopy (args
[index
]);
3098 p
->contents
[index
] = args
[index
];
3100 XSETCOMPILED (val
, p
);
3106 /***********************************************************************
3108 ***********************************************************************/
3110 /* Each symbol_block is just under 1020 bytes long, since malloc
3111 really allocates in units of powers of two and uses 4 bytes for its
3114 #define SYMBOL_BLOCK_SIZE \
3115 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
3119 /* Place `symbols' first, to preserve alignment. */
3120 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3121 struct symbol_block
*next
;
3124 /* Current symbol block and index of first unused Lisp_Symbol
3127 struct symbol_block
*symbol_block
;
3128 int symbol_block_index
;
3130 /* List of free symbols. */
3132 struct Lisp_Symbol
*symbol_free_list
;
3134 /* Total number of symbol blocks now in use. */
3136 int n_symbol_blocks
;
3139 /* Initialize symbol allocation. */
3144 symbol_block
= NULL
;
3145 symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3146 symbol_free_list
= 0;
3147 n_symbol_blocks
= 0;
3151 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3152 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3153 Its value and function definition are void, and its property list is nil. */)
3157 register Lisp_Object val
;
3158 register struct Lisp_Symbol
*p
;
3160 CHECK_STRING (name
);
3162 eassert (!handling_signal
);
3164 if (symbol_free_list
)
3166 XSETSYMBOL (val
, symbol_free_list
);
3167 symbol_free_list
= symbol_free_list
->next
;
3171 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3173 struct symbol_block
*new;
3174 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
3176 new->next
= symbol_block
;
3178 symbol_block_index
= 0;
3181 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
]);
3182 symbol_block_index
++;
3188 p
->value
= Qunbound
;
3189 p
->function
= Qunbound
;
3192 p
->interned
= SYMBOL_UNINTERNED
;
3194 p
->indirect_variable
= 0;
3195 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3202 /***********************************************************************
3203 Marker (Misc) Allocation
3204 ***********************************************************************/
3206 /* Allocation of markers and other objects that share that structure.
3207 Works like allocation of conses. */
3209 #define MARKER_BLOCK_SIZE \
3210 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
3214 /* Place `markers' first, to preserve alignment. */
3215 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3216 struct marker_block
*next
;
3219 struct marker_block
*marker_block
;
3220 int marker_block_index
;
3222 union Lisp_Misc
*marker_free_list
;
3224 /* Total number of marker blocks now in use. */
3226 int n_marker_blocks
;
3231 marker_block
= NULL
;
3232 marker_block_index
= MARKER_BLOCK_SIZE
;
3233 marker_free_list
= 0;
3234 n_marker_blocks
= 0;
3237 /* Return a newly allocated Lisp_Misc object, with no substructure. */
3244 eassert (!handling_signal
);
3246 if (marker_free_list
)
3248 XSETMISC (val
, marker_free_list
);
3249 marker_free_list
= marker_free_list
->u_free
.chain
;
3253 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3255 struct marker_block
*new;
3256 new = (struct marker_block
*) lisp_malloc (sizeof *new,
3258 new->next
= marker_block
;
3260 marker_block_index
= 0;
3262 total_free_markers
+= MARKER_BLOCK_SIZE
;
3264 XSETMISC (val
, &marker_block
->markers
[marker_block_index
]);
3265 marker_block_index
++;
3268 --total_free_markers
;
3269 consing_since_gc
+= sizeof (union Lisp_Misc
);
3270 misc_objects_consed
++;
3271 XMARKER (val
)->gcmarkbit
= 0;
3275 /* Free a Lisp_Misc object */
3281 XMISC (misc
)->u_marker
.type
= Lisp_Misc_Free
;
3282 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3283 marker_free_list
= XMISC (misc
);
3285 total_free_markers
++;
3288 /* Return a Lisp_Misc_Save_Value object containing POINTER and
3289 INTEGER. This is used to package C values to call record_unwind_protect.
3290 The unwind function can get the C values back using XSAVE_VALUE. */
3293 make_save_value (pointer
, integer
)
3297 register Lisp_Object val
;
3298 register struct Lisp_Save_Value
*p
;
3300 val
= allocate_misc ();
3301 XMISCTYPE (val
) = Lisp_Misc_Save_Value
;
3302 p
= XSAVE_VALUE (val
);
3303 p
->pointer
= pointer
;
3304 p
->integer
= integer
;
3309 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3310 doc
: /* Return a newly allocated marker which does not point at any place. */)
3313 register Lisp_Object val
;
3314 register struct Lisp_Marker
*p
;
3316 val
= allocate_misc ();
3317 XMISCTYPE (val
) = Lisp_Misc_Marker
;
3323 p
->insertion_type
= 0;
3327 /* Put MARKER back on the free list after using it temporarily. */
3330 free_marker (marker
)
3333 unchain_marker (XMARKER (marker
));
3338 /* Return a newly created vector or string with specified arguments as
3339 elements. If all the arguments are characters that can fit
3340 in a string of events, make a string; otherwise, make a vector.
3342 Any number of arguments, even zero arguments, are allowed. */
3345 make_event_array (nargs
, args
)
3351 for (i
= 0; i
< nargs
; i
++)
3352 /* The things that fit in a string
3353 are characters that are in 0...127,
3354 after discarding the meta bit and all the bits above it. */
3355 if (!INTEGERP (args
[i
])
3356 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3357 return Fvector (nargs
, args
);
3359 /* Since the loop exited, we know that all the things in it are
3360 characters, so we can make a string. */
3364 result
= Fmake_string (make_number (nargs
), make_number (0));
3365 for (i
= 0; i
< nargs
; i
++)
3367 SSET (result
, i
, XINT (args
[i
]));
3368 /* Move the meta bit to the right place for a string char. */
3369 if (XINT (args
[i
]) & CHAR_META
)
3370 SSET (result
, i
, SREF (result
, i
) | 0x80);
3379 /************************************************************************
3380 Memory Full Handling
3381 ************************************************************************/
3384 /* Called if malloc returns zero. */
3393 memory_full_cons_threshold
= sizeof (struct cons_block
);
3395 /* The first time we get here, free the spare memory. */
3396 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3397 if (spare_memory
[i
])
3400 free (spare_memory
[i
]);
3401 else if (i
>= 1 && i
<= 4)
3402 lisp_align_free (spare_memory
[i
]);
3404 lisp_free (spare_memory
[i
]);
3405 spare_memory
[i
] = 0;
3408 /* Record the space now used. When it decreases substantially,
3409 we can refill the memory reserve. */
3410 #ifndef SYSTEM_MALLOC
3411 bytes_used_when_full
= BYTES_USED
;
3414 /* This used to call error, but if we've run out of memory, we could
3415 get infinite recursion trying to build the string. */
3417 Fsignal (Qnil
, Vmemory_signal_data
);
3420 /* If we released our reserve (due to running out of memory),
3421 and we have a fair amount free once again,
3422 try to set aside another reserve in case we run out once more.
3424 This is called when a relocatable block is freed in ralloc.c,
3425 and also directly from this file, in case we're not using ralloc.c. */
3428 refill_memory_reserve ()
3430 #ifndef SYSTEM_MALLOC
3431 if (spare_memory
[0] == 0)
3432 spare_memory
[0] = (char *) malloc ((size_t) SPARE_MEMORY
);
3433 if (spare_memory
[1] == 0)
3434 spare_memory
[1] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3436 if (spare_memory
[2] == 0)
3437 spare_memory
[2] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3439 if (spare_memory
[3] == 0)
3440 spare_memory
[3] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3442 if (spare_memory
[4] == 0)
3443 spare_memory
[4] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3445 if (spare_memory
[5] == 0)
3446 spare_memory
[5] = (char *) lisp_malloc (sizeof (struct string_block
),
3448 if (spare_memory
[6] == 0)
3449 spare_memory
[6] = (char *) lisp_malloc (sizeof (struct string_block
),
3451 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3452 Vmemory_full
= Qnil
;
3456 /************************************************************************
3458 ************************************************************************/
3460 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3462 /* Conservative C stack marking requires a method to identify possibly
3463 live Lisp objects given a pointer value. We do this by keeping
3464 track of blocks of Lisp data that are allocated in a red-black tree
3465 (see also the comment of mem_node which is the type of nodes in
3466 that tree). Function lisp_malloc adds information for an allocated
3467 block to the red-black tree with calls to mem_insert, and function
3468 lisp_free removes it with mem_delete. Functions live_string_p etc
3469 call mem_find to lookup information about a given pointer in the
3470 tree, and use that to determine if the pointer points to a Lisp
3473 /* Initialize this part of alloc.c. */
3478 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3479 mem_z
.parent
= NULL
;
3480 mem_z
.color
= MEM_BLACK
;
3481 mem_z
.start
= mem_z
.end
= NULL
;
3486 /* Value is a pointer to the mem_node containing START. Value is
3487 MEM_NIL if there is no node in the tree containing START. */
3489 static INLINE
struct mem_node
*
3495 if (start
< min_heap_address
|| start
> max_heap_address
)
3498 /* Make the search always successful to speed up the loop below. */
3499 mem_z
.start
= start
;
3500 mem_z
.end
= (char *) start
+ 1;
3503 while (start
< p
->start
|| start
>= p
->end
)
3504 p
= start
< p
->start
? p
->left
: p
->right
;
3509 /* Insert a new node into the tree for a block of memory with start
3510 address START, end address END, and type TYPE. Value is a
3511 pointer to the node that was inserted. */
3513 static struct mem_node
*
3514 mem_insert (start
, end
, type
)
3518 struct mem_node
*c
, *parent
, *x
;
3520 if (start
< min_heap_address
)
3521 min_heap_address
= start
;
3522 if (end
> max_heap_address
)
3523 max_heap_address
= end
;
3525 /* See where in the tree a node for START belongs. In this
3526 particular application, it shouldn't happen that a node is already
3527 present. For debugging purposes, let's check that. */
3531 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3533 while (c
!= MEM_NIL
)
3535 if (start
>= c
->start
&& start
< c
->end
)
3538 c
= start
< c
->start
? c
->left
: c
->right
;
3541 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3543 while (c
!= MEM_NIL
)
3546 c
= start
< c
->start
? c
->left
: c
->right
;
3549 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3551 /* Create a new node. */
3552 #ifdef GC_MALLOC_CHECK
3553 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
3557 x
= (struct mem_node
*) xmalloc (sizeof *x
);
3563 x
->left
= x
->right
= MEM_NIL
;
3566 /* Insert it as child of PARENT or install it as root. */
3569 if (start
< parent
->start
)
3577 /* Re-establish red-black tree properties. */
3578 mem_insert_fixup (x
);
3584 /* Re-establish the red-black properties of the tree, and thereby
3585 balance the tree, after node X has been inserted; X is always red. */
3588 mem_insert_fixup (x
)
3591 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3593 /* X is red and its parent is red. This is a violation of
3594 red-black tree property #3. */
3596 if (x
->parent
== x
->parent
->parent
->left
)
3598 /* We're on the left side of our grandparent, and Y is our
3600 struct mem_node
*y
= x
->parent
->parent
->right
;
3602 if (y
->color
== MEM_RED
)
3604 /* Uncle and parent are red but should be black because
3605 X is red. Change the colors accordingly and proceed
3606 with the grandparent. */
3607 x
->parent
->color
= MEM_BLACK
;
3608 y
->color
= MEM_BLACK
;
3609 x
->parent
->parent
->color
= MEM_RED
;
3610 x
= x
->parent
->parent
;
3614 /* Parent and uncle have different colors; parent is
3615 red, uncle is black. */
3616 if (x
== x
->parent
->right
)
3619 mem_rotate_left (x
);
3622 x
->parent
->color
= MEM_BLACK
;
3623 x
->parent
->parent
->color
= MEM_RED
;
3624 mem_rotate_right (x
->parent
->parent
);
3629 /* This is the symmetrical case of above. */
3630 struct mem_node
*y
= x
->parent
->parent
->left
;
3632 if (y
->color
== MEM_RED
)
3634 x
->parent
->color
= MEM_BLACK
;
3635 y
->color
= MEM_BLACK
;
3636 x
->parent
->parent
->color
= MEM_RED
;
3637 x
= x
->parent
->parent
;
3641 if (x
== x
->parent
->left
)
3644 mem_rotate_right (x
);
3647 x
->parent
->color
= MEM_BLACK
;
3648 x
->parent
->parent
->color
= MEM_RED
;
3649 mem_rotate_left (x
->parent
->parent
);
3654 /* The root may have been changed to red due to the algorithm. Set
3655 it to black so that property #5 is satisfied. */
3656 mem_root
->color
= MEM_BLACK
;
3672 /* Turn y's left sub-tree into x's right sub-tree. */
3675 if (y
->left
!= MEM_NIL
)
3676 y
->left
->parent
= x
;
3678 /* Y's parent was x's parent. */
3680 y
->parent
= x
->parent
;
3682 /* Get the parent to point to y instead of x. */
3685 if (x
== x
->parent
->left
)
3686 x
->parent
->left
= y
;
3688 x
->parent
->right
= y
;
3693 /* Put x on y's left. */
3707 mem_rotate_right (x
)
3710 struct mem_node
*y
= x
->left
;
3713 if (y
->right
!= MEM_NIL
)
3714 y
->right
->parent
= x
;
3717 y
->parent
= x
->parent
;
3720 if (x
== x
->parent
->right
)
3721 x
->parent
->right
= y
;
3723 x
->parent
->left
= y
;
3734 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3740 struct mem_node
*x
, *y
;
3742 if (!z
|| z
== MEM_NIL
)
3745 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3750 while (y
->left
!= MEM_NIL
)
3754 if (y
->left
!= MEM_NIL
)
3759 x
->parent
= y
->parent
;
3762 if (y
== y
->parent
->left
)
3763 y
->parent
->left
= x
;
3765 y
->parent
->right
= x
;
3772 z
->start
= y
->start
;
3777 if (y
->color
== MEM_BLACK
)
3778 mem_delete_fixup (x
);
3780 #ifdef GC_MALLOC_CHECK
3788 /* Re-establish the red-black properties of the tree, after a
3792 mem_delete_fixup (x
)
3795 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3797 if (x
== x
->parent
->left
)
3799 struct mem_node
*w
= x
->parent
->right
;
3801 if (w
->color
== MEM_RED
)
3803 w
->color
= MEM_BLACK
;
3804 x
->parent
->color
= MEM_RED
;
3805 mem_rotate_left (x
->parent
);
3806 w
= x
->parent
->right
;
3809 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3816 if (w
->right
->color
== MEM_BLACK
)
3818 w
->left
->color
= MEM_BLACK
;
3820 mem_rotate_right (w
);
3821 w
= x
->parent
->right
;
3823 w
->color
= x
->parent
->color
;
3824 x
->parent
->color
= MEM_BLACK
;
3825 w
->right
->color
= MEM_BLACK
;
3826 mem_rotate_left (x
->parent
);
3832 struct mem_node
*w
= x
->parent
->left
;
3834 if (w
->color
== MEM_RED
)
3836 w
->color
= MEM_BLACK
;
3837 x
->parent
->color
= MEM_RED
;
3838 mem_rotate_right (x
->parent
);
3839 w
= x
->parent
->left
;
3842 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3849 if (w
->left
->color
== MEM_BLACK
)
3851 w
->right
->color
= MEM_BLACK
;
3853 mem_rotate_left (w
);
3854 w
= x
->parent
->left
;
3857 w
->color
= x
->parent
->color
;
3858 x
->parent
->color
= MEM_BLACK
;
3859 w
->left
->color
= MEM_BLACK
;
3860 mem_rotate_right (x
->parent
);
3866 x
->color
= MEM_BLACK
;
3870 /* Value is non-zero if P is a pointer to a live Lisp string on
3871 the heap. M is a pointer to the mem_block for P. */
3874 live_string_p (m
, p
)
3878 if (m
->type
== MEM_TYPE_STRING
)
3880 struct string_block
*b
= (struct string_block
*) m
->start
;
3881 int offset
= (char *) p
- (char *) &b
->strings
[0];
3883 /* P must point to the start of a Lisp_String structure, and it
3884 must not be on the free-list. */
3886 && offset
% sizeof b
->strings
[0] == 0
3887 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
3888 && ((struct Lisp_String
*) p
)->data
!= NULL
);
3895 /* Value is non-zero if P is a pointer to a live Lisp cons on
3896 the heap. M is a pointer to the mem_block for P. */
3903 if (m
->type
== MEM_TYPE_CONS
)
3905 struct cons_block
*b
= (struct cons_block
*) m
->start
;
3906 int offset
= (char *) p
- (char *) &b
->conses
[0];
3908 /* P must point to the start of a Lisp_Cons, not be
3909 one of the unused cells in the current cons block,
3910 and not be on the free-list. */
3912 && offset
% sizeof b
->conses
[0] == 0
3913 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
3915 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
3916 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
3923 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3924 the heap. M is a pointer to the mem_block for P. */
3927 live_symbol_p (m
, p
)
3931 if (m
->type
== MEM_TYPE_SYMBOL
)
3933 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
3934 int offset
= (char *) p
- (char *) &b
->symbols
[0];
3936 /* P must point to the start of a Lisp_Symbol, not be
3937 one of the unused cells in the current symbol block,
3938 and not be on the free-list. */
3940 && offset
% sizeof b
->symbols
[0] == 0
3941 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
3942 && (b
!= symbol_block
3943 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
3944 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
3951 /* Value is non-zero if P is a pointer to a live Lisp float on
3952 the heap. M is a pointer to the mem_block for P. */
3959 if (m
->type
== MEM_TYPE_FLOAT
)
3961 struct float_block
*b
= (struct float_block
*) m
->start
;
3962 int offset
= (char *) p
- (char *) &b
->floats
[0];
3964 /* P must point to the start of a Lisp_Float and not be
3965 one of the unused cells in the current float block. */
3967 && offset
% sizeof b
->floats
[0] == 0
3968 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
3969 && (b
!= float_block
3970 || offset
/ sizeof b
->floats
[0] < float_block_index
));
3977 /* Value is non-zero if P is a pointer to a live Lisp Misc on
3978 the heap. M is a pointer to the mem_block for P. */
3985 if (m
->type
== MEM_TYPE_MISC
)
3987 struct marker_block
*b
= (struct marker_block
*) m
->start
;
3988 int offset
= (char *) p
- (char *) &b
->markers
[0];
3990 /* P must point to the start of a Lisp_Misc, not be
3991 one of the unused cells in the current misc block,
3992 and not be on the free-list. */
3994 && offset
% sizeof b
->markers
[0] == 0
3995 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
3996 && (b
!= marker_block
3997 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
3998 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
4005 /* Value is non-zero if P is a pointer to a live vector-like object.
4006 M is a pointer to the mem_block for P. */
4009 live_vector_p (m
, p
)
4013 return (p
== m
->start
4014 && m
->type
>= MEM_TYPE_VECTOR
4015 && m
->type
<= MEM_TYPE_WINDOW
);
4019 /* Value is non-zero if P is a pointer to a live buffer. M is a
4020 pointer to the mem_block for P. */
4023 live_buffer_p (m
, p
)
4027 /* P must point to the start of the block, and the buffer
4028 must not have been killed. */
4029 return (m
->type
== MEM_TYPE_BUFFER
4031 && !NILP (((struct buffer
*) p
)->name
));
4034 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4038 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4040 /* Array of objects that are kept alive because the C stack contains
4041 a pattern that looks like a reference to them . */
4043 #define MAX_ZOMBIES 10
4044 static Lisp_Object zombies
[MAX_ZOMBIES
];
4046 /* Number of zombie objects. */
4048 static int nzombies
;
4050 /* Number of garbage collections. */
4054 /* Average percentage of zombies per collection. */
4056 static double avg_zombies
;
4058 /* Max. number of live and zombie objects. */
4060 static int max_live
, max_zombies
;
4062 /* Average number of live objects per GC. */
4064 static double avg_live
;
4066 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4067 doc
: /* Show information about live and zombie objects. */)
4070 Lisp_Object args
[8], zombie_list
= Qnil
;
4072 for (i
= 0; i
< nzombies
; i
++)
4073 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4074 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4075 args
[1] = make_number (ngcs
);
4076 args
[2] = make_float (avg_live
);
4077 args
[3] = make_float (avg_zombies
);
4078 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4079 args
[5] = make_number (max_live
);
4080 args
[6] = make_number (max_zombies
);
4081 args
[7] = zombie_list
;
4082 return Fmessage (8, args
);
4085 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4088 /* Mark OBJ if we can prove it's a Lisp_Object. */
4091 mark_maybe_object (obj
)
4094 void *po
= (void *) XPNTR (obj
);
4095 struct mem_node
*m
= mem_find (po
);
4101 switch (XGCTYPE (obj
))
4104 mark_p
= (live_string_p (m
, po
)
4105 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4109 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4113 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4117 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4120 case Lisp_Vectorlike
:
4121 /* Note: can't check GC_BUFFERP before we know it's a
4122 buffer because checking that dereferences the pointer
4123 PO which might point anywhere. */
4124 if (live_vector_p (m
, po
))
4125 mark_p
= !GC_SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4126 else if (live_buffer_p (m
, po
))
4127 mark_p
= GC_BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4131 mark_p
= (live_misc_p (m
, po
) && !XMARKER (obj
)->gcmarkbit
);
4135 case Lisp_Type_Limit
:
4141 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4142 if (nzombies
< MAX_ZOMBIES
)
4143 zombies
[nzombies
] = obj
;
4152 /* If P points to Lisp data, mark that as live if it isn't already
4156 mark_maybe_pointer (p
)
4161 /* Quickly rule out some values which can't point to Lisp data. We
4162 assume that Lisp data is aligned on even addresses. */
4163 if ((EMACS_INT
) p
& 1)
4169 Lisp_Object obj
= Qnil
;
4173 case MEM_TYPE_NON_LISP
:
4174 /* Nothing to do; not a pointer to Lisp memory. */
4177 case MEM_TYPE_BUFFER
:
4178 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P((struct buffer
*)p
))
4179 XSETVECTOR (obj
, p
);
4183 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4187 case MEM_TYPE_STRING
:
4188 if (live_string_p (m
, p
)
4189 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4190 XSETSTRING (obj
, p
);
4194 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4198 case MEM_TYPE_SYMBOL
:
4199 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4200 XSETSYMBOL (obj
, p
);
4203 case MEM_TYPE_FLOAT
:
4204 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4208 case MEM_TYPE_VECTOR
:
4209 case MEM_TYPE_PROCESS
:
4210 case MEM_TYPE_HASH_TABLE
:
4211 case MEM_TYPE_FRAME
:
4212 case MEM_TYPE_WINDOW
:
4213 if (live_vector_p (m
, p
))
4216 XSETVECTOR (tem
, p
);
4217 if (!GC_SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4232 /* Mark Lisp objects referenced from the address range START..END. */
4235 mark_memory (start
, end
)
4241 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4245 /* Make START the pointer to the start of the memory region,
4246 if it isn't already. */
4254 /* Mark Lisp_Objects. */
4255 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
4256 mark_maybe_object (*p
);
4258 /* Mark Lisp data pointed to. This is necessary because, in some
4259 situations, the C compiler optimizes Lisp objects away, so that
4260 only a pointer to them remains. Example:
4262 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4265 Lisp_Object obj = build_string ("test");
4266 struct Lisp_String *s = XSTRING (obj);
4267 Fgarbage_collect ();
4268 fprintf (stderr, "test `%s'\n", s->data);
4272 Here, `obj' isn't really used, and the compiler optimizes it
4273 away. The only reference to the life string is through the
4276 for (pp
= (void **) start
; (void *) pp
< end
; ++pp
)
4277 mark_maybe_pointer (*pp
);
4280 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4281 the GCC system configuration. In gcc 3.2, the only systems for
4282 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4283 by others?) and ns32k-pc532-min. */
4285 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4287 static int setjmp_tested_p
, longjmps_done
;
4289 #define SETJMP_WILL_LIKELY_WORK "\
4291 Emacs garbage collector has been changed to use conservative stack\n\
4292 marking. Emacs has determined that the method it uses to do the\n\
4293 marking will likely work on your system, but this isn't sure.\n\
4295 If you are a system-programmer, or can get the help of a local wizard\n\
4296 who is, please take a look at the function mark_stack in alloc.c, and\n\
4297 verify that the methods used are appropriate for your system.\n\
4299 Please mail the result to <emacs-devel@gnu.org>.\n\
4302 #define SETJMP_WILL_NOT_WORK "\
4304 Emacs garbage collector has been changed to use conservative stack\n\
4305 marking. Emacs has determined that the default method it uses to do the\n\
4306 marking will not work on your system. We will need a system-dependent\n\
4307 solution for your system.\n\
4309 Please take a look at the function mark_stack in alloc.c, and\n\
4310 try to find a way to make it work on your system.\n\
4312 Note that you may get false negatives, depending on the compiler.\n\
4313 In particular, you need to use -O with GCC for this test.\n\
4315 Please mail the result to <emacs-devel@gnu.org>.\n\
4319 /* Perform a quick check if it looks like setjmp saves registers in a
4320 jmp_buf. Print a message to stderr saying so. When this test
4321 succeeds, this is _not_ a proof that setjmp is sufficient for
4322 conservative stack marking. Only the sources or a disassembly
4333 /* Arrange for X to be put in a register. */
4339 if (longjmps_done
== 1)
4341 /* Came here after the longjmp at the end of the function.
4343 If x == 1, the longjmp has restored the register to its
4344 value before the setjmp, and we can hope that setjmp
4345 saves all such registers in the jmp_buf, although that
4348 For other values of X, either something really strange is
4349 taking place, or the setjmp just didn't save the register. */
4352 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4355 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4362 if (longjmps_done
== 1)
4366 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4369 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4371 /* Abort if anything GCPRO'd doesn't survive the GC. */
4379 for (p
= gcprolist
; p
; p
= p
->next
)
4380 for (i
= 0; i
< p
->nvars
; ++i
)
4381 if (!survives_gc_p (p
->var
[i
]))
4382 /* FIXME: It's not necessarily a bug. It might just be that the
4383 GCPRO is unnecessary or should release the object sooner. */
4387 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4394 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
4395 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4397 fprintf (stderr
, " %d = ", i
);
4398 debug_print (zombies
[i
]);
4402 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4405 /* Mark live Lisp objects on the C stack.
4407 There are several system-dependent problems to consider when
4408 porting this to new architectures:
4412 We have to mark Lisp objects in CPU registers that can hold local
4413 variables or are used to pass parameters.
4415 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4416 something that either saves relevant registers on the stack, or
4417 calls mark_maybe_object passing it each register's contents.
4419 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4420 implementation assumes that calling setjmp saves registers we need
4421 to see in a jmp_buf which itself lies on the stack. This doesn't
4422 have to be true! It must be verified for each system, possibly
4423 by taking a look at the source code of setjmp.
4427 Architectures differ in the way their processor stack is organized.
4428 For example, the stack might look like this
4431 | Lisp_Object | size = 4
4433 | something else | size = 2
4435 | Lisp_Object | size = 4
4439 In such a case, not every Lisp_Object will be aligned equally. To
4440 find all Lisp_Object on the stack it won't be sufficient to walk
4441 the stack in steps of 4 bytes. Instead, two passes will be
4442 necessary, one starting at the start of the stack, and a second
4443 pass starting at the start of the stack + 2. Likewise, if the
4444 minimal alignment of Lisp_Objects on the stack is 1, four passes
4445 would be necessary, each one starting with one byte more offset
4446 from the stack start.
4448 The current code assumes by default that Lisp_Objects are aligned
4449 equally on the stack. */
4456 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4459 /* This trick flushes the register windows so that all the state of
4460 the process is contained in the stack. */
4461 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4462 needed on ia64 too. See mach_dep.c, where it also says inline
4463 assembler doesn't work with relevant proprietary compilers. */
4468 /* Save registers that we need to see on the stack. We need to see
4469 registers used to hold register variables and registers used to
4471 #ifdef GC_SAVE_REGISTERS_ON_STACK
4472 GC_SAVE_REGISTERS_ON_STACK (end
);
4473 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4475 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4476 setjmp will definitely work, test it
4477 and print a message with the result
4479 if (!setjmp_tested_p
)
4481 setjmp_tested_p
= 1;
4484 #endif /* GC_SETJMP_WORKS */
4487 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4488 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4490 /* This assumes that the stack is a contiguous region in memory. If
4491 that's not the case, something has to be done here to iterate
4492 over the stack segments. */
4493 #ifndef GC_LISP_OBJECT_ALIGNMENT
4495 #define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
4497 #define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
4500 for (i
= 0; i
< sizeof (Lisp_Object
); i
+= GC_LISP_OBJECT_ALIGNMENT
)
4501 mark_memory ((char *) stack_base
+ i
, end
);
4502 /* Allow for marking a secondary stack, like the register stack on the
4504 #ifdef GC_MARK_SECONDARY_STACK
4505 GC_MARK_SECONDARY_STACK ();
4508 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4513 #endif /* GC_MARK_STACK != 0 */
4517 /* Return 1 if OBJ is a valid lisp object.
4518 Return 0 if OBJ is NOT a valid lisp object.
4519 Return -1 if we cannot validate OBJ.
4520 This function can be quite slow,
4521 so it should only be used in code for manual debugging. */
4524 valid_lisp_object_p (obj
)
4537 p
= (void *) XPNTR (obj
);
4538 if (PURE_POINTER_P (p
))
4542 /* We need to determine whether it is safe to access memory at
4543 address P. Obviously, we cannot just access it (we would SEGV
4544 trying), so we trick the o/s to tell us whether p is a valid
4545 pointer. Unfortunately, we cannot use NULL_DEVICE here, as
4546 emacs_write may not validate p in that case. */
4547 if ((fd
= emacs_open ("__Valid__Lisp__Object__", O_CREAT
| O_WRONLY
| O_TRUNC
, 0666)) >= 0)
4549 int valid
= (emacs_write (fd
, (char *)p
, 16) == 16);
4551 unlink ("__Valid__Lisp__Object__");
4565 case MEM_TYPE_NON_LISP
:
4568 case MEM_TYPE_BUFFER
:
4569 return live_buffer_p (m
, p
);
4572 return live_cons_p (m
, p
);
4574 case MEM_TYPE_STRING
:
4575 return live_string_p (m
, p
);
4578 return live_misc_p (m
, p
);
4580 case MEM_TYPE_SYMBOL
:
4581 return live_symbol_p (m
, p
);
4583 case MEM_TYPE_FLOAT
:
4584 return live_float_p (m
, p
);
4586 case MEM_TYPE_VECTOR
:
4587 case MEM_TYPE_PROCESS
:
4588 case MEM_TYPE_HASH_TABLE
:
4589 case MEM_TYPE_FRAME
:
4590 case MEM_TYPE_WINDOW
:
4591 return live_vector_p (m
, p
);
4604 /***********************************************************************
4605 Pure Storage Management
4606 ***********************************************************************/
4608 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4609 pointer to it. TYPE is the Lisp type for which the memory is
4610 allocated. TYPE < 0 means it's not used for a Lisp object.
4612 If store_pure_type_info is set and TYPE is >= 0, the type of
4613 the allocated object is recorded in pure_types. */
4615 static POINTER_TYPE
*
4616 pure_alloc (size
, type
)
4620 POINTER_TYPE
*result
;
4622 size_t alignment
= (1 << GCTYPEBITS
);
4624 size_t alignment
= sizeof (EMACS_INT
);
4626 /* Give Lisp_Floats an extra alignment. */
4627 if (type
== Lisp_Float
)
4629 #if defined __GNUC__ && __GNUC__ >= 2
4630 alignment
= __alignof (struct Lisp_Float
);
4632 alignment
= sizeof (struct Lisp_Float
);
4638 result
= ALIGN (purebeg
+ pure_bytes_used
, alignment
);
4639 pure_bytes_used
= ((char *)result
- (char *)purebeg
) + size
;
4641 if (pure_bytes_used
<= pure_size
)
4644 /* Don't allocate a large amount here,
4645 because it might get mmap'd and then its address
4646 might not be usable. */
4647 purebeg
= (char *) xmalloc (10000);
4649 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4650 pure_bytes_used
= 0;
4655 /* Print a warning if PURESIZE is too small. */
4660 if (pure_bytes_used_before_overflow
)
4661 message ("Pure Lisp storage overflow (approx. %d bytes needed)",
4662 (int) (pure_bytes_used
+ pure_bytes_used_before_overflow
));
4666 /* Return a string allocated in pure space. DATA is a buffer holding
4667 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4668 non-zero means make the result string multibyte.
4670 Must get an error if pure storage is full, since if it cannot hold
4671 a large string it may be able to hold conses that point to that
4672 string; then the string is not protected from gc. */
4675 make_pure_string (data
, nchars
, nbytes
, multibyte
)
4681 struct Lisp_String
*s
;
4683 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4684 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
4686 s
->size_byte
= multibyte
? nbytes
: -1;
4687 bcopy (data
, s
->data
, nbytes
);
4688 s
->data
[nbytes
] = '\0';
4689 s
->intervals
= NULL_INTERVAL
;
4690 XSETSTRING (string
, s
);
4695 /* Return a cons allocated from pure space. Give it pure copies
4696 of CAR as car and CDR as cdr. */
4699 pure_cons (car
, cdr
)
4700 Lisp_Object car
, cdr
;
4702 register Lisp_Object
new;
4703 struct Lisp_Cons
*p
;
4705 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
4707 XSETCAR (new, Fpurecopy (car
));
4708 XSETCDR (new, Fpurecopy (cdr
));
4713 /* Value is a float object with value NUM allocated from pure space. */
4716 make_pure_float (num
)
4719 register Lisp_Object
new;
4720 struct Lisp_Float
*p
;
4722 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
4724 XFLOAT_DATA (new) = num
;
4729 /* Return a vector with room for LEN Lisp_Objects allocated from
4733 make_pure_vector (len
)
4737 struct Lisp_Vector
*p
;
4738 size_t size
= sizeof *p
+ (len
- 1) * sizeof (Lisp_Object
);
4740 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
4741 XSETVECTOR (new, p
);
4742 XVECTOR (new)->size
= len
;
4747 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
4748 doc
: /* Make a copy of OBJECT in pure storage.
4749 Recursively copies contents of vectors and cons cells.
4750 Does not copy symbols. Copies strings without text properties. */)
4752 register Lisp_Object obj
;
4754 if (NILP (Vpurify_flag
))
4757 if (PURE_POINTER_P (XPNTR (obj
)))
4761 return pure_cons (XCAR (obj
), XCDR (obj
));
4762 else if (FLOATP (obj
))
4763 return make_pure_float (XFLOAT_DATA (obj
));
4764 else if (STRINGP (obj
))
4765 return make_pure_string (SDATA (obj
), SCHARS (obj
),
4767 STRING_MULTIBYTE (obj
));
4768 else if (COMPILEDP (obj
) || VECTORP (obj
))
4770 register struct Lisp_Vector
*vec
;
4774 size
= XVECTOR (obj
)->size
;
4775 if (size
& PSEUDOVECTOR_FLAG
)
4776 size
&= PSEUDOVECTOR_SIZE_MASK
;
4777 vec
= XVECTOR (make_pure_vector (size
));
4778 for (i
= 0; i
< size
; i
++)
4779 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
4780 if (COMPILEDP (obj
))
4781 XSETCOMPILED (obj
, vec
);
4783 XSETVECTOR (obj
, vec
);
4786 else if (MARKERP (obj
))
4787 error ("Attempt to copy a marker to pure storage");
4794 /***********************************************************************
4796 ***********************************************************************/
4798 /* Put an entry in staticvec, pointing at the variable with address
4802 staticpro (varaddress
)
4803 Lisp_Object
*varaddress
;
4805 staticvec
[staticidx
++] = varaddress
;
4806 if (staticidx
>= NSTATICS
)
4814 struct catchtag
*next
;
4818 /***********************************************************************
4820 ***********************************************************************/
4822 /* Temporarily prevent garbage collection. */
4825 inhibit_garbage_collection ()
4827 int count
= SPECPDL_INDEX ();
4828 int nbits
= min (VALBITS
, BITS_PER_INT
);
4830 specbind (Qgc_cons_threshold
, make_number (((EMACS_INT
) 1 << (nbits
- 1)) - 1));
4835 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
4836 doc
: /* Reclaim storage for Lisp objects no longer needed.
4837 Garbage collection happens automatically if you cons more than
4838 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4839 `garbage-collect' normally returns a list with info on amount of space in use:
4840 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4841 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4842 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
4843 (USED-STRINGS . FREE-STRINGS))
4844 However, if there was overflow in pure space, `garbage-collect'
4845 returns nil, because real GC can't be done. */)
4848 register struct specbinding
*bind
;
4849 struct catchtag
*catch;
4850 struct handler
*handler
;
4851 char stack_top_variable
;
4854 Lisp_Object total
[8];
4855 int count
= SPECPDL_INDEX ();
4856 EMACS_TIME t1
, t2
, t3
;
4861 /* Can't GC if pure storage overflowed because we can't determine
4862 if something is a pure object or not. */
4863 if (pure_bytes_used_before_overflow
)
4868 /* Don't keep undo information around forever.
4869 Do this early on, so it is no problem if the user quits. */
4871 register struct buffer
*nextb
= all_buffers
;
4875 /* If a buffer's undo list is Qt, that means that undo is
4876 turned off in that buffer. Calling truncate_undo_list on
4877 Qt tends to return NULL, which effectively turns undo back on.
4878 So don't call truncate_undo_list if undo_list is Qt. */
4879 if (! NILP (nextb
->name
) && ! EQ (nextb
->undo_list
, Qt
))
4880 truncate_undo_list (nextb
);
4882 /* Shrink buffer gaps, but skip indirect and dead buffers. */
4883 if (nextb
->base_buffer
== 0 && !NILP (nextb
->name
))
4885 /* If a buffer's gap size is more than 10% of the buffer
4886 size, or larger than 2000 bytes, then shrink it
4887 accordingly. Keep a minimum size of 20 bytes. */
4888 int size
= min (2000, max (20, (nextb
->text
->z_byte
/ 10)));
4890 if (nextb
->text
->gap_size
> size
)
4892 struct buffer
*save_current
= current_buffer
;
4893 current_buffer
= nextb
;
4894 make_gap (-(nextb
->text
->gap_size
- size
));
4895 current_buffer
= save_current
;
4899 nextb
= nextb
->next
;
4903 EMACS_GET_TIME (t1
);
4905 /* In case user calls debug_print during GC,
4906 don't let that cause a recursive GC. */
4907 consing_since_gc
= 0;
4909 /* Save what's currently displayed in the echo area. */
4910 message_p
= push_message ();
4911 record_unwind_protect (pop_message_unwind
, Qnil
);
4913 /* Save a copy of the contents of the stack, for debugging. */
4914 #if MAX_SAVE_STACK > 0
4915 if (NILP (Vpurify_flag
))
4917 i
= &stack_top_variable
- stack_bottom
;
4919 if (i
< MAX_SAVE_STACK
)
4921 if (stack_copy
== 0)
4922 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
4923 else if (stack_copy_size
< i
)
4924 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
4927 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
4928 bcopy (stack_bottom
, stack_copy
, i
);
4930 bcopy (&stack_top_variable
, stack_copy
, i
);
4934 #endif /* MAX_SAVE_STACK > 0 */
4936 if (garbage_collection_messages
)
4937 message1_nolog ("Garbage collecting...");
4941 shrink_regexp_cache ();
4945 /* clear_marks (); */
4947 /* Mark all the special slots that serve as the roots of accessibility. */
4949 for (i
= 0; i
< staticidx
; i
++)
4950 mark_object (*staticvec
[i
]);
4952 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
4954 mark_object (bind
->symbol
);
4955 mark_object (bind
->old_value
);
4961 extern void xg_mark_data ();
4966 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
4967 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
4971 register struct gcpro
*tail
;
4972 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
4973 for (i
= 0; i
< tail
->nvars
; i
++)
4974 mark_object (tail
->var
[i
]);
4979 for (catch = catchlist
; catch; catch = catch->next
)
4981 mark_object (catch->tag
);
4982 mark_object (catch->val
);
4984 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
4986 mark_object (handler
->handler
);
4987 mark_object (handler
->var
);
4991 #ifdef HAVE_WINDOW_SYSTEM
4992 mark_fringe_data ();
4995 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4999 /* Everything is now marked, except for the things that require special
5000 finalization, i.e. the undo_list.
5001 Look thru every buffer's undo list
5002 for elements that update markers that were not marked,
5005 register struct buffer
*nextb
= all_buffers
;
5009 /* If a buffer's undo list is Qt, that means that undo is
5010 turned off in that buffer. Calling truncate_undo_list on
5011 Qt tends to return NULL, which effectively turns undo back on.
5012 So don't call truncate_undo_list if undo_list is Qt. */
5013 if (! EQ (nextb
->undo_list
, Qt
))
5015 Lisp_Object tail
, prev
;
5016 tail
= nextb
->undo_list
;
5018 while (CONSP (tail
))
5020 if (GC_CONSP (XCAR (tail
))
5021 && GC_MARKERP (XCAR (XCAR (tail
)))
5022 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5025 nextb
->undo_list
= tail
= XCDR (tail
);
5029 XSETCDR (prev
, tail
);
5039 /* Now that we have stripped the elements that need not be in the
5040 undo_list any more, we can finally mark the list. */
5041 mark_object (nextb
->undo_list
);
5043 nextb
= nextb
->next
;
5049 /* Clear the mark bits that we set in certain root slots. */
5051 unmark_byte_stack ();
5052 VECTOR_UNMARK (&buffer_defaults
);
5053 VECTOR_UNMARK (&buffer_local_symbols
);
5055 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5063 /* clear_marks (); */
5066 consing_since_gc
= 0;
5067 if (gc_cons_threshold
< 10000)
5068 gc_cons_threshold
= 10000;
5070 if (FLOATP (Vgc_cons_percentage
))
5071 { /* Set gc_cons_combined_threshold. */
5072 EMACS_INT total
= 0;
5074 total
+= total_conses
* sizeof (struct Lisp_Cons
);
5075 total
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5076 total
+= total_markers
* sizeof (union Lisp_Misc
);
5077 total
+= total_string_size
;
5078 total
+= total_vector_size
* sizeof (Lisp_Object
);
5079 total
+= total_floats
* sizeof (struct Lisp_Float
);
5080 total
+= total_intervals
* sizeof (struct interval
);
5081 total
+= total_strings
* sizeof (struct Lisp_String
);
5083 gc_relative_threshold
= total
* XFLOAT_DATA (Vgc_cons_percentage
);
5086 gc_relative_threshold
= 0;
5088 if (garbage_collection_messages
)
5090 if (message_p
|| minibuf_level
> 0)
5093 message1_nolog ("Garbage collecting...done");
5096 unbind_to (count
, Qnil
);
5098 total
[0] = Fcons (make_number (total_conses
),
5099 make_number (total_free_conses
));
5100 total
[1] = Fcons (make_number (total_symbols
),
5101 make_number (total_free_symbols
));
5102 total
[2] = Fcons (make_number (total_markers
),
5103 make_number (total_free_markers
));
5104 total
[3] = make_number (total_string_size
);
5105 total
[4] = make_number (total_vector_size
);
5106 total
[5] = Fcons (make_number (total_floats
),
5107 make_number (total_free_floats
));
5108 total
[6] = Fcons (make_number (total_intervals
),
5109 make_number (total_free_intervals
));
5110 total
[7] = Fcons (make_number (total_strings
),
5111 make_number (total_free_strings
));
5113 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5115 /* Compute average percentage of zombies. */
5118 for (i
= 0; i
< 7; ++i
)
5119 if (CONSP (total
[i
]))
5120 nlive
+= XFASTINT (XCAR (total
[i
]));
5122 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5123 max_live
= max (nlive
, max_live
);
5124 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5125 max_zombies
= max (nzombies
, max_zombies
);
5130 if (!NILP (Vpost_gc_hook
))
5132 int count
= inhibit_garbage_collection ();
5133 safe_run_hooks (Qpost_gc_hook
);
5134 unbind_to (count
, Qnil
);
5137 /* Accumulate statistics. */
5138 EMACS_GET_TIME (t2
);
5139 EMACS_SUB_TIME (t3
, t2
, t1
);
5140 if (FLOATP (Vgc_elapsed
))
5141 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
) +
5143 EMACS_USECS (t3
) * 1.0e-6);
5146 return Flist (sizeof total
/ sizeof *total
, total
);
5150 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5151 only interesting objects referenced from glyphs are strings. */
5154 mark_glyph_matrix (matrix
)
5155 struct glyph_matrix
*matrix
;
5157 struct glyph_row
*row
= matrix
->rows
;
5158 struct glyph_row
*end
= row
+ matrix
->nrows
;
5160 for (; row
< end
; ++row
)
5164 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5166 struct glyph
*glyph
= row
->glyphs
[area
];
5167 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5169 for (; glyph
< end_glyph
; ++glyph
)
5170 if (GC_STRINGP (glyph
->object
)
5171 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5172 mark_object (glyph
->object
);
5178 /* Mark Lisp faces in the face cache C. */
5182 struct face_cache
*c
;
5187 for (i
= 0; i
< c
->used
; ++i
)
5189 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5193 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5194 mark_object (face
->lface
[j
]);
5201 #ifdef HAVE_WINDOW_SYSTEM
5203 /* Mark Lisp objects in image IMG. */
5209 mark_object (img
->spec
);
5211 if (!NILP (img
->data
.lisp_val
))
5212 mark_object (img
->data
.lisp_val
);
5216 /* Mark Lisp objects in image cache of frame F. It's done this way so
5217 that we don't have to include xterm.h here. */
5220 mark_image_cache (f
)
5223 forall_images_in_image_cache (f
, mark_image
);
5226 #endif /* HAVE_X_WINDOWS */
5230 /* Mark reference to a Lisp_Object.
5231 If the object referred to has not been seen yet, recursively mark
5232 all the references contained in it. */
5234 #define LAST_MARKED_SIZE 500
5235 Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5236 int last_marked_index
;
5238 /* For debugging--call abort when we cdr down this many
5239 links of a list, in mark_object. In debugging,
5240 the call to abort will hit a breakpoint.
5241 Normally this is zero and the check never goes off. */
5242 int mark_object_loop_halt
;
5248 register Lisp_Object obj
= arg
;
5249 #ifdef GC_CHECK_MARKED_OBJECTS
5257 if (PURE_POINTER_P (XPNTR (obj
)))
5260 last_marked
[last_marked_index
++] = obj
;
5261 if (last_marked_index
== LAST_MARKED_SIZE
)
5262 last_marked_index
= 0;
5264 /* Perform some sanity checks on the objects marked here. Abort if
5265 we encounter an object we know is bogus. This increases GC time
5266 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5267 #ifdef GC_CHECK_MARKED_OBJECTS
5269 po
= (void *) XPNTR (obj
);
5271 /* Check that the object pointed to by PO is known to be a Lisp
5272 structure allocated from the heap. */
5273 #define CHECK_ALLOCATED() \
5275 m = mem_find (po); \
5280 /* Check that the object pointed to by PO is live, using predicate
5282 #define CHECK_LIVE(LIVEP) \
5284 if (!LIVEP (m, po)) \
5288 /* Check both of the above conditions. */
5289 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5291 CHECK_ALLOCATED (); \
5292 CHECK_LIVE (LIVEP); \
5295 #else /* not GC_CHECK_MARKED_OBJECTS */
5297 #define CHECK_ALLOCATED() (void) 0
5298 #define CHECK_LIVE(LIVEP) (void) 0
5299 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5301 #endif /* not GC_CHECK_MARKED_OBJECTS */
5303 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
5307 register struct Lisp_String
*ptr
= XSTRING (obj
);
5308 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5309 MARK_INTERVAL_TREE (ptr
->intervals
);
5311 #ifdef GC_CHECK_STRING_BYTES
5312 /* Check that the string size recorded in the string is the
5313 same as the one recorded in the sdata structure. */
5314 CHECK_STRING_BYTES (ptr
);
5315 #endif /* GC_CHECK_STRING_BYTES */
5319 case Lisp_Vectorlike
:
5320 #ifdef GC_CHECK_MARKED_OBJECTS
5322 if (m
== MEM_NIL
&& !GC_SUBRP (obj
)
5323 && po
!= &buffer_defaults
5324 && po
!= &buffer_local_symbols
)
5326 #endif /* GC_CHECK_MARKED_OBJECTS */
5328 if (GC_BUFFERP (obj
))
5330 if (!VECTOR_MARKED_P (XBUFFER (obj
)))
5332 #ifdef GC_CHECK_MARKED_OBJECTS
5333 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
5336 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
5341 #endif /* GC_CHECK_MARKED_OBJECTS */
5345 else if (GC_SUBRP (obj
))
5347 else if (GC_COMPILEDP (obj
))
5348 /* We could treat this just like a vector, but it is better to
5349 save the COMPILED_CONSTANTS element for last and avoid
5352 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5353 register EMACS_INT size
= ptr
->size
;
5356 if (VECTOR_MARKED_P (ptr
))
5357 break; /* Already marked */
5359 CHECK_LIVE (live_vector_p
);
5360 VECTOR_MARK (ptr
); /* Else mark it */
5361 size
&= PSEUDOVECTOR_SIZE_MASK
;
5362 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5364 if (i
!= COMPILED_CONSTANTS
)
5365 mark_object (ptr
->contents
[i
]);
5367 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5370 else if (GC_FRAMEP (obj
))
5372 register struct frame
*ptr
= XFRAME (obj
);
5374 if (VECTOR_MARKED_P (ptr
)) break; /* Already marked */
5375 VECTOR_MARK (ptr
); /* Else mark it */
5377 CHECK_LIVE (live_vector_p
);
5378 mark_object (ptr
->name
);
5379 mark_object (ptr
->icon_name
);
5380 mark_object (ptr
->title
);
5381 mark_object (ptr
->focus_frame
);
5382 mark_object (ptr
->selected_window
);
5383 mark_object (ptr
->minibuffer_window
);
5384 mark_object (ptr
->param_alist
);
5385 mark_object (ptr
->scroll_bars
);
5386 mark_object (ptr
->condemned_scroll_bars
);
5387 mark_object (ptr
->menu_bar_items
);
5388 mark_object (ptr
->face_alist
);
5389 mark_object (ptr
->menu_bar_vector
);
5390 mark_object (ptr
->buffer_predicate
);
5391 mark_object (ptr
->buffer_list
);
5392 mark_object (ptr
->menu_bar_window
);
5393 mark_object (ptr
->tool_bar_window
);
5394 mark_face_cache (ptr
->face_cache
);
5395 #ifdef HAVE_WINDOW_SYSTEM
5396 mark_image_cache (ptr
);
5397 mark_object (ptr
->tool_bar_items
);
5398 mark_object (ptr
->desired_tool_bar_string
);
5399 mark_object (ptr
->current_tool_bar_string
);
5400 #endif /* HAVE_WINDOW_SYSTEM */
5402 else if (GC_BOOL_VECTOR_P (obj
))
5404 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5406 if (VECTOR_MARKED_P (ptr
))
5407 break; /* Already marked */
5408 CHECK_LIVE (live_vector_p
);
5409 VECTOR_MARK (ptr
); /* Else mark it */
5411 else if (GC_WINDOWP (obj
))
5413 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5414 struct window
*w
= XWINDOW (obj
);
5417 /* Stop if already marked. */
5418 if (VECTOR_MARKED_P (ptr
))
5422 CHECK_LIVE (live_vector_p
);
5425 /* There is no Lisp data above The member CURRENT_MATRIX in
5426 struct WINDOW. Stop marking when that slot is reached. */
5428 (char *) &ptr
->contents
[i
] < (char *) &w
->current_matrix
;
5430 mark_object (ptr
->contents
[i
]);
5432 /* Mark glyphs for leaf windows. Marking window matrices is
5433 sufficient because frame matrices use the same glyph
5435 if (NILP (w
->hchild
)
5437 && w
->current_matrix
)
5439 mark_glyph_matrix (w
->current_matrix
);
5440 mark_glyph_matrix (w
->desired_matrix
);
5443 else if (GC_HASH_TABLE_P (obj
))
5445 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
5447 /* Stop if already marked. */
5448 if (VECTOR_MARKED_P (h
))
5452 CHECK_LIVE (live_vector_p
);
5455 /* Mark contents. */
5456 /* Do not mark next_free or next_weak.
5457 Being in the next_weak chain
5458 should not keep the hash table alive.
5459 No need to mark `count' since it is an integer. */
5460 mark_object (h
->test
);
5461 mark_object (h
->weak
);
5462 mark_object (h
->rehash_size
);
5463 mark_object (h
->rehash_threshold
);
5464 mark_object (h
->hash
);
5465 mark_object (h
->next
);
5466 mark_object (h
->index
);
5467 mark_object (h
->user_hash_function
);
5468 mark_object (h
->user_cmp_function
);
5470 /* If hash table is not weak, mark all keys and values.
5471 For weak tables, mark only the vector. */
5472 if (GC_NILP (h
->weak
))
5473 mark_object (h
->key_and_value
);
5475 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5479 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5480 register EMACS_INT size
= ptr
->size
;
5483 if (VECTOR_MARKED_P (ptr
)) break; /* Already marked */
5484 CHECK_LIVE (live_vector_p
);
5485 VECTOR_MARK (ptr
); /* Else mark it */
5486 if (size
& PSEUDOVECTOR_FLAG
)
5487 size
&= PSEUDOVECTOR_SIZE_MASK
;
5489 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5490 mark_object (ptr
->contents
[i
]);
5496 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5497 struct Lisp_Symbol
*ptrx
;
5499 if (ptr
->gcmarkbit
) break;
5500 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5502 mark_object (ptr
->value
);
5503 mark_object (ptr
->function
);
5504 mark_object (ptr
->plist
);
5506 if (!PURE_POINTER_P (XSTRING (ptr
->xname
)))
5507 MARK_STRING (XSTRING (ptr
->xname
));
5508 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr
->xname
));
5510 /* Note that we do not mark the obarray of the symbol.
5511 It is safe not to do so because nothing accesses that
5512 slot except to check whether it is nil. */
5516 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
5517 XSETSYMBOL (obj
, ptrx
);
5524 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5525 if (XMARKER (obj
)->gcmarkbit
)
5527 XMARKER (obj
)->gcmarkbit
= 1;
5529 switch (XMISCTYPE (obj
))
5531 case Lisp_Misc_Buffer_Local_Value
:
5532 case Lisp_Misc_Some_Buffer_Local_Value
:
5534 register struct Lisp_Buffer_Local_Value
*ptr
5535 = XBUFFER_LOCAL_VALUE (obj
);
5536 /* If the cdr is nil, avoid recursion for the car. */
5537 if (EQ (ptr
->cdr
, Qnil
))
5539 obj
= ptr
->realvalue
;
5542 mark_object (ptr
->realvalue
);
5543 mark_object (ptr
->buffer
);
5544 mark_object (ptr
->frame
);
5549 case Lisp_Misc_Marker
:
5550 /* DO NOT mark thru the marker's chain.
5551 The buffer's markers chain does not preserve markers from gc;
5552 instead, markers are removed from the chain when freed by gc. */
5555 case Lisp_Misc_Intfwd
:
5556 case Lisp_Misc_Boolfwd
:
5557 case Lisp_Misc_Objfwd
:
5558 case Lisp_Misc_Buffer_Objfwd
:
5559 case Lisp_Misc_Kboard_Objfwd
:
5560 /* Don't bother with Lisp_Buffer_Objfwd,
5561 since all markable slots in current buffer marked anyway. */
5562 /* Don't need to do Lisp_Objfwd, since the places they point
5563 are protected with staticpro. */
5566 case Lisp_Misc_Save_Value
:
5569 register struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5570 /* If DOGC is set, POINTER is the address of a memory
5571 area containing INTEGER potential Lisp_Objects. */
5574 Lisp_Object
*p
= (Lisp_Object
*) ptr
->pointer
;
5576 for (nelt
= ptr
->integer
; nelt
> 0; nelt
--, p
++)
5577 mark_maybe_object (*p
);
5583 case Lisp_Misc_Overlay
:
5585 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
5586 mark_object (ptr
->start
);
5587 mark_object (ptr
->end
);
5588 mark_object (ptr
->plist
);
5591 XSETMISC (obj
, ptr
->next
);
5604 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5605 if (CONS_MARKED_P (ptr
)) break;
5606 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5608 /* If the cdr is nil, avoid recursion for the car. */
5609 if (EQ (ptr
->u
.cdr
, Qnil
))
5615 mark_object (ptr
->car
);
5618 if (cdr_count
== mark_object_loop_halt
)
5624 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
5625 FLOAT_MARK (XFLOAT (obj
));
5636 #undef CHECK_ALLOCATED
5637 #undef CHECK_ALLOCATED_AND_LIVE
5640 /* Mark the pointers in a buffer structure. */
5646 register struct buffer
*buffer
= XBUFFER (buf
);
5647 register Lisp_Object
*ptr
, tmp
;
5648 Lisp_Object base_buffer
;
5650 VECTOR_MARK (buffer
);
5652 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
5654 /* For now, we just don't mark the undo_list. It's done later in
5655 a special way just before the sweep phase, and after stripping
5656 some of its elements that are not needed any more. */
5658 if (buffer
->overlays_before
)
5660 XSETMISC (tmp
, buffer
->overlays_before
);
5663 if (buffer
->overlays_after
)
5665 XSETMISC (tmp
, buffer
->overlays_after
);
5669 for (ptr
= &buffer
->name
;
5670 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
5674 /* If this is an indirect buffer, mark its base buffer. */
5675 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5677 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
5678 mark_buffer (base_buffer
);
5683 /* Value is non-zero if OBJ will survive the current GC because it's
5684 either marked or does not need to be marked to survive. */
5692 switch (XGCTYPE (obj
))
5699 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
5703 survives_p
= XMARKER (obj
)->gcmarkbit
;
5707 survives_p
= STRING_MARKED_P (XSTRING (obj
));
5710 case Lisp_Vectorlike
:
5711 survives_p
= GC_SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
5715 survives_p
= CONS_MARKED_P (XCONS (obj
));
5719 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
5726 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
5731 /* Sweep: find all structures not marked, and free them. */
5736 /* Remove or mark entries in weak hash tables.
5737 This must be done before any object is unmarked. */
5738 sweep_weak_hash_tables ();
5741 #ifdef GC_CHECK_STRING_BYTES
5742 if (!noninteractive
)
5743 check_string_bytes (1);
5746 /* Put all unmarked conses on free list */
5748 register struct cons_block
*cblk
;
5749 struct cons_block
**cprev
= &cons_block
;
5750 register int lim
= cons_block_index
;
5751 register int num_free
= 0, num_used
= 0;
5755 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
5759 for (i
= 0; i
< lim
; i
++)
5760 if (!CONS_MARKED_P (&cblk
->conses
[i
]))
5763 cblk
->conses
[i
].u
.chain
= cons_free_list
;
5764 cons_free_list
= &cblk
->conses
[i
];
5766 cons_free_list
->car
= Vdead
;
5772 CONS_UNMARK (&cblk
->conses
[i
]);
5774 lim
= CONS_BLOCK_SIZE
;
5775 /* If this block contains only free conses and we have already
5776 seen more than two blocks worth of free conses then deallocate
5778 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
5780 *cprev
= cblk
->next
;
5781 /* Unhook from the free list. */
5782 cons_free_list
= cblk
->conses
[0].u
.chain
;
5783 lisp_align_free (cblk
);
5788 num_free
+= this_free
;
5789 cprev
= &cblk
->next
;
5792 total_conses
= num_used
;
5793 total_free_conses
= num_free
;
5796 /* Put all unmarked floats on free list */
5798 register struct float_block
*fblk
;
5799 struct float_block
**fprev
= &float_block
;
5800 register int lim
= float_block_index
;
5801 register int num_free
= 0, num_used
= 0;
5803 float_free_list
= 0;
5805 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
5809 for (i
= 0; i
< lim
; i
++)
5810 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
5813 fblk
->floats
[i
].u
.chain
= float_free_list
;
5814 float_free_list
= &fblk
->floats
[i
];
5819 FLOAT_UNMARK (&fblk
->floats
[i
]);
5821 lim
= FLOAT_BLOCK_SIZE
;
5822 /* If this block contains only free floats and we have already
5823 seen more than two blocks worth of free floats then deallocate
5825 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
5827 *fprev
= fblk
->next
;
5828 /* Unhook from the free list. */
5829 float_free_list
= fblk
->floats
[0].u
.chain
;
5830 lisp_align_free (fblk
);
5835 num_free
+= this_free
;
5836 fprev
= &fblk
->next
;
5839 total_floats
= num_used
;
5840 total_free_floats
= num_free
;
5843 /* Put all unmarked intervals on free list */
5845 register struct interval_block
*iblk
;
5846 struct interval_block
**iprev
= &interval_block
;
5847 register int lim
= interval_block_index
;
5848 register int num_free
= 0, num_used
= 0;
5850 interval_free_list
= 0;
5852 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
5857 for (i
= 0; i
< lim
; i
++)
5859 if (!iblk
->intervals
[i
].gcmarkbit
)
5861 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
5862 interval_free_list
= &iblk
->intervals
[i
];
5868 iblk
->intervals
[i
].gcmarkbit
= 0;
5871 lim
= INTERVAL_BLOCK_SIZE
;
5872 /* If this block contains only free intervals and we have already
5873 seen more than two blocks worth of free intervals then
5874 deallocate this block. */
5875 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
5877 *iprev
= iblk
->next
;
5878 /* Unhook from the free list. */
5879 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
5881 n_interval_blocks
--;
5885 num_free
+= this_free
;
5886 iprev
= &iblk
->next
;
5889 total_intervals
= num_used
;
5890 total_free_intervals
= num_free
;
5893 /* Put all unmarked symbols on free list */
5895 register struct symbol_block
*sblk
;
5896 struct symbol_block
**sprev
= &symbol_block
;
5897 register int lim
= symbol_block_index
;
5898 register int num_free
= 0, num_used
= 0;
5900 symbol_free_list
= NULL
;
5902 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
5905 struct Lisp_Symbol
*sym
= sblk
->symbols
;
5906 struct Lisp_Symbol
*end
= sym
+ lim
;
5908 for (; sym
< end
; ++sym
)
5910 /* Check if the symbol was created during loadup. In such a case
5911 it might be pointed to by pure bytecode which we don't trace,
5912 so we conservatively assume that it is live. */
5913 int pure_p
= PURE_POINTER_P (XSTRING (sym
->xname
));
5915 if (!sym
->gcmarkbit
&& !pure_p
)
5917 sym
->next
= symbol_free_list
;
5918 symbol_free_list
= sym
;
5920 symbol_free_list
->function
= Vdead
;
5928 UNMARK_STRING (XSTRING (sym
->xname
));
5933 lim
= SYMBOL_BLOCK_SIZE
;
5934 /* If this block contains only free symbols and we have already
5935 seen more than two blocks worth of free symbols then deallocate
5937 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
5939 *sprev
= sblk
->next
;
5940 /* Unhook from the free list. */
5941 symbol_free_list
= sblk
->symbols
[0].next
;
5947 num_free
+= this_free
;
5948 sprev
= &sblk
->next
;
5951 total_symbols
= num_used
;
5952 total_free_symbols
= num_free
;
5955 /* Put all unmarked misc's on free list.
5956 For a marker, first unchain it from the buffer it points into. */
5958 register struct marker_block
*mblk
;
5959 struct marker_block
**mprev
= &marker_block
;
5960 register int lim
= marker_block_index
;
5961 register int num_free
= 0, num_used
= 0;
5963 marker_free_list
= 0;
5965 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
5970 for (i
= 0; i
< lim
; i
++)
5972 if (!mblk
->markers
[i
].u_marker
.gcmarkbit
)
5974 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
5975 unchain_marker (&mblk
->markers
[i
].u_marker
);
5976 /* Set the type of the freed object to Lisp_Misc_Free.
5977 We could leave the type alone, since nobody checks it,
5978 but this might catch bugs faster. */
5979 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
5980 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
5981 marker_free_list
= &mblk
->markers
[i
];
5987 mblk
->markers
[i
].u_marker
.gcmarkbit
= 0;
5990 lim
= MARKER_BLOCK_SIZE
;
5991 /* If this block contains only free markers and we have already
5992 seen more than two blocks worth of free markers then deallocate
5994 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
5996 *mprev
= mblk
->next
;
5997 /* Unhook from the free list. */
5998 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
6004 num_free
+= this_free
;
6005 mprev
= &mblk
->next
;
6009 total_markers
= num_used
;
6010 total_free_markers
= num_free
;
6013 /* Free all unmarked buffers */
6015 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
6018 if (!VECTOR_MARKED_P (buffer
))
6021 prev
->next
= buffer
->next
;
6023 all_buffers
= buffer
->next
;
6024 next
= buffer
->next
;
6030 VECTOR_UNMARK (buffer
);
6031 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
6032 prev
= buffer
, buffer
= buffer
->next
;
6036 /* Free all unmarked vectors */
6038 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
6039 total_vector_size
= 0;
6042 if (!VECTOR_MARKED_P (vector
))
6045 prev
->next
= vector
->next
;
6047 all_vectors
= vector
->next
;
6048 next
= vector
->next
;
6056 VECTOR_UNMARK (vector
);
6057 if (vector
->size
& PSEUDOVECTOR_FLAG
)
6058 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
6060 total_vector_size
+= vector
->size
;
6061 prev
= vector
, vector
= vector
->next
;
6065 #ifdef GC_CHECK_STRING_BYTES
6066 if (!noninteractive
)
6067 check_string_bytes (1);
6074 /* Debugging aids. */
6076 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6077 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6078 This may be helpful in debugging Emacs's memory usage.
6079 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6084 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
6089 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6090 doc
: /* Return a list of counters that measure how much consing there has been.
6091 Each of these counters increments for a certain kind of object.
6092 The counters wrap around from the largest positive integer to zero.
6093 Garbage collection does not decrease them.
6094 The elements of the value are as follows:
6095 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6096 All are in units of 1 = one object consed
6097 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6099 MISCS include overlays, markers, and some internal types.
6100 Frames, windows, buffers, and subprocesses count as vectors
6101 (but the contents of a buffer's text do not count here). */)
6104 Lisp_Object consed
[8];
6106 consed
[0] = make_number (min (MOST_POSITIVE_FIXNUM
, cons_cells_consed
));
6107 consed
[1] = make_number (min (MOST_POSITIVE_FIXNUM
, floats_consed
));
6108 consed
[2] = make_number (min (MOST_POSITIVE_FIXNUM
, vector_cells_consed
));
6109 consed
[3] = make_number (min (MOST_POSITIVE_FIXNUM
, symbols_consed
));
6110 consed
[4] = make_number (min (MOST_POSITIVE_FIXNUM
, string_chars_consed
));
6111 consed
[5] = make_number (min (MOST_POSITIVE_FIXNUM
, misc_objects_consed
));
6112 consed
[6] = make_number (min (MOST_POSITIVE_FIXNUM
, intervals_consed
));
6113 consed
[7] = make_number (min (MOST_POSITIVE_FIXNUM
, strings_consed
));
6115 return Flist (8, consed
);
6118 int suppress_checking
;
6120 die (msg
, file
, line
)
6125 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
6130 /* Initialization */
6135 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6137 pure_size
= PURESIZE
;
6138 pure_bytes_used
= 0;
6139 pure_bytes_used_before_overflow
= 0;
6141 /* Initialize the list of free aligned blocks. */
6144 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6146 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6150 ignore_warnings
= 1;
6151 #ifdef DOUG_LEA_MALLOC
6152 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
6153 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
6154 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
6164 malloc_hysteresis
= 32;
6166 malloc_hysteresis
= 0;
6169 refill_memory_reserve ();
6171 ignore_warnings
= 0;
6173 byte_stack_list
= 0;
6175 consing_since_gc
= 0;
6176 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
6177 gc_relative_threshold
= 0;
6179 #ifdef VIRT_ADDR_VARIES
6180 malloc_sbrk_unused
= 1<<22; /* A large number */
6181 malloc_sbrk_used
= 100000; /* as reasonable as any number */
6182 #endif /* VIRT_ADDR_VARIES */
6189 byte_stack_list
= 0;
6191 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6192 setjmp_tested_p
= longjmps_done
= 0;
6195 Vgc_elapsed
= make_float (0.0);
6202 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
6203 doc
: /* *Number of bytes of consing between garbage collections.
6204 Garbage collection can happen automatically once this many bytes have been
6205 allocated since the last garbage collection. All data types count.
6207 Garbage collection happens automatically only when `eval' is called.
6209 By binding this temporarily to a large number, you can effectively
6210 prevent garbage collection during a part of the program.
6211 See also `gc-cons-percentage'. */);
6213 DEFVAR_LISP ("gc-cons-percentage", &Vgc_cons_percentage
,
6214 doc
: /* *Portion of the heap used for allocation.
6215 Garbage collection can happen automatically once this portion of the heap
6216 has been allocated since the last garbage collection.
6217 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6218 Vgc_cons_percentage
= make_float (0.1);
6220 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used
,
6221 doc
: /* Number of bytes of sharable Lisp data allocated so far. */);
6223 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
6224 doc
: /* Number of cons cells that have been consed so far. */);
6226 DEFVAR_INT ("floats-consed", &floats_consed
,
6227 doc
: /* Number of floats that have been consed so far. */);
6229 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
6230 doc
: /* Number of vector cells that have been consed so far. */);
6232 DEFVAR_INT ("symbols-consed", &symbols_consed
,
6233 doc
: /* Number of symbols that have been consed so far. */);
6235 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
6236 doc
: /* Number of string characters that have been consed so far. */);
6238 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
6239 doc
: /* Number of miscellaneous objects that have been consed so far. */);
6241 DEFVAR_INT ("intervals-consed", &intervals_consed
,
6242 doc
: /* Number of intervals that have been consed so far. */);
6244 DEFVAR_INT ("strings-consed", &strings_consed
,
6245 doc
: /* Number of strings that have been consed so far. */);
6247 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
6248 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6249 This means that certain objects should be allocated in shared (pure) space. */);
6251 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
6252 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6253 garbage_collection_messages
= 0;
6255 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook
,
6256 doc
: /* Hook run after garbage collection has finished. */);
6257 Vpost_gc_hook
= Qnil
;
6258 Qpost_gc_hook
= intern ("post-gc-hook");
6259 staticpro (&Qpost_gc_hook
);
6261 DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data
,
6262 doc
: /* Precomputed `signal' argument for memory-full error. */);
6263 /* We build this in advance because if we wait until we need it, we might
6264 not be able to allocate the memory to hold it. */
6267 build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6269 DEFVAR_LISP ("memory-full", &Vmemory_full
,
6270 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6271 Vmemory_full
= Qnil
;
6273 staticpro (&Qgc_cons_threshold
);
6274 Qgc_cons_threshold
= intern ("gc-cons-threshold");
6276 staticpro (&Qchar_table_extra_slots
);
6277 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
6279 DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed
,
6280 doc
: /* Accumulated time elapsed in garbage collections.
6281 The time is in seconds as a floating point value. */);
6282 DEFVAR_INT ("gcs-done", &gcs_done
,
6283 doc
: /* Accumulated number of garbage collections done. */);
6288 defsubr (&Smake_byte_code
);
6289 defsubr (&Smake_list
);
6290 defsubr (&Smake_vector
);
6291 defsubr (&Smake_char_table
);
6292 defsubr (&Smake_string
);
6293 defsubr (&Smake_bool_vector
);
6294 defsubr (&Smake_symbol
);
6295 defsubr (&Smake_marker
);
6296 defsubr (&Spurecopy
);
6297 defsubr (&Sgarbage_collect
);
6298 defsubr (&Smemory_limit
);
6299 defsubr (&Smemory_use_counts
);
6301 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6302 defsubr (&Sgc_status
);
6306 /* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
6307 (do not change this comment) */