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, 2007, 2008, 2009, 2010
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
23 #include <limits.h> /* For CHAR_BIT. */
32 #ifdef HAVE_GTK_AND_PTHREAD
36 /* This file is part of the core Lisp implementation, and thus must
37 deal with the real data structures. If the Lisp implementation is
38 replaced, this file likely will not be used. */
40 #undef HIDE_LISP_IMPLEMENTATION
43 #include "intervals.h"
49 #include "blockinput.h"
50 #include "character.h"
51 #include "syssignal.h"
52 #include "termhooks.h" /* For struct terminal. */
55 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
56 memory. Can do this only if using gmalloc.c. */
58 #if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
59 #undef GC_MALLOC_CHECK
65 extern POINTER_TYPE
*sbrk ();
80 #ifdef DOUG_LEA_MALLOC
83 /* malloc.h #defines this as size_t, at least in glibc2. */
84 #ifndef __malloc_size_t
85 #define __malloc_size_t int
88 /* Specify maximum number of areas to mmap. It would be nice to use a
89 value that explicitly means "no limit". */
91 #define MMAP_MAX_AREAS 100000000
93 #else /* not DOUG_LEA_MALLOC */
95 /* The following come from gmalloc.c. */
97 #define __malloc_size_t size_t
98 extern __malloc_size_t _bytes_used
;
99 extern __malloc_size_t __malloc_extra_blocks
;
101 #endif /* not DOUG_LEA_MALLOC */
103 #if ! defined (SYSTEM_MALLOC) && defined (HAVE_GTK_AND_PTHREAD)
105 /* When GTK uses the file chooser dialog, different backends can be loaded
106 dynamically. One such a backend is the Gnome VFS backend that gets loaded
107 if you run Gnome. That backend creates several threads and also allocates
110 If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
111 functions below are called from malloc, there is a chance that one
112 of these threads preempts the Emacs main thread and the hook variables
113 end up in an inconsistent state. So we have a mutex to prevent that (note
114 that the backend handles concurrent access to malloc within its own threads
115 but Emacs code running in the main thread is not included in that control).
117 When UNBLOCK_INPUT is called, reinvoke_input_signal may be called. If this
118 happens in one of the backend threads we will have two threads that tries
119 to run Emacs code at once, and the code is not prepared for that.
120 To prevent that, we only call BLOCK/UNBLOCK from the main thread. */
122 static pthread_mutex_t alloc_mutex
;
124 #define BLOCK_INPUT_ALLOC \
127 if (pthread_equal (pthread_self (), main_thread)) \
129 pthread_mutex_lock (&alloc_mutex); \
132 #define UNBLOCK_INPUT_ALLOC \
135 pthread_mutex_unlock (&alloc_mutex); \
136 if (pthread_equal (pthread_self (), main_thread)) \
141 #else /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
143 #define BLOCK_INPUT_ALLOC BLOCK_INPUT
144 #define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
146 #endif /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
148 /* Value of _bytes_used, when spare_memory was freed. */
150 static __malloc_size_t bytes_used_when_full
;
152 static __malloc_size_t bytes_used_when_reconsidered
;
154 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
155 to a struct Lisp_String. */
157 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
158 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
159 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
161 #define VECTOR_MARK(V) ((V)->size |= ARRAY_MARK_FLAG)
162 #define VECTOR_UNMARK(V) ((V)->size &= ~ARRAY_MARK_FLAG)
163 #define VECTOR_MARKED_P(V) (((V)->size & ARRAY_MARK_FLAG) != 0)
165 /* Value is the number of bytes/chars of S, a pointer to a struct
166 Lisp_String. This must be used instead of STRING_BYTES (S) or
167 S->size during GC, because S->size contains the mark bit for
170 #define GC_STRING_BYTES(S) (STRING_BYTES (S))
171 #define GC_STRING_CHARS(S) ((S)->size & ~ARRAY_MARK_FLAG)
173 /* Number of bytes of consing done since the last gc. */
175 int consing_since_gc
;
177 /* Count the amount of consing of various sorts of space. */
179 EMACS_INT cons_cells_consed
;
180 EMACS_INT floats_consed
;
181 EMACS_INT vector_cells_consed
;
182 EMACS_INT symbols_consed
;
183 EMACS_INT string_chars_consed
;
184 EMACS_INT misc_objects_consed
;
185 EMACS_INT intervals_consed
;
186 EMACS_INT strings_consed
;
188 /* Minimum number of bytes of consing since GC before next GC. */
190 EMACS_INT gc_cons_threshold
;
192 /* Similar minimum, computed from Vgc_cons_percentage. */
194 EMACS_INT gc_relative_threshold
;
196 static Lisp_Object Vgc_cons_percentage
;
198 /* Minimum number of bytes of consing since GC before next GC,
199 when memory is full. */
201 EMACS_INT memory_full_cons_threshold
;
203 /* Nonzero during GC. */
207 /* Nonzero means abort if try to GC.
208 This is for code which is written on the assumption that
209 no GC will happen, so as to verify that assumption. */
213 /* Nonzero means display messages at beginning and end of GC. */
215 int garbage_collection_messages
;
217 /* Number of live and free conses etc. */
219 static int total_conses
, total_markers
, total_symbols
, total_vector_size
;
220 static int total_free_conses
, total_free_markers
, total_free_symbols
;
221 static int total_free_floats
, total_floats
;
223 /* Points to memory space allocated as "spare", to be freed if we run
224 out of memory. We keep one large block, four cons-blocks, and
225 two string blocks. */
227 static char *spare_memory
[7];
229 /* Amount of spare memory to keep in large reserve block. */
231 #define SPARE_MEMORY (1 << 14)
233 /* Number of extra blocks malloc should get when it needs more core. */
235 static int malloc_hysteresis
;
237 /* Non-nil means defun should do purecopy on the function definition. */
239 Lisp_Object Vpurify_flag
;
241 /* Non-nil means we are handling a memory-full error. */
243 Lisp_Object Vmemory_full
;
245 /* Initialize it to a nonzero value to force it into data space
246 (rather than bss space). That way unexec will remap it into text
247 space (pure), on some systems. We have not implemented the
248 remapping on more recent systems because this is less important
249 nowadays than in the days of small memories and timesharing. */
251 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
252 #define PUREBEG (char *) pure
254 /* Pointer to the pure area, and its size. */
256 static char *purebeg
;
257 static size_t pure_size
;
259 /* Number of bytes of pure storage used before pure storage overflowed.
260 If this is non-zero, this implies that an overflow occurred. */
262 static size_t pure_bytes_used_before_overflow
;
264 /* Value is non-zero if P points into pure space. */
266 #define PURE_POINTER_P(P) \
267 (((PNTR_COMPARISON_TYPE) (P) \
268 < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size)) \
269 && ((PNTR_COMPARISON_TYPE) (P) \
270 >= (PNTR_COMPARISON_TYPE) purebeg))
272 /* Total number of bytes allocated in pure storage. */
274 EMACS_INT pure_bytes_used
;
276 /* Index in pure at which next pure Lisp object will be allocated.. */
278 static EMACS_INT pure_bytes_used_lisp
;
280 /* Number of bytes allocated for non-Lisp objects in pure storage. */
282 static EMACS_INT pure_bytes_used_non_lisp
;
284 /* If nonzero, this is a warning delivered by malloc and not yet
287 const char *pending_malloc_warning
;
289 /* Pre-computed signal argument for use when memory is exhausted. */
291 Lisp_Object Vmemory_signal_data
;
293 /* Maximum amount of C stack to save when a GC happens. */
295 #ifndef MAX_SAVE_STACK
296 #define MAX_SAVE_STACK 16000
299 /* Buffer in which we save a copy of the C stack at each GC. */
301 static char *stack_copy
;
302 static int stack_copy_size
;
304 /* Non-zero means ignore malloc warnings. Set during initialization.
305 Currently not used. */
307 static int ignore_warnings
;
309 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
311 /* Hook run after GC has finished. */
313 Lisp_Object Vpost_gc_hook
, Qpost_gc_hook
;
315 Lisp_Object Vgc_elapsed
; /* accumulated elapsed time in GC */
316 EMACS_INT gcs_done
; /* accumulated GCs */
318 static void mark_buffer (Lisp_Object
);
319 static void mark_terminals (void);
320 extern void mark_kboards (void);
321 extern void mark_ttys (void);
322 extern void mark_backtrace (void);
323 static void gc_sweep (void);
324 static void mark_glyph_matrix (struct glyph_matrix
*);
325 static void mark_face_cache (struct face_cache
*);
327 #ifdef HAVE_WINDOW_SYSTEM
328 extern void mark_fringe_data (void);
329 #endif /* HAVE_WINDOW_SYSTEM */
331 static struct Lisp_String
*allocate_string (void);
332 static void compact_small_strings (void);
333 static void free_large_strings (void);
334 static void sweep_strings (void);
336 extern int message_enable_multibyte
;
338 /* When scanning the C stack for live Lisp objects, Emacs keeps track
339 of what memory allocated via lisp_malloc is intended for what
340 purpose. This enumeration specifies the type of memory. */
351 /* We used to keep separate mem_types for subtypes of vectors such as
352 process, hash_table, frame, terminal, and window, but we never made
353 use of the distinction, so it only caused source-code complexity
354 and runtime slowdown. Minor but pointless. */
358 static POINTER_TYPE
*lisp_align_malloc (size_t, enum mem_type
);
359 static POINTER_TYPE
*lisp_malloc (size_t, enum mem_type
);
360 void refill_memory_reserve (void);
363 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
365 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
366 #include <stdio.h> /* For fprintf. */
369 /* A unique object in pure space used to make some Lisp objects
370 on free lists recognizable in O(1). */
372 static Lisp_Object Vdead
;
374 #ifdef GC_MALLOC_CHECK
376 enum mem_type allocated_mem_type
;
377 static int dont_register_blocks
;
379 #endif /* GC_MALLOC_CHECK */
381 /* A node in the red-black tree describing allocated memory containing
382 Lisp data. Each such block is recorded with its start and end
383 address when it is allocated, and removed from the tree when it
386 A red-black tree is a balanced binary tree with the following
389 1. Every node is either red or black.
390 2. Every leaf is black.
391 3. If a node is red, then both of its children are black.
392 4. Every simple path from a node to a descendant leaf contains
393 the same number of black nodes.
394 5. The root is always black.
396 When nodes are inserted into the tree, or deleted from the tree,
397 the tree is "fixed" so that these properties are always true.
399 A red-black tree with N internal nodes has height at most 2
400 log(N+1). Searches, insertions and deletions are done in O(log N).
401 Please see a text book about data structures for a detailed
402 description of red-black trees. Any book worth its salt should
407 /* Children of this node. These pointers are never NULL. When there
408 is no child, the value is MEM_NIL, which points to a dummy node. */
409 struct mem_node
*left
, *right
;
411 /* The parent of this node. In the root node, this is NULL. */
412 struct mem_node
*parent
;
414 /* Start and end of allocated region. */
418 enum {MEM_BLACK
, MEM_RED
} color
;
424 /* Base address of stack. Set in main. */
426 Lisp_Object
*stack_base
;
428 /* Root of the tree describing allocated Lisp memory. */
430 static struct mem_node
*mem_root
;
432 /* Lowest and highest known address in the heap. */
434 static void *min_heap_address
, *max_heap_address
;
436 /* Sentinel node of the tree. */
438 static struct mem_node mem_z
;
439 #define MEM_NIL &mem_z
441 static struct Lisp_Vector
*allocate_vectorlike (EMACS_INT
);
442 static void lisp_free (POINTER_TYPE
*);
443 static void mark_stack (void);
444 static int live_vector_p (struct mem_node
*, void *);
445 static int live_buffer_p (struct mem_node
*, void *);
446 static int live_string_p (struct mem_node
*, void *);
447 static int live_cons_p (struct mem_node
*, void *);
448 static int live_symbol_p (struct mem_node
*, void *);
449 static int live_float_p (struct mem_node
*, void *);
450 static int live_misc_p (struct mem_node
*, void *);
451 static void mark_maybe_object (Lisp_Object
);
452 static void mark_memory (void *, void *, int);
453 static void mem_init (void);
454 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
455 static void mem_insert_fixup (struct mem_node
*);
456 static void mem_rotate_left (struct mem_node
*);
457 static void mem_rotate_right (struct mem_node
*);
458 static void mem_delete (struct mem_node
*);
459 static void mem_delete_fixup (struct mem_node
*);
460 static INLINE
struct mem_node
*mem_find (void *);
463 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
464 static void check_gcpros (void);
467 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
469 /* Recording what needs to be marked for gc. */
471 struct gcpro
*gcprolist
;
473 /* Addresses of staticpro'd variables. Initialize it to a nonzero
474 value; otherwise some compilers put it into BSS. */
476 #define NSTATICS 0x640
477 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
479 /* Index of next unused slot in staticvec. */
481 static int staticidx
= 0;
483 static POINTER_TYPE
*pure_alloc (size_t, int);
486 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
487 ALIGNMENT must be a power of 2. */
489 #define ALIGN(ptr, ALIGNMENT) \
490 ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
491 & ~((ALIGNMENT) - 1)))
495 /************************************************************************
497 ************************************************************************/
499 /* Function malloc calls this if it finds we are near exhausting storage. */
502 malloc_warning (const char *str
)
504 pending_malloc_warning
= str
;
508 /* Display an already-pending malloc warning. */
511 display_malloc_warning (void)
513 call3 (intern ("display-warning"),
515 build_string (pending_malloc_warning
),
516 intern ("emergency"));
517 pending_malloc_warning
= 0;
521 #ifdef DOUG_LEA_MALLOC
522 # define BYTES_USED (mallinfo ().uordblks)
524 # define BYTES_USED _bytes_used
527 /* Called if we can't allocate relocatable space for a buffer. */
530 buffer_memory_full (void)
532 /* If buffers use the relocating allocator, no need to free
533 spare_memory, because we may have plenty of malloc space left
534 that we could get, and if we don't, the malloc that fails will
535 itself cause spare_memory to be freed. If buffers don't use the
536 relocating allocator, treat this like any other failing
543 /* This used to call error, but if we've run out of memory, we could
544 get infinite recursion trying to build the string. */
545 xsignal (Qnil
, Vmemory_signal_data
);
549 #ifdef XMALLOC_OVERRUN_CHECK
551 /* Check for overrun in malloc'ed buffers by wrapping a 16 byte header
552 and a 16 byte trailer around each block.
554 The header consists of 12 fixed bytes + a 4 byte integer contaning the
555 original block size, while the trailer consists of 16 fixed bytes.
557 The header is used to detect whether this block has been allocated
558 through these functions -- as it seems that some low-level libc
559 functions may bypass the malloc hooks.
563 #define XMALLOC_OVERRUN_CHECK_SIZE 16
565 static char xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
-4] =
566 { 0x9a, 0x9b, 0xae, 0xaf,
567 0xbf, 0xbe, 0xce, 0xcf,
568 0xea, 0xeb, 0xec, 0xed };
570 static char xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
571 { 0xaa, 0xab, 0xac, 0xad,
572 0xba, 0xbb, 0xbc, 0xbd,
573 0xca, 0xcb, 0xcc, 0xcd,
574 0xda, 0xdb, 0xdc, 0xdd };
576 /* Macros to insert and extract the block size in the header. */
578 #define XMALLOC_PUT_SIZE(ptr, size) \
579 (ptr[-1] = (size & 0xff), \
580 ptr[-2] = ((size >> 8) & 0xff), \
581 ptr[-3] = ((size >> 16) & 0xff), \
582 ptr[-4] = ((size >> 24) & 0xff))
584 #define XMALLOC_GET_SIZE(ptr) \
585 (size_t)((unsigned)(ptr[-1]) | \
586 ((unsigned)(ptr[-2]) << 8) | \
587 ((unsigned)(ptr[-3]) << 16) | \
588 ((unsigned)(ptr[-4]) << 24))
591 /* The call depth in overrun_check functions. For example, this might happen:
593 overrun_check_malloc()
594 -> malloc -> (via hook)_-> emacs_blocked_malloc
595 -> overrun_check_malloc
596 call malloc (hooks are NULL, so real malloc is called).
597 malloc returns 10000.
598 add overhead, return 10016.
599 <- (back in overrun_check_malloc)
600 add overhead again, return 10032
601 xmalloc returns 10032.
606 overrun_check_free(10032)
608 free(10016) <- crash, because 10000 is the original pointer. */
610 static int check_depth
;
612 /* Like malloc, but wraps allocated block with header and trailer. */
615 overrun_check_malloc (size
)
618 register unsigned char *val
;
619 size_t overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_SIZE
*2 : 0;
621 val
= (unsigned char *) malloc (size
+ overhead
);
622 if (val
&& check_depth
== 1)
624 memcpy (val
, xmalloc_overrun_check_header
,
625 XMALLOC_OVERRUN_CHECK_SIZE
- 4);
626 val
+= XMALLOC_OVERRUN_CHECK_SIZE
;
627 XMALLOC_PUT_SIZE(val
, size
);
628 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
629 XMALLOC_OVERRUN_CHECK_SIZE
);
632 return (POINTER_TYPE
*)val
;
636 /* Like realloc, but checks old block for overrun, and wraps new block
637 with header and trailer. */
640 overrun_check_realloc (block
, size
)
644 register unsigned char *val
= (unsigned char *)block
;
645 size_t overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_SIZE
*2 : 0;
649 && memcmp (xmalloc_overrun_check_header
,
650 val
- XMALLOC_OVERRUN_CHECK_SIZE
,
651 XMALLOC_OVERRUN_CHECK_SIZE
- 4) == 0)
653 size_t osize
= XMALLOC_GET_SIZE (val
);
654 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
655 XMALLOC_OVERRUN_CHECK_SIZE
))
657 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
658 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
659 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
662 val
= (unsigned char *) realloc ((POINTER_TYPE
*)val
, size
+ overhead
);
664 if (val
&& check_depth
== 1)
666 memcpy (val
, xmalloc_overrun_check_header
,
667 XMALLOC_OVERRUN_CHECK_SIZE
- 4);
668 val
+= XMALLOC_OVERRUN_CHECK_SIZE
;
669 XMALLOC_PUT_SIZE(val
, size
);
670 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
671 XMALLOC_OVERRUN_CHECK_SIZE
);
674 return (POINTER_TYPE
*)val
;
677 /* Like free, but checks block for overrun. */
680 overrun_check_free (block
)
683 unsigned char *val
= (unsigned char *)block
;
688 && memcmp (xmalloc_overrun_check_header
,
689 val
- XMALLOC_OVERRUN_CHECK_SIZE
,
690 XMALLOC_OVERRUN_CHECK_SIZE
- 4) == 0)
692 size_t osize
= XMALLOC_GET_SIZE (val
);
693 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
694 XMALLOC_OVERRUN_CHECK_SIZE
))
696 #ifdef XMALLOC_CLEAR_FREE_MEMORY
697 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
698 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_SIZE
*2);
700 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
701 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
702 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
713 #define malloc overrun_check_malloc
714 #define realloc overrun_check_realloc
715 #define free overrun_check_free
719 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
720 there's no need to block input around malloc. */
721 #define MALLOC_BLOCK_INPUT ((void)0)
722 #define MALLOC_UNBLOCK_INPUT ((void)0)
724 #define MALLOC_BLOCK_INPUT BLOCK_INPUT
725 #define MALLOC_UNBLOCK_INPUT UNBLOCK_INPUT
728 /* Like malloc but check for no memory and block interrupt input.. */
731 xmalloc (size_t size
)
733 register POINTER_TYPE
*val
;
736 val
= (POINTER_TYPE
*) malloc (size
);
737 MALLOC_UNBLOCK_INPUT
;
745 /* Like realloc but check for no memory and block interrupt input.. */
748 xrealloc (POINTER_TYPE
*block
, size_t size
)
750 register POINTER_TYPE
*val
;
753 /* We must call malloc explicitly when BLOCK is 0, since some
754 reallocs don't do this. */
756 val
= (POINTER_TYPE
*) malloc (size
);
758 val
= (POINTER_TYPE
*) realloc (block
, size
);
759 MALLOC_UNBLOCK_INPUT
;
761 if (!val
&& size
) memory_full ();
766 /* Like free but block interrupt input. */
769 xfree (POINTER_TYPE
*block
)
775 MALLOC_UNBLOCK_INPUT
;
776 /* We don't call refill_memory_reserve here
777 because that duplicates doing so in emacs_blocked_free
778 and the criterion should go there. */
782 /* Like strdup, but uses xmalloc. */
785 xstrdup (const char *s
)
787 size_t len
= strlen (s
) + 1;
788 char *p
= (char *) xmalloc (len
);
794 /* Unwind for SAFE_ALLOCA */
797 safe_alloca_unwind (Lisp_Object arg
)
799 register struct Lisp_Save_Value
*p
= XSAVE_VALUE (arg
);
809 /* Like malloc but used for allocating Lisp data. NBYTES is the
810 number of bytes to allocate, TYPE describes the intended use of the
811 allcated memory block (for strings, for conses, ...). */
814 static void *lisp_malloc_loser
;
817 static POINTER_TYPE
*
818 lisp_malloc (size_t nbytes
, enum mem_type type
)
824 #ifdef GC_MALLOC_CHECK
825 allocated_mem_type
= type
;
828 val
= (void *) malloc (nbytes
);
831 /* If the memory just allocated cannot be addressed thru a Lisp
832 object's pointer, and it needs to be,
833 that's equivalent to running out of memory. */
834 if (val
&& type
!= MEM_TYPE_NON_LISP
)
837 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
838 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
840 lisp_malloc_loser
= val
;
847 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
848 if (val
&& type
!= MEM_TYPE_NON_LISP
)
849 mem_insert (val
, (char *) val
+ nbytes
, type
);
852 MALLOC_UNBLOCK_INPUT
;
858 /* Free BLOCK. This must be called to free memory allocated with a
859 call to lisp_malloc. */
862 lisp_free (POINTER_TYPE
*block
)
866 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
867 mem_delete (mem_find (block
));
869 MALLOC_UNBLOCK_INPUT
;
872 /* Allocation of aligned blocks of memory to store Lisp data. */
873 /* The entry point is lisp_align_malloc which returns blocks of at most */
874 /* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
876 /* Use posix_memalloc if the system has it and we're using the system's
877 malloc (because our gmalloc.c routines don't have posix_memalign although
878 its memalloc could be used). */
879 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
880 #define USE_POSIX_MEMALIGN 1
883 /* BLOCK_ALIGN has to be a power of 2. */
884 #define BLOCK_ALIGN (1 << 10)
886 /* Padding to leave at the end of a malloc'd block. This is to give
887 malloc a chance to minimize the amount of memory wasted to alignment.
888 It should be tuned to the particular malloc library used.
889 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
890 posix_memalign on the other hand would ideally prefer a value of 4
891 because otherwise, there's 1020 bytes wasted between each ablocks.
892 In Emacs, testing shows that those 1020 can most of the time be
893 efficiently used by malloc to place other objects, so a value of 0 can
894 still preferable unless you have a lot of aligned blocks and virtually
896 #define BLOCK_PADDING 0
897 #define BLOCK_BYTES \
898 (BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
900 /* Internal data structures and constants. */
902 #define ABLOCKS_SIZE 16
904 /* An aligned block of memory. */
909 char payload
[BLOCK_BYTES
];
910 struct ablock
*next_free
;
912 /* `abase' is the aligned base of the ablocks. */
913 /* It is overloaded to hold the virtual `busy' field that counts
914 the number of used ablock in the parent ablocks.
915 The first ablock has the `busy' field, the others have the `abase'
916 field. To tell the difference, we assume that pointers will have
917 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
918 is used to tell whether the real base of the parent ablocks is `abase'
919 (if not, the word before the first ablock holds a pointer to the
921 struct ablocks
*abase
;
922 /* The padding of all but the last ablock is unused. The padding of
923 the last ablock in an ablocks is not allocated. */
925 char padding
[BLOCK_PADDING
];
929 /* A bunch of consecutive aligned blocks. */
932 struct ablock blocks
[ABLOCKS_SIZE
];
935 /* Size of the block requested from malloc or memalign. */
936 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
938 #define ABLOCK_ABASE(block) \
939 (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
940 ? (struct ablocks *)(block) \
943 /* Virtual `busy' field. */
944 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
946 /* Pointer to the (not necessarily aligned) malloc block. */
947 #ifdef USE_POSIX_MEMALIGN
948 #define ABLOCKS_BASE(abase) (abase)
950 #define ABLOCKS_BASE(abase) \
951 (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
954 /* The list of free ablock. */
955 static struct ablock
*free_ablock
;
957 /* Allocate an aligned block of nbytes.
958 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
959 smaller or equal to BLOCK_BYTES. */
960 static POINTER_TYPE
*
961 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
964 struct ablocks
*abase
;
966 eassert (nbytes
<= BLOCK_BYTES
);
970 #ifdef GC_MALLOC_CHECK
971 allocated_mem_type
= type
;
977 EMACS_INT aligned
; /* int gets warning casting to 64-bit pointer. */
979 #ifdef DOUG_LEA_MALLOC
980 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
981 because mapped region contents are not preserved in
983 mallopt (M_MMAP_MAX
, 0);
986 #ifdef USE_POSIX_MEMALIGN
988 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
994 base
= malloc (ABLOCKS_BYTES
);
995 abase
= ALIGN (base
, BLOCK_ALIGN
);
1000 MALLOC_UNBLOCK_INPUT
;
1004 aligned
= (base
== abase
);
1006 ((void**)abase
)[-1] = base
;
1008 #ifdef DOUG_LEA_MALLOC
1009 /* Back to a reasonable maximum of mmap'ed areas. */
1010 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1014 /* If the memory just allocated cannot be addressed thru a Lisp
1015 object's pointer, and it needs to be, that's equivalent to
1016 running out of memory. */
1017 if (type
!= MEM_TYPE_NON_LISP
)
1020 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1021 XSETCONS (tem
, end
);
1022 if ((char *) XCONS (tem
) != end
)
1024 lisp_malloc_loser
= base
;
1026 MALLOC_UNBLOCK_INPUT
;
1032 /* Initialize the blocks and put them on the free list.
1033 Is `base' was not properly aligned, we can't use the last block. */
1034 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1036 abase
->blocks
[i
].abase
= abase
;
1037 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1038 free_ablock
= &abase
->blocks
[i
];
1040 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (long) aligned
;
1042 eassert (0 == ((EMACS_UINT
)abase
) % BLOCK_ALIGN
);
1043 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1044 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1045 eassert (ABLOCKS_BASE (abase
) == base
);
1046 eassert (aligned
== (long) ABLOCKS_BUSY (abase
));
1049 abase
= ABLOCK_ABASE (free_ablock
);
1050 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (2 + (long) ABLOCKS_BUSY (abase
));
1052 free_ablock
= free_ablock
->x
.next_free
;
1054 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1055 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1056 mem_insert (val
, (char *) val
+ nbytes
, type
);
1059 MALLOC_UNBLOCK_INPUT
;
1063 eassert (0 == ((EMACS_UINT
)val
) % BLOCK_ALIGN
);
1068 lisp_align_free (POINTER_TYPE
*block
)
1070 struct ablock
*ablock
= block
;
1071 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1074 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1075 mem_delete (mem_find (block
));
1077 /* Put on free list. */
1078 ablock
->x
.next_free
= free_ablock
;
1079 free_ablock
= ablock
;
1080 /* Update busy count. */
1081 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (-2 + (long) ABLOCKS_BUSY (abase
));
1083 if (2 > (long) ABLOCKS_BUSY (abase
))
1084 { /* All the blocks are free. */
1085 int i
= 0, aligned
= (long) ABLOCKS_BUSY (abase
);
1086 struct ablock
**tem
= &free_ablock
;
1087 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1091 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1094 *tem
= (*tem
)->x
.next_free
;
1097 tem
= &(*tem
)->x
.next_free
;
1099 eassert ((aligned
& 1) == aligned
);
1100 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1101 #ifdef USE_POSIX_MEMALIGN
1102 eassert ((unsigned long)ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1104 free (ABLOCKS_BASE (abase
));
1106 MALLOC_UNBLOCK_INPUT
;
1109 /* Return a new buffer structure allocated from the heap with
1110 a call to lisp_malloc. */
1113 allocate_buffer (void)
1116 = (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
1118 b
->size
= sizeof (struct buffer
) / sizeof (EMACS_INT
);
1119 XSETPVECTYPE (b
, PVEC_BUFFER
);
1124 #ifndef SYSTEM_MALLOC
1126 /* Arranging to disable input signals while we're in malloc.
1128 This only works with GNU malloc. To help out systems which can't
1129 use GNU malloc, all the calls to malloc, realloc, and free
1130 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
1131 pair; unfortunately, we have no idea what C library functions
1132 might call malloc, so we can't really protect them unless you're
1133 using GNU malloc. Fortunately, most of the major operating systems
1134 can use GNU malloc. */
1137 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
1138 there's no need to block input around malloc. */
1140 #ifndef DOUG_LEA_MALLOC
1141 extern void * (*__malloc_hook
) (size_t, const void *);
1142 extern void * (*__realloc_hook
) (void *, size_t, const void *);
1143 extern void (*__free_hook
) (void *, const void *);
1144 /* Else declared in malloc.h, perhaps with an extra arg. */
1145 #endif /* DOUG_LEA_MALLOC */
1146 static void * (*old_malloc_hook
) (size_t, const void *);
1147 static void * (*old_realloc_hook
) (void *, size_t, const void*);
1148 static void (*old_free_hook
) (void*, const void*);
1150 /* This function is used as the hook for free to call. */
1153 emacs_blocked_free (void *ptr
, const void *ptr2
)
1157 #ifdef GC_MALLOC_CHECK
1163 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1166 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
1171 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
1175 #endif /* GC_MALLOC_CHECK */
1177 __free_hook
= old_free_hook
;
1180 /* If we released our reserve (due to running out of memory),
1181 and we have a fair amount free once again,
1182 try to set aside another reserve in case we run out once more. */
1183 if (! NILP (Vmemory_full
)
1184 /* Verify there is enough space that even with the malloc
1185 hysteresis this call won't run out again.
1186 The code here is correct as long as SPARE_MEMORY
1187 is substantially larger than the block size malloc uses. */
1188 && (bytes_used_when_full
1189 > ((bytes_used_when_reconsidered
= BYTES_USED
)
1190 + max (malloc_hysteresis
, 4) * SPARE_MEMORY
)))
1191 refill_memory_reserve ();
1193 __free_hook
= emacs_blocked_free
;
1194 UNBLOCK_INPUT_ALLOC
;
1198 /* This function is the malloc hook that Emacs uses. */
1201 emacs_blocked_malloc (size_t size
, const void *ptr
)
1206 __malloc_hook
= old_malloc_hook
;
1207 #ifdef DOUG_LEA_MALLOC
1208 /* Segfaults on my system. --lorentey */
1209 /* mallopt (M_TOP_PAD, malloc_hysteresis * 4096); */
1211 __malloc_extra_blocks
= malloc_hysteresis
;
1214 value
= (void *) malloc (size
);
1216 #ifdef GC_MALLOC_CHECK
1218 struct mem_node
*m
= mem_find (value
);
1221 fprintf (stderr
, "Malloc returned %p which is already in use\n",
1223 fprintf (stderr
, "Region in use is %p...%p, %u bytes, type %d\n",
1224 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
1229 if (!dont_register_blocks
)
1231 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
1232 allocated_mem_type
= MEM_TYPE_NON_LISP
;
1235 #endif /* GC_MALLOC_CHECK */
1237 __malloc_hook
= emacs_blocked_malloc
;
1238 UNBLOCK_INPUT_ALLOC
;
1240 /* fprintf (stderr, "%p malloc\n", value); */
1245 /* This function is the realloc hook that Emacs uses. */
1248 emacs_blocked_realloc (void *ptr
, size_t size
, const void *ptr2
)
1253 __realloc_hook
= old_realloc_hook
;
1255 #ifdef GC_MALLOC_CHECK
1258 struct mem_node
*m
= mem_find (ptr
);
1259 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1262 "Realloc of %p which wasn't allocated with malloc\n",
1270 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1272 /* Prevent malloc from registering blocks. */
1273 dont_register_blocks
= 1;
1274 #endif /* GC_MALLOC_CHECK */
1276 value
= (void *) realloc (ptr
, size
);
1278 #ifdef GC_MALLOC_CHECK
1279 dont_register_blocks
= 0;
1282 struct mem_node
*m
= mem_find (value
);
1285 fprintf (stderr
, "Realloc returns memory that is already in use\n");
1289 /* Can't handle zero size regions in the red-black tree. */
1290 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
1293 /* fprintf (stderr, "%p <- realloc\n", value); */
1294 #endif /* GC_MALLOC_CHECK */
1296 __realloc_hook
= emacs_blocked_realloc
;
1297 UNBLOCK_INPUT_ALLOC
;
1303 #ifdef HAVE_GTK_AND_PTHREAD
1304 /* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
1305 normal malloc. Some thread implementations need this as they call
1306 malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
1307 calls malloc because it is the first call, and we have an endless loop. */
1310 reset_malloc_hooks ()
1312 __free_hook
= old_free_hook
;
1313 __malloc_hook
= old_malloc_hook
;
1314 __realloc_hook
= old_realloc_hook
;
1316 #endif /* HAVE_GTK_AND_PTHREAD */
1319 /* Called from main to set up malloc to use our hooks. */
1322 uninterrupt_malloc (void)
1324 #ifdef HAVE_GTK_AND_PTHREAD
1325 #ifdef DOUG_LEA_MALLOC
1326 pthread_mutexattr_t attr
;
1328 /* GLIBC has a faster way to do this, but lets keep it portable.
1329 This is according to the Single UNIX Specification. */
1330 pthread_mutexattr_init (&attr
);
1331 pthread_mutexattr_settype (&attr
, PTHREAD_MUTEX_RECURSIVE
);
1332 pthread_mutex_init (&alloc_mutex
, &attr
);
1333 #else /* !DOUG_LEA_MALLOC */
1334 /* Some systems such as Solaris 2.6 don't have a recursive mutex,
1335 and the bundled gmalloc.c doesn't require it. */
1336 pthread_mutex_init (&alloc_mutex
, NULL
);
1337 #endif /* !DOUG_LEA_MALLOC */
1338 #endif /* HAVE_GTK_AND_PTHREAD */
1340 if (__free_hook
!= emacs_blocked_free
)
1341 old_free_hook
= __free_hook
;
1342 __free_hook
= emacs_blocked_free
;
1344 if (__malloc_hook
!= emacs_blocked_malloc
)
1345 old_malloc_hook
= __malloc_hook
;
1346 __malloc_hook
= emacs_blocked_malloc
;
1348 if (__realloc_hook
!= emacs_blocked_realloc
)
1349 old_realloc_hook
= __realloc_hook
;
1350 __realloc_hook
= emacs_blocked_realloc
;
1353 #endif /* not SYNC_INPUT */
1354 #endif /* not SYSTEM_MALLOC */
1358 /***********************************************************************
1360 ***********************************************************************/
1362 /* Number of intervals allocated in an interval_block structure.
1363 The 1020 is 1024 minus malloc overhead. */
1365 #define INTERVAL_BLOCK_SIZE \
1366 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1368 /* Intervals are allocated in chunks in form of an interval_block
1371 struct interval_block
1373 /* Place `intervals' first, to preserve alignment. */
1374 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1375 struct interval_block
*next
;
1378 /* Current interval block. Its `next' pointer points to older
1381 static struct interval_block
*interval_block
;
1383 /* Index in interval_block above of the next unused interval
1386 static int interval_block_index
;
1388 /* Number of free and live intervals. */
1390 static int total_free_intervals
, total_intervals
;
1392 /* List of free intervals. */
1394 INTERVAL interval_free_list
;
1396 /* Total number of interval blocks now in use. */
1398 static int n_interval_blocks
;
1401 /* Initialize interval allocation. */
1404 init_intervals (void)
1406 interval_block
= NULL
;
1407 interval_block_index
= INTERVAL_BLOCK_SIZE
;
1408 interval_free_list
= 0;
1409 n_interval_blocks
= 0;
1413 /* Return a new interval. */
1416 make_interval (void)
1420 /* eassert (!handling_signal); */
1424 if (interval_free_list
)
1426 val
= interval_free_list
;
1427 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1431 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1433 register struct interval_block
*newi
;
1435 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
1438 newi
->next
= interval_block
;
1439 interval_block
= newi
;
1440 interval_block_index
= 0;
1441 n_interval_blocks
++;
1443 val
= &interval_block
->intervals
[interval_block_index
++];
1446 MALLOC_UNBLOCK_INPUT
;
1448 consing_since_gc
+= sizeof (struct interval
);
1450 RESET_INTERVAL (val
);
1456 /* Mark Lisp objects in interval I. */
1459 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1461 eassert (!i
->gcmarkbit
); /* Intervals are never shared. */
1463 mark_object (i
->plist
);
1467 /* Mark the interval tree rooted in TREE. Don't call this directly;
1468 use the macro MARK_INTERVAL_TREE instead. */
1471 mark_interval_tree (register INTERVAL tree
)
1473 /* No need to test if this tree has been marked already; this
1474 function is always called through the MARK_INTERVAL_TREE macro,
1475 which takes care of that. */
1477 traverse_intervals_noorder (tree
, mark_interval
, Qnil
);
1481 /* Mark the interval tree rooted in I. */
1483 #define MARK_INTERVAL_TREE(i) \
1485 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
1486 mark_interval_tree (i); \
1490 #define UNMARK_BALANCE_INTERVALS(i) \
1492 if (! NULL_INTERVAL_P (i)) \
1493 (i) = balance_intervals (i); \
1497 /* Number support. If USE_LISP_UNION_TYPE is in effect, we
1498 can't create number objects in macros. */
1506 obj
.s
.type
= Lisp_Int
;
1511 /***********************************************************************
1513 ***********************************************************************/
1515 /* Lisp_Strings are allocated in string_block structures. When a new
1516 string_block is allocated, all the Lisp_Strings it contains are
1517 added to a free-list string_free_list. When a new Lisp_String is
1518 needed, it is taken from that list. During the sweep phase of GC,
1519 string_blocks that are entirely free are freed, except two which
1522 String data is allocated from sblock structures. Strings larger
1523 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1524 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1526 Sblocks consist internally of sdata structures, one for each
1527 Lisp_String. The sdata structure points to the Lisp_String it
1528 belongs to. The Lisp_String points back to the `u.data' member of
1529 its sdata structure.
1531 When a Lisp_String is freed during GC, it is put back on
1532 string_free_list, and its `data' member and its sdata's `string'
1533 pointer is set to null. The size of the string is recorded in the
1534 `u.nbytes' member of the sdata. So, sdata structures that are no
1535 longer used, can be easily recognized, and it's easy to compact the
1536 sblocks of small strings which we do in compact_small_strings. */
1538 /* Size in bytes of an sblock structure used for small strings. This
1539 is 8192 minus malloc overhead. */
1541 #define SBLOCK_SIZE 8188
1543 /* Strings larger than this are considered large strings. String data
1544 for large strings is allocated from individual sblocks. */
1546 #define LARGE_STRING_BYTES 1024
1548 /* Structure describing string memory sub-allocated from an sblock.
1549 This is where the contents of Lisp strings are stored. */
1553 /* Back-pointer to the string this sdata belongs to. If null, this
1554 structure is free, and the NBYTES member of the union below
1555 contains the string's byte size (the same value that STRING_BYTES
1556 would return if STRING were non-null). If non-null, STRING_BYTES
1557 (STRING) is the size of the data, and DATA contains the string's
1559 struct Lisp_String
*string
;
1561 #ifdef GC_CHECK_STRING_BYTES
1564 unsigned char data
[1];
1566 #define SDATA_NBYTES(S) (S)->nbytes
1567 #define SDATA_DATA(S) (S)->data
1569 #else /* not GC_CHECK_STRING_BYTES */
1573 /* When STRING in non-null. */
1574 unsigned char data
[1];
1576 /* When STRING is null. */
1581 #define SDATA_NBYTES(S) (S)->u.nbytes
1582 #define SDATA_DATA(S) (S)->u.data
1584 #endif /* not GC_CHECK_STRING_BYTES */
1588 /* Structure describing a block of memory which is sub-allocated to
1589 obtain string data memory for strings. Blocks for small strings
1590 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1591 as large as needed. */
1596 struct sblock
*next
;
1598 /* Pointer to the next free sdata block. This points past the end
1599 of the sblock if there isn't any space left in this block. */
1600 struct sdata
*next_free
;
1602 /* Start of data. */
1603 struct sdata first_data
;
1606 /* Number of Lisp strings in a string_block structure. The 1020 is
1607 1024 minus malloc overhead. */
1609 #define STRING_BLOCK_SIZE \
1610 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1612 /* Structure describing a block from which Lisp_String structures
1617 /* Place `strings' first, to preserve alignment. */
1618 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1619 struct string_block
*next
;
1622 /* Head and tail of the list of sblock structures holding Lisp string
1623 data. We always allocate from current_sblock. The NEXT pointers
1624 in the sblock structures go from oldest_sblock to current_sblock. */
1626 static struct sblock
*oldest_sblock
, *current_sblock
;
1628 /* List of sblocks for large strings. */
1630 static struct sblock
*large_sblocks
;
1632 /* List of string_block structures, and how many there are. */
1634 static struct string_block
*string_blocks
;
1635 static int n_string_blocks
;
1637 /* Free-list of Lisp_Strings. */
1639 static struct Lisp_String
*string_free_list
;
1641 /* Number of live and free Lisp_Strings. */
1643 static int total_strings
, total_free_strings
;
1645 /* Number of bytes used by live strings. */
1647 static EMACS_INT total_string_size
;
1649 /* Given a pointer to a Lisp_String S which is on the free-list
1650 string_free_list, return a pointer to its successor in the
1653 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1655 /* Return a pointer to the sdata structure belonging to Lisp string S.
1656 S must be live, i.e. S->data must not be null. S->data is actually
1657 a pointer to the `u.data' member of its sdata structure; the
1658 structure starts at a constant offset in front of that. */
1660 #ifdef GC_CHECK_STRING_BYTES
1662 #define SDATA_OF_STRING(S) \
1663 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
1664 - sizeof (EMACS_INT)))
1666 #else /* not GC_CHECK_STRING_BYTES */
1668 #define SDATA_OF_STRING(S) \
1669 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
1671 #endif /* not GC_CHECK_STRING_BYTES */
1674 #ifdef GC_CHECK_STRING_OVERRUN
1676 /* We check for overrun in string data blocks by appending a small
1677 "cookie" after each allocated string data block, and check for the
1678 presence of this cookie during GC. */
1680 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1681 static char string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1682 { 0xde, 0xad, 0xbe, 0xef };
1685 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1688 /* Value is the size of an sdata structure large enough to hold NBYTES
1689 bytes of string data. The value returned includes a terminating
1690 NUL byte, the size of the sdata structure, and padding. */
1692 #ifdef GC_CHECK_STRING_BYTES
1694 #define SDATA_SIZE(NBYTES) \
1695 ((sizeof (struct Lisp_String *) \
1697 + sizeof (EMACS_INT) \
1698 + sizeof (EMACS_INT) - 1) \
1699 & ~(sizeof (EMACS_INT) - 1))
1701 #else /* not GC_CHECK_STRING_BYTES */
1703 #define SDATA_SIZE(NBYTES) \
1704 ((sizeof (struct Lisp_String *) \
1706 + sizeof (EMACS_INT) - 1) \
1707 & ~(sizeof (EMACS_INT) - 1))
1709 #endif /* not GC_CHECK_STRING_BYTES */
1711 /* Extra bytes to allocate for each string. */
1713 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1715 /* Initialize string allocation. Called from init_alloc_once. */
1720 total_strings
= total_free_strings
= total_string_size
= 0;
1721 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1722 string_blocks
= NULL
;
1723 n_string_blocks
= 0;
1724 string_free_list
= NULL
;
1725 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1726 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1730 #ifdef GC_CHECK_STRING_BYTES
1732 static int check_string_bytes_count
;
1734 static void check_string_bytes (int);
1735 static void check_sblock (struct sblock
*);
1737 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1740 /* Like GC_STRING_BYTES, but with debugging check. */
1743 string_bytes (struct Lisp_String
*s
)
1746 (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 long)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
*
1841 allocate_string (void)
1843 struct Lisp_String
*s
;
1845 /* eassert (!handling_signal); */
1849 /* If the free-list is empty, allocate a new string_block, and
1850 add all the Lisp_Strings in it to the free-list. */
1851 if (string_free_list
== NULL
)
1853 struct string_block
*b
;
1856 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1857 memset (b
, 0, sizeof *b
);
1858 b
->next
= string_blocks
;
1862 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1865 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1866 string_free_list
= s
;
1869 total_free_strings
+= STRING_BLOCK_SIZE
;
1872 check_string_free_list ();
1874 /* Pop a Lisp_String off the free-list. */
1875 s
= string_free_list
;
1876 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1878 MALLOC_UNBLOCK_INPUT
;
1880 /* Probably not strictly necessary, but play it safe. */
1881 memset (s
, 0, sizeof *s
);
1883 --total_free_strings
;
1886 consing_since_gc
+= sizeof *s
;
1888 #ifdef GC_CHECK_STRING_BYTES
1889 if (!noninteractive
)
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 (struct Lisp_String
*s
,
1913 EMACS_INT nchars
, EMACS_INT nbytes
)
1915 struct sdata
*data
, *old_data
;
1917 EMACS_INT needed
, old_nbytes
;
1919 /* Determine the number of bytes needed to store NBYTES bytes
1921 needed
= SDATA_SIZE (nbytes
);
1922 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
1923 old_nbytes
= GC_STRING_BYTES (s
);
1927 if (nbytes
> LARGE_STRING_BYTES
)
1929 size_t size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1931 #ifdef DOUG_LEA_MALLOC
1932 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1933 because mapped region contents are not preserved in
1936 In case you think of allowing it in a dumped Emacs at the
1937 cost of not being able to re-dump, there's another reason:
1938 mmap'ed data typically have an address towards the top of the
1939 address space, which won't fit into an EMACS_INT (at least on
1940 32-bit systems with the current tagging scheme). --fx */
1941 mallopt (M_MMAP_MAX
, 0);
1944 b
= (struct sblock
*) lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1946 #ifdef DOUG_LEA_MALLOC
1947 /* Back to a reasonable maximum of mmap'ed areas. */
1948 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1951 b
->next_free
= &b
->first_data
;
1952 b
->first_data
.string
= NULL
;
1953 b
->next
= large_sblocks
;
1956 else if (current_sblock
== NULL
1957 || (((char *) current_sblock
+ SBLOCK_SIZE
1958 - (char *) current_sblock
->next_free
)
1959 < (needed
+ GC_STRING_EXTRA
)))
1961 /* Not enough room in the current sblock. */
1962 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1963 b
->next_free
= &b
->first_data
;
1964 b
->first_data
.string
= NULL
;
1968 current_sblock
->next
= b
;
1976 data
= b
->next_free
;
1977 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1979 MALLOC_UNBLOCK_INPUT
;
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 memcpy (data
+ needed
, string_overrun_cookie
, GC_STRING_OVERRUN_COOKIE_SIZE
);
1993 /* If S had already data assigned, mark that as free by setting its
1994 string back-pointer to null, and recording the size of the data
1998 SDATA_NBYTES (old_data
) = old_nbytes
;
1999 old_data
->string
= NULL
;
2002 consing_since_gc
+= needed
;
2006 /* Sweep and compact strings. */
2009 sweep_strings (void)
2011 struct string_block
*b
, *next
;
2012 struct string_block
*live_blocks
= NULL
;
2014 string_free_list
= NULL
;
2015 total_strings
= total_free_strings
= 0;
2016 total_string_size
= 0;
2018 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2019 for (b
= string_blocks
; b
; b
= next
)
2022 struct Lisp_String
*free_list_before
= string_free_list
;
2026 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
2028 struct Lisp_String
*s
= b
->strings
+ i
;
2032 /* String was not on free-list before. */
2033 if (STRING_MARKED_P (s
))
2035 /* String is live; unmark it and its intervals. */
2038 if (!NULL_INTERVAL_P (s
->intervals
))
2039 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2042 total_string_size
+= STRING_BYTES (s
);
2046 /* String is dead. Put it on the free-list. */
2047 struct sdata
*data
= SDATA_OF_STRING (s
);
2049 /* Save the size of S in its sdata so that we know
2050 how large that is. Reset the sdata's string
2051 back-pointer so that we know it's free. */
2052 #ifdef GC_CHECK_STRING_BYTES
2053 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
2056 data
->u
.nbytes
= GC_STRING_BYTES (s
);
2058 data
->string
= NULL
;
2060 /* Reset the strings's `data' member so that we
2064 /* Put the string on the free-list. */
2065 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2066 string_free_list
= s
;
2072 /* S was on the free-list before. Put it there again. */
2073 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2074 string_free_list
= s
;
2079 /* Free blocks that contain free Lisp_Strings only, except
2080 the first two of them. */
2081 if (nfree
== STRING_BLOCK_SIZE
2082 && total_free_strings
> STRING_BLOCK_SIZE
)
2086 string_free_list
= free_list_before
;
2090 total_free_strings
+= nfree
;
2091 b
->next
= live_blocks
;
2096 check_string_free_list ();
2098 string_blocks
= live_blocks
;
2099 free_large_strings ();
2100 compact_small_strings ();
2102 check_string_free_list ();
2106 /* Free dead large strings. */
2109 free_large_strings (void)
2111 struct sblock
*b
, *next
;
2112 struct sblock
*live_blocks
= NULL
;
2114 for (b
= large_sblocks
; b
; b
= next
)
2118 if (b
->first_data
.string
== NULL
)
2122 b
->next
= live_blocks
;
2127 large_sblocks
= live_blocks
;
2131 /* Compact data of small strings. Free sblocks that don't contain
2132 data of live strings after compaction. */
2135 compact_small_strings (void)
2137 struct sblock
*b
, *tb
, *next
;
2138 struct sdata
*from
, *to
, *end
, *tb_end
;
2139 struct sdata
*to_end
, *from_end
;
2141 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2142 to, and TB_END is the end of TB. */
2144 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2145 to
= &tb
->first_data
;
2147 /* Step through the blocks from the oldest to the youngest. We
2148 expect that old blocks will stabilize over time, so that less
2149 copying will happen this way. */
2150 for (b
= oldest_sblock
; b
; b
= b
->next
)
2153 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2155 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
2157 /* Compute the next FROM here because copying below may
2158 overwrite data we need to compute it. */
2161 #ifdef GC_CHECK_STRING_BYTES
2162 /* Check that the string size recorded in the string is the
2163 same as the one recorded in the sdata structure. */
2165 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
2167 #endif /* GC_CHECK_STRING_BYTES */
2170 nbytes
= GC_STRING_BYTES (from
->string
);
2172 nbytes
= SDATA_NBYTES (from
);
2174 if (nbytes
> LARGE_STRING_BYTES
)
2177 nbytes
= SDATA_SIZE (nbytes
);
2178 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
2180 #ifdef GC_CHECK_STRING_OVERRUN
2181 if (memcmp (string_overrun_cookie
,
2182 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
2183 GC_STRING_OVERRUN_COOKIE_SIZE
))
2187 /* FROM->string non-null means it's alive. Copy its data. */
2190 /* If TB is full, proceed with the next sblock. */
2191 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2192 if (to_end
> tb_end
)
2196 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2197 to
= &tb
->first_data
;
2198 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2201 /* Copy, and update the string's `data' pointer. */
2204 xassert (tb
!= b
|| to
<= from
);
2205 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
2206 to
->string
->data
= SDATA_DATA (to
);
2209 /* Advance past the sdata we copied to. */
2215 /* The rest of the sblocks following TB don't contain live data, so
2216 we can free them. */
2217 for (b
= tb
->next
; b
; b
= next
)
2225 current_sblock
= tb
;
2229 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2230 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2231 LENGTH must be an integer.
2232 INIT must be an integer that represents a character. */)
2233 (Lisp_Object length
, Lisp_Object init
)
2235 register Lisp_Object val
;
2236 register unsigned char *p
, *end
;
2240 CHECK_NATNUM (length
);
2241 CHECK_NUMBER (init
);
2244 if (ASCII_CHAR_P (c
))
2246 nbytes
= XINT (length
);
2247 val
= make_uninit_string (nbytes
);
2249 end
= p
+ SCHARS (val
);
2255 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2256 int len
= CHAR_STRING (c
, str
);
2257 EMACS_INT string_len
= XINT (length
);
2259 if (string_len
> MOST_POSITIVE_FIXNUM
/ len
)
2260 error ("Maximum string size exceeded");
2261 nbytes
= len
* string_len
;
2262 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2267 memcpy (p
, str
, len
);
2277 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2278 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2279 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2280 (Lisp_Object length
, Lisp_Object init
)
2282 register Lisp_Object val
;
2283 struct Lisp_Bool_Vector
*p
;
2285 EMACS_INT length_in_chars
, length_in_elts
;
2288 CHECK_NATNUM (length
);
2290 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2292 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2293 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2294 / BOOL_VECTOR_BITS_PER_CHAR
);
2296 /* We must allocate one more elements than LENGTH_IN_ELTS for the
2297 slot `size' of the struct Lisp_Bool_Vector. */
2298 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
2300 /* Get rid of any bits that would cause confusion. */
2301 XVECTOR (val
)->size
= 0; /* No Lisp_Object to trace in there. */
2302 /* Use XVECTOR (val) rather than `p' because p->size is not TRT. */
2303 XSETPVECTYPE (XVECTOR (val
), PVEC_BOOL_VECTOR
);
2305 p
= XBOOL_VECTOR (val
);
2306 p
->size
= XFASTINT (length
);
2308 real_init
= (NILP (init
) ? 0 : -1);
2309 for (i
= 0; i
< length_in_chars
; i
++)
2310 p
->data
[i
] = real_init
;
2312 /* Clear the extraneous bits in the last byte. */
2313 if (XINT (length
) != length_in_chars
* BOOL_VECTOR_BITS_PER_CHAR
)
2314 p
->data
[length_in_chars
- 1]
2315 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2321 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2322 of characters from the contents. This string may be unibyte or
2323 multibyte, depending on the contents. */
2326 make_string (const char *contents
, EMACS_INT nbytes
)
2328 register Lisp_Object val
;
2329 EMACS_INT nchars
, multibyte_nbytes
;
2331 parse_str_as_multibyte (contents
, nbytes
, &nchars
, &multibyte_nbytes
);
2332 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2333 /* CONTENTS contains no multibyte sequences or contains an invalid
2334 multibyte sequence. We must make unibyte string. */
2335 val
= make_unibyte_string (contents
, nbytes
);
2337 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2342 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2345 make_unibyte_string (const char *contents
, EMACS_INT length
)
2347 register Lisp_Object val
;
2348 val
= make_uninit_string (length
);
2349 memcpy (SDATA (val
), contents
, length
);
2350 STRING_SET_UNIBYTE (val
);
2355 /* Make a multibyte string from NCHARS characters occupying NBYTES
2356 bytes at CONTENTS. */
2359 make_multibyte_string (const char *contents
,
2360 EMACS_INT nchars
, EMACS_INT nbytes
)
2362 register Lisp_Object val
;
2363 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2364 memcpy (SDATA (val
), contents
, nbytes
);
2369 /* Make a string from NCHARS characters occupying NBYTES bytes at
2370 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2373 make_string_from_bytes (const char *contents
,
2374 EMACS_INT nchars
, EMACS_INT nbytes
)
2376 register Lisp_Object val
;
2377 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2378 memcpy (SDATA (val
), contents
, nbytes
);
2379 if (SBYTES (val
) == SCHARS (val
))
2380 STRING_SET_UNIBYTE (val
);
2385 /* Make a string from NCHARS characters occupying NBYTES bytes at
2386 CONTENTS. The argument MULTIBYTE controls whether to label the
2387 string as multibyte. If NCHARS is negative, it counts the number of
2388 characters by itself. */
2391 make_specified_string (const char *contents
,
2392 EMACS_INT nchars
, EMACS_INT nbytes
, int multibyte
)
2394 register Lisp_Object val
;
2399 nchars
= multibyte_chars_in_text (contents
, nbytes
);
2403 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2404 memcpy (SDATA (val
), contents
, nbytes
);
2406 STRING_SET_UNIBYTE (val
);
2411 /* Make a string from the data at STR, treating it as multibyte if the
2415 build_string (const char *str
)
2417 return make_string (str
, strlen (str
));
2421 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2422 occupying LENGTH bytes. */
2425 make_uninit_string (EMACS_INT length
)
2430 return empty_unibyte_string
;
2431 val
= make_uninit_multibyte_string (length
, length
);
2432 STRING_SET_UNIBYTE (val
);
2437 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2438 which occupy NBYTES bytes. */
2441 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2444 struct Lisp_String
*s
;
2449 return empty_multibyte_string
;
2451 s
= allocate_string ();
2452 allocate_string_data (s
, nchars
, nbytes
);
2453 XSETSTRING (string
, s
);
2454 string_chars_consed
+= nbytes
;
2460 /***********************************************************************
2462 ***********************************************************************/
2464 /* We store float cells inside of float_blocks, allocating a new
2465 float_block with malloc whenever necessary. Float cells reclaimed
2466 by GC are put on a free list to be reallocated before allocating
2467 any new float cells from the latest float_block. */
2469 #define FLOAT_BLOCK_SIZE \
2470 (((BLOCK_BYTES - sizeof (struct float_block *) \
2471 /* The compiler might add padding at the end. */ \
2472 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2473 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2475 #define GETMARKBIT(block,n) \
2476 (((block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2477 >> ((n) % (sizeof(int) * CHAR_BIT))) \
2480 #define SETMARKBIT(block,n) \
2481 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2482 |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
2484 #define UNSETMARKBIT(block,n) \
2485 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2486 &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
2488 #define FLOAT_BLOCK(fptr) \
2489 ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2491 #define FLOAT_INDEX(fptr) \
2492 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2496 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2497 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2498 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2499 struct float_block
*next
;
2502 #define FLOAT_MARKED_P(fptr) \
2503 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2505 #define FLOAT_MARK(fptr) \
2506 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2508 #define FLOAT_UNMARK(fptr) \
2509 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2511 /* Current float_block. */
2513 struct float_block
*float_block
;
2515 /* Index of first unused Lisp_Float in the current float_block. */
2517 int float_block_index
;
2519 /* Total number of float blocks now in use. */
2523 /* Free-list of Lisp_Floats. */
2525 struct Lisp_Float
*float_free_list
;
2528 /* Initialize float allocation. */
2534 float_block_index
= FLOAT_BLOCK_SIZE
; /* Force alloc of new float_block. */
2535 float_free_list
= 0;
2540 /* Return a new float object with value FLOAT_VALUE. */
2543 make_float (double float_value
)
2545 register Lisp_Object val
;
2547 /* eassert (!handling_signal); */
2551 if (float_free_list
)
2553 /* We use the data field for chaining the free list
2554 so that we won't use the same field that has the mark bit. */
2555 XSETFLOAT (val
, float_free_list
);
2556 float_free_list
= float_free_list
->u
.chain
;
2560 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2562 register struct float_block
*new;
2564 new = (struct float_block
*) lisp_align_malloc (sizeof *new,
2566 new->next
= float_block
;
2567 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2569 float_block_index
= 0;
2572 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2573 float_block_index
++;
2576 MALLOC_UNBLOCK_INPUT
;
2578 XFLOAT_INIT (val
, float_value
);
2579 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2580 consing_since_gc
+= sizeof (struct Lisp_Float
);
2587 /***********************************************************************
2589 ***********************************************************************/
2591 /* We store cons cells inside of cons_blocks, allocating a new
2592 cons_block with malloc whenever necessary. Cons cells reclaimed by
2593 GC are put on a free list to be reallocated before allocating
2594 any new cons cells from the latest cons_block. */
2596 #define CONS_BLOCK_SIZE \
2597 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2598 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2600 #define CONS_BLOCK(fptr) \
2601 ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2603 #define CONS_INDEX(fptr) \
2604 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2608 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2609 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2610 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2611 struct cons_block
*next
;
2614 #define CONS_MARKED_P(fptr) \
2615 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2617 #define CONS_MARK(fptr) \
2618 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2620 #define CONS_UNMARK(fptr) \
2621 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2623 /* Current cons_block. */
2625 struct cons_block
*cons_block
;
2627 /* Index of first unused Lisp_Cons in the current block. */
2629 int cons_block_index
;
2631 /* Free-list of Lisp_Cons structures. */
2633 struct Lisp_Cons
*cons_free_list
;
2635 /* Total number of cons blocks now in use. */
2637 static int n_cons_blocks
;
2640 /* Initialize cons allocation. */
2646 cons_block_index
= CONS_BLOCK_SIZE
; /* Force alloc of new cons_block. */
2652 /* Explicitly free a cons cell by putting it on the free-list. */
2655 free_cons (struct Lisp_Cons
*ptr
)
2657 ptr
->u
.chain
= cons_free_list
;
2661 cons_free_list
= ptr
;
2664 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2665 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2666 (Lisp_Object car
, Lisp_Object cdr
)
2668 register Lisp_Object val
;
2670 /* eassert (!handling_signal); */
2676 /* We use the cdr for chaining the free list
2677 so that we won't use the same field that has the mark bit. */
2678 XSETCONS (val
, cons_free_list
);
2679 cons_free_list
= cons_free_list
->u
.chain
;
2683 if (cons_block_index
== CONS_BLOCK_SIZE
)
2685 register struct cons_block
*new;
2686 new = (struct cons_block
*) lisp_align_malloc (sizeof *new,
2688 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2689 new->next
= cons_block
;
2691 cons_block_index
= 0;
2694 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2698 MALLOC_UNBLOCK_INPUT
;
2702 eassert (!CONS_MARKED_P (XCONS (val
)));
2703 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2704 cons_cells_consed
++;
2708 /* Get an error now if there's any junk in the cons free list. */
2710 check_cons_list (void)
2712 #ifdef GC_CHECK_CONS_LIST
2713 struct Lisp_Cons
*tail
= cons_free_list
;
2716 tail
= tail
->u
.chain
;
2720 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2723 list1 (Lisp_Object arg1
)
2725 return Fcons (arg1
, Qnil
);
2729 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2731 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2736 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2738 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2743 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2745 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2750 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2752 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2753 Fcons (arg5
, Qnil
)))));
2757 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2758 doc
: /* Return a newly created list with specified arguments as elements.
2759 Any number of arguments, even zero arguments, are allowed.
2760 usage: (list &rest OBJECTS) */)
2761 (int nargs
, register Lisp_Object
*args
)
2763 register Lisp_Object val
;
2769 val
= Fcons (args
[nargs
], val
);
2775 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2776 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2777 (register Lisp_Object length
, Lisp_Object init
)
2779 register Lisp_Object val
;
2780 register EMACS_INT size
;
2782 CHECK_NATNUM (length
);
2783 size
= XFASTINT (length
);
2788 val
= Fcons (init
, val
);
2793 val
= Fcons (init
, val
);
2798 val
= Fcons (init
, val
);
2803 val
= Fcons (init
, val
);
2808 val
= Fcons (init
, val
);
2823 /***********************************************************************
2825 ***********************************************************************/
2827 /* Singly-linked list of all vectors. */
2829 static struct Lisp_Vector
*all_vectors
;
2831 /* Total number of vector-like objects now in use. */
2833 static int n_vectors
;
2836 /* Value is a pointer to a newly allocated Lisp_Vector structure
2837 with room for LEN Lisp_Objects. */
2839 static struct Lisp_Vector
*
2840 allocate_vectorlike (EMACS_INT len
)
2842 struct Lisp_Vector
*p
;
2847 #ifdef DOUG_LEA_MALLOC
2848 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2849 because mapped region contents are not preserved in
2851 mallopt (M_MMAP_MAX
, 0);
2854 /* This gets triggered by code which I haven't bothered to fix. --Stef */
2855 /* eassert (!handling_signal); */
2857 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
2858 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, MEM_TYPE_VECTORLIKE
);
2860 #ifdef DOUG_LEA_MALLOC
2861 /* Back to a reasonable maximum of mmap'ed areas. */
2862 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2865 consing_since_gc
+= nbytes
;
2866 vector_cells_consed
+= len
;
2868 p
->next
= all_vectors
;
2871 MALLOC_UNBLOCK_INPUT
;
2878 /* Allocate a vector with NSLOTS slots. */
2880 struct Lisp_Vector
*
2881 allocate_vector (EMACS_INT nslots
)
2883 struct Lisp_Vector
*v
= allocate_vectorlike (nslots
);
2889 /* Allocate other vector-like structures. */
2891 struct Lisp_Vector
*
2892 allocate_pseudovector (int memlen
, int lisplen
, EMACS_INT tag
)
2894 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
2897 /* Only the first lisplen slots will be traced normally by the GC. */
2899 for (i
= 0; i
< lisplen
; ++i
)
2900 v
->contents
[i
] = Qnil
;
2902 XSETPVECTYPE (v
, tag
); /* Add the appropriate tag. */
2906 struct Lisp_Hash_Table
*
2907 allocate_hash_table (void)
2909 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
2914 allocate_window (void)
2916 return ALLOCATE_PSEUDOVECTOR(struct window
, current_matrix
, PVEC_WINDOW
);
2921 allocate_terminal (void)
2923 struct terminal
*t
= ALLOCATE_PSEUDOVECTOR (struct terminal
,
2924 next_terminal
, PVEC_TERMINAL
);
2925 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
2926 memset (&t
->next_terminal
, 0,
2927 (char*) (t
+ 1) - (char*) &t
->next_terminal
);
2933 allocate_frame (void)
2935 struct frame
*f
= ALLOCATE_PSEUDOVECTOR (struct frame
,
2936 face_cache
, PVEC_FRAME
);
2937 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
2938 memset (&f
->face_cache
, 0,
2939 (char *) (f
+ 1) - (char *) &f
->face_cache
);
2944 struct Lisp_Process
*
2945 allocate_process (void)
2947 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
2951 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
2952 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
2953 See also the function `vector'. */)
2954 (register Lisp_Object length
, Lisp_Object init
)
2957 register EMACS_INT sizei
;
2958 register EMACS_INT index
;
2959 register struct Lisp_Vector
*p
;
2961 CHECK_NATNUM (length
);
2962 sizei
= XFASTINT (length
);
2964 p
= allocate_vector (sizei
);
2965 for (index
= 0; index
< sizei
; index
++)
2966 p
->contents
[index
] = init
;
2968 XSETVECTOR (vector
, p
);
2973 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
2974 doc
: /* Return a newly created vector with specified arguments as elements.
2975 Any number of arguments, even zero arguments, are allowed.
2976 usage: (vector &rest OBJECTS) */)
2977 (register int nargs
, Lisp_Object
*args
)
2979 register Lisp_Object len
, val
;
2981 register struct Lisp_Vector
*p
;
2983 XSETFASTINT (len
, nargs
);
2984 val
= Fmake_vector (len
, Qnil
);
2986 for (index
= 0; index
< nargs
; index
++)
2987 p
->contents
[index
] = args
[index
];
2992 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
2993 doc
: /* Create a byte-code object with specified arguments as elements.
2994 The arguments should be the arglist, bytecode-string, constant vector,
2995 stack size, (optional) doc string, and (optional) interactive spec.
2996 The first four arguments are required; at most six have any
2998 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
2999 (register int nargs
, Lisp_Object
*args
)
3001 register Lisp_Object len
, val
;
3003 register struct Lisp_Vector
*p
;
3005 XSETFASTINT (len
, nargs
);
3006 if (!NILP (Vpurify_flag
))
3007 val
= make_pure_vector ((EMACS_INT
) nargs
);
3009 val
= Fmake_vector (len
, Qnil
);
3011 if (nargs
> 1 && STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
3012 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3013 earlier because they produced a raw 8-bit string for byte-code
3014 and now such a byte-code string is loaded as multibyte while
3015 raw 8-bit characters converted to multibyte form. Thus, now we
3016 must convert them back to the original unibyte form. */
3017 args
[1] = Fstring_as_unibyte (args
[1]);
3020 for (index
= 0; index
< nargs
; index
++)
3022 if (!NILP (Vpurify_flag
))
3023 args
[index
] = Fpurecopy (args
[index
]);
3024 p
->contents
[index
] = args
[index
];
3026 XSETPVECTYPE (p
, PVEC_COMPILED
);
3027 XSETCOMPILED (val
, p
);
3033 /***********************************************************************
3035 ***********************************************************************/
3037 /* Each symbol_block is just under 1020 bytes long, since malloc
3038 really allocates in units of powers of two and uses 4 bytes for its
3041 #define SYMBOL_BLOCK_SIZE \
3042 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
3046 /* Place `symbols' first, to preserve alignment. */
3047 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3048 struct symbol_block
*next
;
3051 /* Current symbol block and index of first unused Lisp_Symbol
3054 static struct symbol_block
*symbol_block
;
3055 static int symbol_block_index
;
3057 /* List of free symbols. */
3059 static struct Lisp_Symbol
*symbol_free_list
;
3061 /* Total number of symbol blocks now in use. */
3063 static int n_symbol_blocks
;
3066 /* Initialize symbol allocation. */
3071 symbol_block
= NULL
;
3072 symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3073 symbol_free_list
= 0;
3074 n_symbol_blocks
= 0;
3078 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3079 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3080 Its value and function definition are void, and its property list is nil. */)
3083 register Lisp_Object val
;
3084 register struct Lisp_Symbol
*p
;
3086 CHECK_STRING (name
);
3088 /* eassert (!handling_signal); */
3092 if (symbol_free_list
)
3094 XSETSYMBOL (val
, symbol_free_list
);
3095 symbol_free_list
= symbol_free_list
->next
;
3099 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3101 struct symbol_block
*new;
3102 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
3104 new->next
= symbol_block
;
3106 symbol_block_index
= 0;
3109 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
]);
3110 symbol_block_index
++;
3113 MALLOC_UNBLOCK_INPUT
;
3118 p
->redirect
= SYMBOL_PLAINVAL
;
3119 SET_SYMBOL_VAL (p
, Qunbound
);
3120 p
->function
= Qunbound
;
3123 p
->interned
= SYMBOL_UNINTERNED
;
3125 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3132 /***********************************************************************
3133 Marker (Misc) Allocation
3134 ***********************************************************************/
3136 /* Allocation of markers and other objects that share that structure.
3137 Works like allocation of conses. */
3139 #define MARKER_BLOCK_SIZE \
3140 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
3144 /* Place `markers' first, to preserve alignment. */
3145 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3146 struct marker_block
*next
;
3149 static struct marker_block
*marker_block
;
3150 static int marker_block_index
;
3152 static union Lisp_Misc
*marker_free_list
;
3154 /* Total number of marker blocks now in use. */
3156 static int n_marker_blocks
;
3161 marker_block
= NULL
;
3162 marker_block_index
= MARKER_BLOCK_SIZE
;
3163 marker_free_list
= 0;
3164 n_marker_blocks
= 0;
3167 /* Return a newly allocated Lisp_Misc object, with no substructure. */
3170 allocate_misc (void)
3174 /* eassert (!handling_signal); */
3178 if (marker_free_list
)
3180 XSETMISC (val
, marker_free_list
);
3181 marker_free_list
= marker_free_list
->u_free
.chain
;
3185 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3187 struct marker_block
*new;
3188 new = (struct marker_block
*) lisp_malloc (sizeof *new,
3190 new->next
= marker_block
;
3192 marker_block_index
= 0;
3194 total_free_markers
+= MARKER_BLOCK_SIZE
;
3196 XSETMISC (val
, &marker_block
->markers
[marker_block_index
]);
3197 marker_block_index
++;
3200 MALLOC_UNBLOCK_INPUT
;
3202 --total_free_markers
;
3203 consing_since_gc
+= sizeof (union Lisp_Misc
);
3204 misc_objects_consed
++;
3205 XMISCANY (val
)->gcmarkbit
= 0;
3209 /* Free a Lisp_Misc object */
3212 free_misc (Lisp_Object misc
)
3214 XMISCTYPE (misc
) = Lisp_Misc_Free
;
3215 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3216 marker_free_list
= XMISC (misc
);
3218 total_free_markers
++;
3221 /* Return a Lisp_Misc_Save_Value object containing POINTER and
3222 INTEGER. This is used to package C values to call record_unwind_protect.
3223 The unwind function can get the C values back using XSAVE_VALUE. */
3226 make_save_value (void *pointer
, int integer
)
3228 register Lisp_Object val
;
3229 register struct Lisp_Save_Value
*p
;
3231 val
= allocate_misc ();
3232 XMISCTYPE (val
) = Lisp_Misc_Save_Value
;
3233 p
= XSAVE_VALUE (val
);
3234 p
->pointer
= pointer
;
3235 p
->integer
= integer
;
3240 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3241 doc
: /* Return a newly allocated marker which does not point at any place. */)
3244 register Lisp_Object val
;
3245 register struct Lisp_Marker
*p
;
3247 val
= allocate_misc ();
3248 XMISCTYPE (val
) = Lisp_Misc_Marker
;
3254 p
->insertion_type
= 0;
3258 /* Put MARKER back on the free list after using it temporarily. */
3261 free_marker (Lisp_Object marker
)
3263 unchain_marker (XMARKER (marker
));
3268 /* Return a newly created vector or string with specified arguments as
3269 elements. If all the arguments are characters that can fit
3270 in a string of events, make a string; otherwise, make a vector.
3272 Any number of arguments, even zero arguments, are allowed. */
3275 make_event_array (register int nargs
, Lisp_Object
*args
)
3279 for (i
= 0; i
< nargs
; i
++)
3280 /* The things that fit in a string
3281 are characters that are in 0...127,
3282 after discarding the meta bit and all the bits above it. */
3283 if (!INTEGERP (args
[i
])
3284 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3285 return Fvector (nargs
, args
);
3287 /* Since the loop exited, we know that all the things in it are
3288 characters, so we can make a string. */
3292 result
= Fmake_string (make_number (nargs
), make_number (0));
3293 for (i
= 0; i
< nargs
; i
++)
3295 SSET (result
, i
, XINT (args
[i
]));
3296 /* Move the meta bit to the right place for a string char. */
3297 if (XINT (args
[i
]) & CHAR_META
)
3298 SSET (result
, i
, SREF (result
, i
) | 0x80);
3307 /************************************************************************
3308 Memory Full Handling
3309 ************************************************************************/
3312 /* Called if malloc returns zero. */
3321 memory_full_cons_threshold
= sizeof (struct cons_block
);
3323 /* The first time we get here, free the spare memory. */
3324 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3325 if (spare_memory
[i
])
3328 free (spare_memory
[i
]);
3329 else if (i
>= 1 && i
<= 4)
3330 lisp_align_free (spare_memory
[i
]);
3332 lisp_free (spare_memory
[i
]);
3333 spare_memory
[i
] = 0;
3336 /* Record the space now used. When it decreases substantially,
3337 we can refill the memory reserve. */
3338 #ifndef SYSTEM_MALLOC
3339 bytes_used_when_full
= BYTES_USED
;
3342 /* This used to call error, but if we've run out of memory, we could
3343 get infinite recursion trying to build the string. */
3344 xsignal (Qnil
, Vmemory_signal_data
);
3347 /* If we released our reserve (due to running out of memory),
3348 and we have a fair amount free once again,
3349 try to set aside another reserve in case we run out once more.
3351 This is called when a relocatable block is freed in ralloc.c,
3352 and also directly from this file, in case we're not using ralloc.c. */
3355 refill_memory_reserve (void)
3357 #ifndef SYSTEM_MALLOC
3358 if (spare_memory
[0] == 0)
3359 spare_memory
[0] = (char *) malloc ((size_t) SPARE_MEMORY
);
3360 if (spare_memory
[1] == 0)
3361 spare_memory
[1] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3363 if (spare_memory
[2] == 0)
3364 spare_memory
[2] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3366 if (spare_memory
[3] == 0)
3367 spare_memory
[3] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3369 if (spare_memory
[4] == 0)
3370 spare_memory
[4] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3372 if (spare_memory
[5] == 0)
3373 spare_memory
[5] = (char *) lisp_malloc (sizeof (struct string_block
),
3375 if (spare_memory
[6] == 0)
3376 spare_memory
[6] = (char *) lisp_malloc (sizeof (struct string_block
),
3378 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3379 Vmemory_full
= Qnil
;
3383 /************************************************************************
3385 ************************************************************************/
3387 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3389 /* Conservative C stack marking requires a method to identify possibly
3390 live Lisp objects given a pointer value. We do this by keeping
3391 track of blocks of Lisp data that are allocated in a red-black tree
3392 (see also the comment of mem_node which is the type of nodes in
3393 that tree). Function lisp_malloc adds information for an allocated
3394 block to the red-black tree with calls to mem_insert, and function
3395 lisp_free removes it with mem_delete. Functions live_string_p etc
3396 call mem_find to lookup information about a given pointer in the
3397 tree, and use that to determine if the pointer points to a Lisp
3400 /* Initialize this part of alloc.c. */
3405 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3406 mem_z
.parent
= NULL
;
3407 mem_z
.color
= MEM_BLACK
;
3408 mem_z
.start
= mem_z
.end
= NULL
;
3413 /* Value is a pointer to the mem_node containing START. Value is
3414 MEM_NIL if there is no node in the tree containing START. */
3416 static INLINE
struct mem_node
*
3417 mem_find (void *start
)
3421 if (start
< min_heap_address
|| start
> max_heap_address
)
3424 /* Make the search always successful to speed up the loop below. */
3425 mem_z
.start
= start
;
3426 mem_z
.end
= (char *) start
+ 1;
3429 while (start
< p
->start
|| start
>= p
->end
)
3430 p
= start
< p
->start
? p
->left
: p
->right
;
3435 /* Insert a new node into the tree for a block of memory with start
3436 address START, end address END, and type TYPE. Value is a
3437 pointer to the node that was inserted. */
3439 static struct mem_node
*
3440 mem_insert (void *start
, void *end
, enum mem_type type
)
3442 struct mem_node
*c
, *parent
, *x
;
3444 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3445 min_heap_address
= start
;
3446 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3447 max_heap_address
= end
;
3449 /* See where in the tree a node for START belongs. In this
3450 particular application, it shouldn't happen that a node is already
3451 present. For debugging purposes, let's check that. */
3455 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3457 while (c
!= MEM_NIL
)
3459 if (start
>= c
->start
&& start
< c
->end
)
3462 c
= start
< c
->start
? c
->left
: c
->right
;
3465 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3467 while (c
!= MEM_NIL
)
3470 c
= start
< c
->start
? c
->left
: c
->right
;
3473 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3475 /* Create a new node. */
3476 #ifdef GC_MALLOC_CHECK
3477 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
3481 x
= (struct mem_node
*) xmalloc (sizeof *x
);
3487 x
->left
= x
->right
= MEM_NIL
;
3490 /* Insert it as child of PARENT or install it as root. */
3493 if (start
< parent
->start
)
3501 /* Re-establish red-black tree properties. */
3502 mem_insert_fixup (x
);
3508 /* Re-establish the red-black properties of the tree, and thereby
3509 balance the tree, after node X has been inserted; X is always red. */
3512 mem_insert_fixup (struct mem_node
*x
)
3514 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3516 /* X is red and its parent is red. This is a violation of
3517 red-black tree property #3. */
3519 if (x
->parent
== x
->parent
->parent
->left
)
3521 /* We're on the left side of our grandparent, and Y is our
3523 struct mem_node
*y
= x
->parent
->parent
->right
;
3525 if (y
->color
== MEM_RED
)
3527 /* Uncle and parent are red but should be black because
3528 X is red. Change the colors accordingly and proceed
3529 with the grandparent. */
3530 x
->parent
->color
= MEM_BLACK
;
3531 y
->color
= MEM_BLACK
;
3532 x
->parent
->parent
->color
= MEM_RED
;
3533 x
= x
->parent
->parent
;
3537 /* Parent and uncle have different colors; parent is
3538 red, uncle is black. */
3539 if (x
== x
->parent
->right
)
3542 mem_rotate_left (x
);
3545 x
->parent
->color
= MEM_BLACK
;
3546 x
->parent
->parent
->color
= MEM_RED
;
3547 mem_rotate_right (x
->parent
->parent
);
3552 /* This is the symmetrical case of above. */
3553 struct mem_node
*y
= x
->parent
->parent
->left
;
3555 if (y
->color
== MEM_RED
)
3557 x
->parent
->color
= MEM_BLACK
;
3558 y
->color
= MEM_BLACK
;
3559 x
->parent
->parent
->color
= MEM_RED
;
3560 x
= x
->parent
->parent
;
3564 if (x
== x
->parent
->left
)
3567 mem_rotate_right (x
);
3570 x
->parent
->color
= MEM_BLACK
;
3571 x
->parent
->parent
->color
= MEM_RED
;
3572 mem_rotate_left (x
->parent
->parent
);
3577 /* The root may have been changed to red due to the algorithm. Set
3578 it to black so that property #5 is satisfied. */
3579 mem_root
->color
= MEM_BLACK
;
3590 mem_rotate_left (struct mem_node
*x
)
3594 /* Turn y's left sub-tree into x's right sub-tree. */
3597 if (y
->left
!= MEM_NIL
)
3598 y
->left
->parent
= x
;
3600 /* Y's parent was x's parent. */
3602 y
->parent
= x
->parent
;
3604 /* Get the parent to point to y instead of x. */
3607 if (x
== x
->parent
->left
)
3608 x
->parent
->left
= y
;
3610 x
->parent
->right
= y
;
3615 /* Put x on y's left. */
3629 mem_rotate_right (struct mem_node
*x
)
3631 struct mem_node
*y
= x
->left
;
3634 if (y
->right
!= MEM_NIL
)
3635 y
->right
->parent
= x
;
3638 y
->parent
= x
->parent
;
3641 if (x
== x
->parent
->right
)
3642 x
->parent
->right
= y
;
3644 x
->parent
->left
= y
;
3655 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3658 mem_delete (struct mem_node
*z
)
3660 struct mem_node
*x
, *y
;
3662 if (!z
|| z
== MEM_NIL
)
3665 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3670 while (y
->left
!= MEM_NIL
)
3674 if (y
->left
!= MEM_NIL
)
3679 x
->parent
= y
->parent
;
3682 if (y
== y
->parent
->left
)
3683 y
->parent
->left
= x
;
3685 y
->parent
->right
= x
;
3692 z
->start
= y
->start
;
3697 if (y
->color
== MEM_BLACK
)
3698 mem_delete_fixup (x
);
3700 #ifdef GC_MALLOC_CHECK
3708 /* Re-establish the red-black properties of the tree, after a
3712 mem_delete_fixup (struct mem_node
*x
)
3714 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3716 if (x
== x
->parent
->left
)
3718 struct mem_node
*w
= x
->parent
->right
;
3720 if (w
->color
== MEM_RED
)
3722 w
->color
= MEM_BLACK
;
3723 x
->parent
->color
= MEM_RED
;
3724 mem_rotate_left (x
->parent
);
3725 w
= x
->parent
->right
;
3728 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3735 if (w
->right
->color
== MEM_BLACK
)
3737 w
->left
->color
= MEM_BLACK
;
3739 mem_rotate_right (w
);
3740 w
= x
->parent
->right
;
3742 w
->color
= x
->parent
->color
;
3743 x
->parent
->color
= MEM_BLACK
;
3744 w
->right
->color
= MEM_BLACK
;
3745 mem_rotate_left (x
->parent
);
3751 struct mem_node
*w
= x
->parent
->left
;
3753 if (w
->color
== MEM_RED
)
3755 w
->color
= MEM_BLACK
;
3756 x
->parent
->color
= MEM_RED
;
3757 mem_rotate_right (x
->parent
);
3758 w
= x
->parent
->left
;
3761 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3768 if (w
->left
->color
== MEM_BLACK
)
3770 w
->right
->color
= MEM_BLACK
;
3772 mem_rotate_left (w
);
3773 w
= x
->parent
->left
;
3776 w
->color
= x
->parent
->color
;
3777 x
->parent
->color
= MEM_BLACK
;
3778 w
->left
->color
= MEM_BLACK
;
3779 mem_rotate_right (x
->parent
);
3785 x
->color
= MEM_BLACK
;
3789 /* Value is non-zero if P is a pointer to a live Lisp string on
3790 the heap. M is a pointer to the mem_block for P. */
3793 live_string_p (struct mem_node
*m
, void *p
)
3795 if (m
->type
== MEM_TYPE_STRING
)
3797 struct string_block
*b
= (struct string_block
*) m
->start
;
3798 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
3800 /* P must point to the start of a Lisp_String structure, and it
3801 must not be on the free-list. */
3803 && offset
% sizeof b
->strings
[0] == 0
3804 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
3805 && ((struct Lisp_String
*) p
)->data
!= NULL
);
3812 /* Value is non-zero if P is a pointer to a live Lisp cons on
3813 the heap. M is a pointer to the mem_block for P. */
3816 live_cons_p (struct mem_node
*m
, void *p
)
3818 if (m
->type
== MEM_TYPE_CONS
)
3820 struct cons_block
*b
= (struct cons_block
*) m
->start
;
3821 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
3823 /* P must point to the start of a Lisp_Cons, not be
3824 one of the unused cells in the current cons block,
3825 and not be on the free-list. */
3827 && offset
% sizeof b
->conses
[0] == 0
3828 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
3830 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
3831 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
3838 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3839 the heap. M is a pointer to the mem_block for P. */
3842 live_symbol_p (struct mem_node
*m
, void *p
)
3844 if (m
->type
== MEM_TYPE_SYMBOL
)
3846 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
3847 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
3849 /* P must point to the start of a Lisp_Symbol, not be
3850 one of the unused cells in the current symbol block,
3851 and not be on the free-list. */
3853 && offset
% sizeof b
->symbols
[0] == 0
3854 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
3855 && (b
!= symbol_block
3856 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
3857 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
3864 /* Value is non-zero if P is a pointer to a live Lisp float on
3865 the heap. M is a pointer to the mem_block for P. */
3868 live_float_p (struct mem_node
*m
, void *p
)
3870 if (m
->type
== MEM_TYPE_FLOAT
)
3872 struct float_block
*b
= (struct float_block
*) m
->start
;
3873 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
3875 /* P must point to the start of a Lisp_Float and not be
3876 one of the unused cells in the current float block. */
3878 && offset
% sizeof b
->floats
[0] == 0
3879 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
3880 && (b
!= float_block
3881 || offset
/ sizeof b
->floats
[0] < float_block_index
));
3888 /* Value is non-zero if P is a pointer to a live Lisp Misc on
3889 the heap. M is a pointer to the mem_block for P. */
3892 live_misc_p (struct mem_node
*m
, void *p
)
3894 if (m
->type
== MEM_TYPE_MISC
)
3896 struct marker_block
*b
= (struct marker_block
*) m
->start
;
3897 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
3899 /* P must point to the start of a Lisp_Misc, not be
3900 one of the unused cells in the current misc block,
3901 and not be on the free-list. */
3903 && offset
% sizeof b
->markers
[0] == 0
3904 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
3905 && (b
!= marker_block
3906 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
3907 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
3914 /* Value is non-zero if P is a pointer to a live vector-like object.
3915 M is a pointer to the mem_block for P. */
3918 live_vector_p (struct mem_node
*m
, void *p
)
3920 return (p
== m
->start
&& m
->type
== MEM_TYPE_VECTORLIKE
);
3924 /* Value is non-zero if P is a pointer to a live buffer. M is a
3925 pointer to the mem_block for P. */
3928 live_buffer_p (struct mem_node
*m
, void *p
)
3930 /* P must point to the start of the block, and the buffer
3931 must not have been killed. */
3932 return (m
->type
== MEM_TYPE_BUFFER
3934 && !NILP (((struct buffer
*) p
)->name
));
3937 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
3941 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3943 /* Array of objects that are kept alive because the C stack contains
3944 a pattern that looks like a reference to them . */
3946 #define MAX_ZOMBIES 10
3947 static Lisp_Object zombies
[MAX_ZOMBIES
];
3949 /* Number of zombie objects. */
3951 static int nzombies
;
3953 /* Number of garbage collections. */
3957 /* Average percentage of zombies per collection. */
3959 static double avg_zombies
;
3961 /* Max. number of live and zombie objects. */
3963 static int max_live
, max_zombies
;
3965 /* Average number of live objects per GC. */
3967 static double avg_live
;
3969 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
3970 doc
: /* Show information about live and zombie objects. */)
3973 Lisp_Object args
[8], zombie_list
= Qnil
;
3975 for (i
= 0; i
< nzombies
; i
++)
3976 zombie_list
= Fcons (zombies
[i
], zombie_list
);
3977 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
3978 args
[1] = make_number (ngcs
);
3979 args
[2] = make_float (avg_live
);
3980 args
[3] = make_float (avg_zombies
);
3981 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
3982 args
[5] = make_number (max_live
);
3983 args
[6] = make_number (max_zombies
);
3984 args
[7] = zombie_list
;
3985 return Fmessage (8, args
);
3988 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3991 /* Mark OBJ if we can prove it's a Lisp_Object. */
3994 mark_maybe_object (Lisp_Object obj
)
3996 void *po
= (void *) XPNTR (obj
);
3997 struct mem_node
*m
= mem_find (po
);
4003 switch (XTYPE (obj
))
4006 mark_p
= (live_string_p (m
, po
)
4007 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4011 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4015 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4019 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4022 case Lisp_Vectorlike
:
4023 /* Note: can't check BUFFERP before we know it's a
4024 buffer because checking that dereferences the pointer
4025 PO which might point anywhere. */
4026 if (live_vector_p (m
, po
))
4027 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4028 else if (live_buffer_p (m
, po
))
4029 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4033 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4042 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4043 if (nzombies
< MAX_ZOMBIES
)
4044 zombies
[nzombies
] = obj
;
4053 /* If P points to Lisp data, mark that as live if it isn't already
4057 mark_maybe_pointer (void *p
)
4061 /* Quickly rule out some values which can't point to Lisp data. */
4064 8 /* USE_LSB_TAG needs Lisp data to be aligned on multiples of 8. */
4066 2 /* We assume that Lisp data is aligned on even addresses. */
4074 Lisp_Object obj
= Qnil
;
4078 case MEM_TYPE_NON_LISP
:
4079 /* Nothing to do; not a pointer to Lisp memory. */
4082 case MEM_TYPE_BUFFER
:
4083 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P((struct buffer
*)p
))
4084 XSETVECTOR (obj
, p
);
4088 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4092 case MEM_TYPE_STRING
:
4093 if (live_string_p (m
, p
)
4094 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4095 XSETSTRING (obj
, p
);
4099 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4103 case MEM_TYPE_SYMBOL
:
4104 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4105 XSETSYMBOL (obj
, p
);
4108 case MEM_TYPE_FLOAT
:
4109 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4113 case MEM_TYPE_VECTORLIKE
:
4114 if (live_vector_p (m
, p
))
4117 XSETVECTOR (tem
, p
);
4118 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4133 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4134 or END+OFFSET..START. */
4137 mark_memory (void *start
, void *end
, int offset
)
4142 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4146 /* Make START the pointer to the start of the memory region,
4147 if it isn't already. */
4155 /* Mark Lisp_Objects. */
4156 for (p
= (Lisp_Object
*) ((char *) start
+ offset
); (void *) p
< end
; ++p
)
4157 mark_maybe_object (*p
);
4159 /* Mark Lisp data pointed to. This is necessary because, in some
4160 situations, the C compiler optimizes Lisp objects away, so that
4161 only a pointer to them remains. Example:
4163 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4166 Lisp_Object obj = build_string ("test");
4167 struct Lisp_String *s = XSTRING (obj);
4168 Fgarbage_collect ();
4169 fprintf (stderr, "test `%s'\n", s->data);
4173 Here, `obj' isn't really used, and the compiler optimizes it
4174 away. The only reference to the life string is through the
4177 for (pp
= (void **) ((char *) start
+ offset
); (void *) pp
< end
; ++pp
)
4178 mark_maybe_pointer (*pp
);
4181 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4182 the GCC system configuration. In gcc 3.2, the only systems for
4183 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4184 by others?) and ns32k-pc532-min. */
4186 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4188 static int setjmp_tested_p
, longjmps_done
;
4190 #define SETJMP_WILL_LIKELY_WORK "\
4192 Emacs garbage collector has been changed to use conservative stack\n\
4193 marking. Emacs has determined that the method it uses to do the\n\
4194 marking will likely work on your system, but this isn't sure.\n\
4196 If you are a system-programmer, or can get the help of a local wizard\n\
4197 who is, please take a look at the function mark_stack in alloc.c, and\n\
4198 verify that the methods used are appropriate for your system.\n\
4200 Please mail the result to <emacs-devel@gnu.org>.\n\
4203 #define SETJMP_WILL_NOT_WORK "\
4205 Emacs garbage collector has been changed to use conservative stack\n\
4206 marking. Emacs has determined that the default method it uses to do the\n\
4207 marking will not work on your system. We will need a system-dependent\n\
4208 solution for your system.\n\
4210 Please take a look at the function mark_stack in alloc.c, and\n\
4211 try to find a way to make it work on your system.\n\
4213 Note that you may get false negatives, depending on the compiler.\n\
4214 In particular, you need to use -O with GCC for this test.\n\
4216 Please mail the result to <emacs-devel@gnu.org>.\n\
4220 /* Perform a quick check if it looks like setjmp saves registers in a
4221 jmp_buf. Print a message to stderr saying so. When this test
4222 succeeds, this is _not_ a proof that setjmp is sufficient for
4223 conservative stack marking. Only the sources or a disassembly
4234 /* Arrange for X to be put in a register. */
4240 if (longjmps_done
== 1)
4242 /* Came here after the longjmp at the end of the function.
4244 If x == 1, the longjmp has restored the register to its
4245 value before the setjmp, and we can hope that setjmp
4246 saves all such registers in the jmp_buf, although that
4249 For other values of X, either something really strange is
4250 taking place, or the setjmp just didn't save the register. */
4253 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4256 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4263 if (longjmps_done
== 1)
4267 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4270 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4272 /* Abort if anything GCPRO'd doesn't survive the GC. */
4280 for (p
= gcprolist
; p
; p
= p
->next
)
4281 for (i
= 0; i
< p
->nvars
; ++i
)
4282 if (!survives_gc_p (p
->var
[i
]))
4283 /* FIXME: It's not necessarily a bug. It might just be that the
4284 GCPRO is unnecessary or should release the object sooner. */
4288 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4295 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
4296 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4298 fprintf (stderr
, " %d = ", i
);
4299 debug_print (zombies
[i
]);
4303 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4306 /* Mark live Lisp objects on the C stack.
4308 There are several system-dependent problems to consider when
4309 porting this to new architectures:
4313 We have to mark Lisp objects in CPU registers that can hold local
4314 variables or are used to pass parameters.
4316 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4317 something that either saves relevant registers on the stack, or
4318 calls mark_maybe_object passing it each register's contents.
4320 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4321 implementation assumes that calling setjmp saves registers we need
4322 to see in a jmp_buf which itself lies on the stack. This doesn't
4323 have to be true! It must be verified for each system, possibly
4324 by taking a look at the source code of setjmp.
4328 Architectures differ in the way their processor stack is organized.
4329 For example, the stack might look like this
4332 | Lisp_Object | size = 4
4334 | something else | size = 2
4336 | Lisp_Object | size = 4
4340 In such a case, not every Lisp_Object will be aligned equally. To
4341 find all Lisp_Object on the stack it won't be sufficient to walk
4342 the stack in steps of 4 bytes. Instead, two passes will be
4343 necessary, one starting at the start of the stack, and a second
4344 pass starting at the start of the stack + 2. Likewise, if the
4345 minimal alignment of Lisp_Objects on the stack is 1, four passes
4346 would be necessary, each one starting with one byte more offset
4347 from the stack start.
4349 The current code assumes by default that Lisp_Objects are aligned
4350 equally on the stack. */
4356 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4357 union aligned_jmpbuf
{
4361 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4364 /* This trick flushes the register windows so that all the state of
4365 the process is contained in the stack. */
4366 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4367 needed on ia64 too. See mach_dep.c, where it also says inline
4368 assembler doesn't work with relevant proprietary compilers. */
4370 #if defined (__sparc64__) && defined (__FreeBSD__)
4371 /* FreeBSD does not have a ta 3 handler. */
4378 /* Save registers that we need to see on the stack. We need to see
4379 registers used to hold register variables and registers used to
4381 #ifdef GC_SAVE_REGISTERS_ON_STACK
4382 GC_SAVE_REGISTERS_ON_STACK (end
);
4383 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4385 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4386 setjmp will definitely work, test it
4387 and print a message with the result
4389 if (!setjmp_tested_p
)
4391 setjmp_tested_p
= 1;
4394 #endif /* GC_SETJMP_WORKS */
4397 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4398 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4400 /* This assumes that the stack is a contiguous region in memory. If
4401 that's not the case, something has to be done here to iterate
4402 over the stack segments. */
4403 #ifndef GC_LISP_OBJECT_ALIGNMENT
4405 #define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
4407 #define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
4410 for (i
= 0; i
< sizeof (Lisp_Object
); i
+= GC_LISP_OBJECT_ALIGNMENT
)
4411 mark_memory (stack_base
, end
, i
);
4412 /* Allow for marking a secondary stack, like the register stack on the
4414 #ifdef GC_MARK_SECONDARY_STACK
4415 GC_MARK_SECONDARY_STACK ();
4418 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4423 #endif /* GC_MARK_STACK != 0 */
4426 /* Determine whether it is safe to access memory at address P. */
4428 valid_pointer_p (void *p
)
4431 return w32_valid_pointer_p (p
, 16);
4435 /* Obviously, we cannot just access it (we would SEGV trying), so we
4436 trick the o/s to tell us whether p is a valid pointer.
4437 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4438 not validate p in that case. */
4440 if ((fd
= emacs_open ("__Valid__Lisp__Object__", O_CREAT
| O_WRONLY
| O_TRUNC
, 0666)) >= 0)
4442 int valid
= (emacs_write (fd
, (char *)p
, 16) == 16);
4444 unlink ("__Valid__Lisp__Object__");
4452 /* Return 1 if OBJ is a valid lisp object.
4453 Return 0 if OBJ is NOT a valid lisp object.
4454 Return -1 if we cannot validate OBJ.
4455 This function can be quite slow,
4456 so it should only be used in code for manual debugging. */
4459 valid_lisp_object_p (Lisp_Object obj
)
4469 p
= (void *) XPNTR (obj
);
4470 if (PURE_POINTER_P (p
))
4474 return valid_pointer_p (p
);
4481 int valid
= valid_pointer_p (p
);
4493 case MEM_TYPE_NON_LISP
:
4496 case MEM_TYPE_BUFFER
:
4497 return live_buffer_p (m
, p
);
4500 return live_cons_p (m
, p
);
4502 case MEM_TYPE_STRING
:
4503 return live_string_p (m
, p
);
4506 return live_misc_p (m
, p
);
4508 case MEM_TYPE_SYMBOL
:
4509 return live_symbol_p (m
, p
);
4511 case MEM_TYPE_FLOAT
:
4512 return live_float_p (m
, p
);
4514 case MEM_TYPE_VECTORLIKE
:
4515 return live_vector_p (m
, p
);
4528 /***********************************************************************
4529 Pure Storage Management
4530 ***********************************************************************/
4532 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4533 pointer to it. TYPE is the Lisp type for which the memory is
4534 allocated. TYPE < 0 means it's not used for a Lisp object. */
4536 static POINTER_TYPE
*
4537 pure_alloc (size_t size
, int type
)
4539 POINTER_TYPE
*result
;
4541 size_t alignment
= (1 << GCTYPEBITS
);
4543 size_t alignment
= sizeof (EMACS_INT
);
4545 /* Give Lisp_Floats an extra alignment. */
4546 if (type
== Lisp_Float
)
4548 #if defined __GNUC__ && __GNUC__ >= 2
4549 alignment
= __alignof (struct Lisp_Float
);
4551 alignment
= sizeof (struct Lisp_Float
);
4559 /* Allocate space for a Lisp object from the beginning of the free
4560 space with taking account of alignment. */
4561 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4562 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4566 /* Allocate space for a non-Lisp object from the end of the free
4568 pure_bytes_used_non_lisp
+= size
;
4569 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4571 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4573 if (pure_bytes_used
<= pure_size
)
4576 /* Don't allocate a large amount here,
4577 because it might get mmap'd and then its address
4578 might not be usable. */
4579 purebeg
= (char *) xmalloc (10000);
4581 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4582 pure_bytes_used
= 0;
4583 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4588 /* Print a warning if PURESIZE is too small. */
4591 check_pure_size (void)
4593 if (pure_bytes_used_before_overflow
)
4594 message ("emacs:0:Pure Lisp storage overflow (approx. %d bytes needed)",
4595 (int) (pure_bytes_used
+ pure_bytes_used_before_overflow
));
4599 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4600 the non-Lisp data pool of the pure storage, and return its start
4601 address. Return NULL if not found. */
4604 find_string_data_in_pure (const char *data
, EMACS_INT nbytes
)
4607 EMACS_INT skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
4608 const unsigned char *p
;
4611 if (pure_bytes_used_non_lisp
< nbytes
+ 1)
4614 /* Set up the Boyer-Moore table. */
4616 for (i
= 0; i
< 256; i
++)
4619 p
= (const unsigned char *) data
;
4621 bm_skip
[*p
++] = skip
;
4623 last_char_skip
= bm_skip
['\0'];
4625 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4626 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
4628 /* See the comments in the function `boyer_moore' (search.c) for the
4629 use of `infinity'. */
4630 infinity
= pure_bytes_used_non_lisp
+ 1;
4631 bm_skip
['\0'] = infinity
;
4633 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
4637 /* Check the last character (== '\0'). */
4640 start
+= bm_skip
[*(p
+ start
)];
4642 while (start
<= start_max
);
4644 if (start
< infinity
)
4645 /* Couldn't find the last character. */
4648 /* No less than `infinity' means we could find the last
4649 character at `p[start - infinity]'. */
4652 /* Check the remaining characters. */
4653 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
4655 return non_lisp_beg
+ start
;
4657 start
+= last_char_skip
;
4659 while (start
<= start_max
);
4665 /* Return a string allocated in pure space. DATA is a buffer holding
4666 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4667 non-zero means make the result string multibyte.
4669 Must get an error if pure storage is full, since if it cannot hold
4670 a large string it may be able to hold conses that point to that
4671 string; then the string is not protected from gc. */
4674 make_pure_string (const char *data
,
4675 EMACS_INT nchars
, EMACS_INT nbytes
, int multibyte
)
4678 struct Lisp_String
*s
;
4680 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4681 s
->data
= find_string_data_in_pure (data
, nbytes
);
4682 if (s
->data
== NULL
)
4684 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
4685 memcpy (s
->data
, data
, nbytes
);
4686 s
->data
[nbytes
] = '\0';
4689 s
->size_byte
= multibyte
? nbytes
: -1;
4690 s
->intervals
= NULL_INTERVAL
;
4691 XSETSTRING (string
, s
);
4695 /* Return a string a string allocated in pure space. Do not allocate
4696 the string data, just point to DATA. */
4699 make_pure_c_string (const char *data
)
4702 struct Lisp_String
*s
;
4703 EMACS_INT nchars
= strlen (data
);
4705 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4708 s
->data
= (unsigned char *) data
;
4709 s
->intervals
= NULL_INTERVAL
;
4710 XSETSTRING (string
, s
);
4714 /* Return a cons allocated from pure space. Give it pure copies
4715 of CAR as car and CDR as cdr. */
4718 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
4720 register Lisp_Object
new;
4721 struct Lisp_Cons
*p
;
4723 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
4725 XSETCAR (new, Fpurecopy (car
));
4726 XSETCDR (new, Fpurecopy (cdr
));
4731 /* Value is a float object with value NUM allocated from pure space. */
4734 make_pure_float (double num
)
4736 register Lisp_Object
new;
4737 struct Lisp_Float
*p
;
4739 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
4741 XFLOAT_INIT (new, num
);
4746 /* Return a vector with room for LEN Lisp_Objects allocated from
4750 make_pure_vector (EMACS_INT len
)
4753 struct Lisp_Vector
*p
;
4754 size_t size
= sizeof *p
+ (len
- 1) * sizeof (Lisp_Object
);
4756 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
4757 XSETVECTOR (new, p
);
4758 XVECTOR (new)->size
= len
;
4763 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
4764 doc
: /* Make a copy of object OBJ in pure storage.
4765 Recursively copies contents of vectors and cons cells.
4766 Does not copy symbols. Copies strings without text properties. */)
4767 (register Lisp_Object obj
)
4769 if (NILP (Vpurify_flag
))
4772 if (PURE_POINTER_P (XPNTR (obj
)))
4775 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
4777 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
4783 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
4784 else if (FLOATP (obj
))
4785 obj
= make_pure_float (XFLOAT_DATA (obj
));
4786 else if (STRINGP (obj
))
4787 obj
= make_pure_string (SDATA (obj
), SCHARS (obj
),
4789 STRING_MULTIBYTE (obj
));
4790 else if (COMPILEDP (obj
) || VECTORP (obj
))
4792 register struct Lisp_Vector
*vec
;
4793 register EMACS_INT i
;
4796 size
= XVECTOR (obj
)->size
;
4797 if (size
& PSEUDOVECTOR_FLAG
)
4798 size
&= PSEUDOVECTOR_SIZE_MASK
;
4799 vec
= XVECTOR (make_pure_vector (size
));
4800 for (i
= 0; i
< size
; i
++)
4801 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
4802 if (COMPILEDP (obj
))
4804 XSETPVECTYPE (vec
, PVEC_COMPILED
);
4805 XSETCOMPILED (obj
, vec
);
4808 XSETVECTOR (obj
, vec
);
4810 else if (MARKERP (obj
))
4811 error ("Attempt to copy a marker to pure storage");
4813 /* Not purified, don't hash-cons. */
4816 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
4817 Fputhash (obj
, obj
, Vpurify_flag
);
4824 /***********************************************************************
4826 ***********************************************************************/
4828 /* Put an entry in staticvec, pointing at the variable with address
4832 staticpro (Lisp_Object
*varaddress
)
4834 staticvec
[staticidx
++] = varaddress
;
4835 if (staticidx
>= NSTATICS
)
4840 /***********************************************************************
4842 ***********************************************************************/
4844 /* Temporarily prevent garbage collection. */
4847 inhibit_garbage_collection (void)
4849 int count
= SPECPDL_INDEX ();
4850 int nbits
= min (VALBITS
, BITS_PER_INT
);
4852 specbind (Qgc_cons_threshold
, make_number (((EMACS_INT
) 1 << (nbits
- 1)) - 1));
4857 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
4858 doc
: /* Reclaim storage for Lisp objects no longer needed.
4859 Garbage collection happens automatically if you cons more than
4860 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4861 `garbage-collect' normally returns a list with info on amount of space in use:
4862 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4863 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4864 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
4865 (USED-STRINGS . FREE-STRINGS))
4866 However, if there was overflow in pure space, `garbage-collect'
4867 returns nil, because real GC can't be done. */)
4870 register struct specbinding
*bind
;
4871 struct catchtag
*catch;
4872 struct handler
*handler
;
4873 char stack_top_variable
;
4876 Lisp_Object total
[8];
4877 int count
= SPECPDL_INDEX ();
4878 EMACS_TIME t1
, t2
, t3
;
4883 /* Can't GC if pure storage overflowed because we can't determine
4884 if something is a pure object or not. */
4885 if (pure_bytes_used_before_overflow
)
4890 /* Don't keep undo information around forever.
4891 Do this early on, so it is no problem if the user quits. */
4893 register struct buffer
*nextb
= all_buffers
;
4897 /* If a buffer's undo list is Qt, that means that undo is
4898 turned off in that buffer. Calling truncate_undo_list on
4899 Qt tends to return NULL, which effectively turns undo back on.
4900 So don't call truncate_undo_list if undo_list is Qt. */
4901 if (! NILP (nextb
->name
) && ! EQ (nextb
->undo_list
, Qt
))
4902 truncate_undo_list (nextb
);
4904 /* Shrink buffer gaps, but skip indirect and dead buffers. */
4905 if (nextb
->base_buffer
== 0 && !NILP (nextb
->name
)
4906 && ! nextb
->text
->inhibit_shrinking
)
4908 /* If a buffer's gap size is more than 10% of the buffer
4909 size, or larger than 2000 bytes, then shrink it
4910 accordingly. Keep a minimum size of 20 bytes. */
4911 int size
= min (2000, max (20, (nextb
->text
->z_byte
/ 10)));
4913 if (nextb
->text
->gap_size
> size
)
4915 struct buffer
*save_current
= current_buffer
;
4916 current_buffer
= nextb
;
4917 make_gap (-(nextb
->text
->gap_size
- size
));
4918 current_buffer
= save_current
;
4922 nextb
= nextb
->next
;
4926 EMACS_GET_TIME (t1
);
4928 /* In case user calls debug_print during GC,
4929 don't let that cause a recursive GC. */
4930 consing_since_gc
= 0;
4932 /* Save what's currently displayed in the echo area. */
4933 message_p
= push_message ();
4934 record_unwind_protect (pop_message_unwind
, Qnil
);
4936 /* Save a copy of the contents of the stack, for debugging. */
4937 #if MAX_SAVE_STACK > 0
4938 if (NILP (Vpurify_flag
))
4940 i
= &stack_top_variable
- stack_bottom
;
4942 if (i
< MAX_SAVE_STACK
)
4944 if (stack_copy
== 0)
4945 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
4946 else if (stack_copy_size
< i
)
4947 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
4950 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
4951 memcpy (stack_copy
, stack_bottom
, i
);
4953 memcpy (stack_copy
, &stack_top_variable
, i
);
4957 #endif /* MAX_SAVE_STACK > 0 */
4959 if (garbage_collection_messages
)
4960 message1_nolog ("Garbage collecting...");
4964 shrink_regexp_cache ();
4968 /* clear_marks (); */
4970 /* Mark all the special slots that serve as the roots of accessibility. */
4972 for (i
= 0; i
< staticidx
; i
++)
4973 mark_object (*staticvec
[i
]);
4975 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
4977 mark_object (bind
->symbol
);
4978 mark_object (bind
->old_value
);
4986 extern void xg_mark_data (void);
4991 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
4992 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
4996 register struct gcpro
*tail
;
4997 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
4998 for (i
= 0; i
< tail
->nvars
; i
++)
4999 mark_object (tail
->var
[i
]);
5004 for (catch = catchlist
; catch; catch = catch->next
)
5006 mark_object (catch->tag
);
5007 mark_object (catch->val
);
5009 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5011 mark_object (handler
->handler
);
5012 mark_object (handler
->var
);
5016 #ifdef HAVE_WINDOW_SYSTEM
5017 mark_fringe_data ();
5020 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5024 /* Everything is now marked, except for the things that require special
5025 finalization, i.e. the undo_list.
5026 Look thru every buffer's undo list
5027 for elements that update markers that were not marked,
5030 register struct buffer
*nextb
= all_buffers
;
5034 /* If a buffer's undo list is Qt, that means that undo is
5035 turned off in that buffer. Calling truncate_undo_list on
5036 Qt tends to return NULL, which effectively turns undo back on.
5037 So don't call truncate_undo_list if undo_list is Qt. */
5038 if (! EQ (nextb
->undo_list
, Qt
))
5040 Lisp_Object tail
, prev
;
5041 tail
= nextb
->undo_list
;
5043 while (CONSP (tail
))
5045 if (CONSP (XCAR (tail
))
5046 && MARKERP (XCAR (XCAR (tail
)))
5047 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5050 nextb
->undo_list
= tail
= XCDR (tail
);
5054 XSETCDR (prev
, tail
);
5064 /* Now that we have stripped the elements that need not be in the
5065 undo_list any more, we can finally mark the list. */
5066 mark_object (nextb
->undo_list
);
5068 nextb
= nextb
->next
;
5074 /* Clear the mark bits that we set in certain root slots. */
5076 unmark_byte_stack ();
5077 VECTOR_UNMARK (&buffer_defaults
);
5078 VECTOR_UNMARK (&buffer_local_symbols
);
5080 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5088 /* clear_marks (); */
5091 consing_since_gc
= 0;
5092 if (gc_cons_threshold
< 10000)
5093 gc_cons_threshold
= 10000;
5095 if (FLOATP (Vgc_cons_percentage
))
5096 { /* Set gc_cons_combined_threshold. */
5097 EMACS_INT total
= 0;
5099 total
+= total_conses
* sizeof (struct Lisp_Cons
);
5100 total
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5101 total
+= total_markers
* sizeof (union Lisp_Misc
);
5102 total
+= total_string_size
;
5103 total
+= total_vector_size
* sizeof (Lisp_Object
);
5104 total
+= total_floats
* sizeof (struct Lisp_Float
);
5105 total
+= total_intervals
* sizeof (struct interval
);
5106 total
+= total_strings
* sizeof (struct Lisp_String
);
5108 gc_relative_threshold
= total
* XFLOAT_DATA (Vgc_cons_percentage
);
5111 gc_relative_threshold
= 0;
5113 if (garbage_collection_messages
)
5115 if (message_p
|| minibuf_level
> 0)
5118 message1_nolog ("Garbage collecting...done");
5121 unbind_to (count
, Qnil
);
5123 total
[0] = Fcons (make_number (total_conses
),
5124 make_number (total_free_conses
));
5125 total
[1] = Fcons (make_number (total_symbols
),
5126 make_number (total_free_symbols
));
5127 total
[2] = Fcons (make_number (total_markers
),
5128 make_number (total_free_markers
));
5129 total
[3] = make_number (total_string_size
);
5130 total
[4] = make_number (total_vector_size
);
5131 total
[5] = Fcons (make_number (total_floats
),
5132 make_number (total_free_floats
));
5133 total
[6] = Fcons (make_number (total_intervals
),
5134 make_number (total_free_intervals
));
5135 total
[7] = Fcons (make_number (total_strings
),
5136 make_number (total_free_strings
));
5138 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5140 /* Compute average percentage of zombies. */
5143 for (i
= 0; i
< 7; ++i
)
5144 if (CONSP (total
[i
]))
5145 nlive
+= XFASTINT (XCAR (total
[i
]));
5147 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5148 max_live
= max (nlive
, max_live
);
5149 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5150 max_zombies
= max (nzombies
, max_zombies
);
5155 if (!NILP (Vpost_gc_hook
))
5157 int count
= inhibit_garbage_collection ();
5158 safe_run_hooks (Qpost_gc_hook
);
5159 unbind_to (count
, Qnil
);
5162 /* Accumulate statistics. */
5163 EMACS_GET_TIME (t2
);
5164 EMACS_SUB_TIME (t3
, t2
, t1
);
5165 if (FLOATP (Vgc_elapsed
))
5166 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
) +
5168 EMACS_USECS (t3
) * 1.0e-6);
5171 return Flist (sizeof total
/ sizeof *total
, total
);
5175 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5176 only interesting objects referenced from glyphs are strings. */
5179 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5181 struct glyph_row
*row
= matrix
->rows
;
5182 struct glyph_row
*end
= row
+ matrix
->nrows
;
5184 for (; row
< end
; ++row
)
5188 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5190 struct glyph
*glyph
= row
->glyphs
[area
];
5191 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5193 for (; glyph
< end_glyph
; ++glyph
)
5194 if (STRINGP (glyph
->object
)
5195 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5196 mark_object (glyph
->object
);
5202 /* Mark Lisp faces in the face cache C. */
5205 mark_face_cache (struct face_cache
*c
)
5210 for (i
= 0; i
< c
->used
; ++i
)
5212 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5216 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5217 mark_object (face
->lface
[j
]);
5225 /* Mark reference to a Lisp_Object.
5226 If the object referred to has not been seen yet, recursively mark
5227 all the references contained in it. */
5229 #define LAST_MARKED_SIZE 500
5230 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5231 int last_marked_index
;
5233 /* For debugging--call abort when we cdr down this many
5234 links of a list, in mark_object. In debugging,
5235 the call to abort will hit a breakpoint.
5236 Normally this is zero and the check never goes off. */
5237 static int mark_object_loop_halt
;
5240 mark_vectorlike (struct Lisp_Vector
*ptr
)
5242 register EMACS_UINT size
= ptr
->size
;
5243 register EMACS_UINT i
;
5245 eassert (!VECTOR_MARKED_P (ptr
));
5246 VECTOR_MARK (ptr
); /* Else mark it */
5247 if (size
& PSEUDOVECTOR_FLAG
)
5248 size
&= PSEUDOVECTOR_SIZE_MASK
;
5250 /* Note that this size is not the memory-footprint size, but only
5251 the number of Lisp_Object fields that we should trace.
5252 The distinction is used e.g. by Lisp_Process which places extra
5253 non-Lisp_Object fields at the end of the structure. */
5254 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5255 mark_object (ptr
->contents
[i
]);
5258 /* Like mark_vectorlike but optimized for char-tables (and
5259 sub-char-tables) assuming that the contents are mostly integers or
5263 mark_char_table (struct Lisp_Vector
*ptr
)
5265 register EMACS_UINT size
= ptr
->size
& PSEUDOVECTOR_SIZE_MASK
;
5266 register EMACS_UINT i
;
5268 eassert (!VECTOR_MARKED_P (ptr
));
5270 for (i
= 0; i
< size
; i
++)
5272 Lisp_Object val
= ptr
->contents
[i
];
5274 if (INTEGERP (val
) || SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
)
5276 if (SUB_CHAR_TABLE_P (val
))
5278 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5279 mark_char_table (XVECTOR (val
));
5287 mark_object (Lisp_Object arg
)
5289 register Lisp_Object obj
= arg
;
5290 #ifdef GC_CHECK_MARKED_OBJECTS
5298 if (PURE_POINTER_P (XPNTR (obj
)))
5301 last_marked
[last_marked_index
++] = obj
;
5302 if (last_marked_index
== LAST_MARKED_SIZE
)
5303 last_marked_index
= 0;
5305 /* Perform some sanity checks on the objects marked here. Abort if
5306 we encounter an object we know is bogus. This increases GC time
5307 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5308 #ifdef GC_CHECK_MARKED_OBJECTS
5310 po
= (void *) XPNTR (obj
);
5312 /* Check that the object pointed to by PO is known to be a Lisp
5313 structure allocated from the heap. */
5314 #define CHECK_ALLOCATED() \
5316 m = mem_find (po); \
5321 /* Check that the object pointed to by PO is live, using predicate
5323 #define CHECK_LIVE(LIVEP) \
5325 if (!LIVEP (m, po)) \
5329 /* Check both of the above conditions. */
5330 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5332 CHECK_ALLOCATED (); \
5333 CHECK_LIVE (LIVEP); \
5336 #else /* not GC_CHECK_MARKED_OBJECTS */
5338 #define CHECK_ALLOCATED() (void) 0
5339 #define CHECK_LIVE(LIVEP) (void) 0
5340 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5342 #endif /* not GC_CHECK_MARKED_OBJECTS */
5344 switch (SWITCH_ENUM_CAST (XTYPE (obj
)))
5348 register struct Lisp_String
*ptr
= XSTRING (obj
);
5349 if (STRING_MARKED_P (ptr
))
5351 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5352 MARK_INTERVAL_TREE (ptr
->intervals
);
5354 #ifdef GC_CHECK_STRING_BYTES
5355 /* Check that the string size recorded in the string is the
5356 same as the one recorded in the sdata structure. */
5357 CHECK_STRING_BYTES (ptr
);
5358 #endif /* GC_CHECK_STRING_BYTES */
5362 case Lisp_Vectorlike
:
5363 if (VECTOR_MARKED_P (XVECTOR (obj
)))
5365 #ifdef GC_CHECK_MARKED_OBJECTS
5367 if (m
== MEM_NIL
&& !SUBRP (obj
)
5368 && po
!= &buffer_defaults
5369 && po
!= &buffer_local_symbols
)
5371 #endif /* GC_CHECK_MARKED_OBJECTS */
5375 #ifdef GC_CHECK_MARKED_OBJECTS
5376 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
5379 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
5384 #endif /* GC_CHECK_MARKED_OBJECTS */
5387 else if (SUBRP (obj
))
5389 else if (COMPILEDP (obj
))
5390 /* We could treat this just like a vector, but it is better to
5391 save the COMPILED_CONSTANTS element for last and avoid
5394 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5395 register EMACS_UINT size
= ptr
->size
;
5396 register EMACS_UINT i
;
5398 CHECK_LIVE (live_vector_p
);
5399 VECTOR_MARK (ptr
); /* Else mark it */
5400 size
&= PSEUDOVECTOR_SIZE_MASK
;
5401 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5403 if (i
!= COMPILED_CONSTANTS
)
5404 mark_object (ptr
->contents
[i
]);
5406 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5409 else if (FRAMEP (obj
))
5411 register struct frame
*ptr
= XFRAME (obj
);
5412 mark_vectorlike (XVECTOR (obj
));
5413 mark_face_cache (ptr
->face_cache
);
5415 else if (WINDOWP (obj
))
5417 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5418 struct window
*w
= XWINDOW (obj
);
5419 mark_vectorlike (ptr
);
5420 /* Mark glyphs for leaf windows. Marking window matrices is
5421 sufficient because frame matrices use the same glyph
5423 if (NILP (w
->hchild
)
5425 && w
->current_matrix
)
5427 mark_glyph_matrix (w
->current_matrix
);
5428 mark_glyph_matrix (w
->desired_matrix
);
5431 else if (HASH_TABLE_P (obj
))
5433 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
5434 mark_vectorlike ((struct Lisp_Vector
*)h
);
5435 /* If hash table is not weak, mark all keys and values.
5436 For weak tables, mark only the vector. */
5438 mark_object (h
->key_and_value
);
5440 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5442 else if (CHAR_TABLE_P (obj
))
5443 mark_char_table (XVECTOR (obj
));
5445 mark_vectorlike (XVECTOR (obj
));
5450 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5451 struct Lisp_Symbol
*ptrx
;
5455 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5457 mark_object (ptr
->function
);
5458 mark_object (ptr
->plist
);
5459 switch (ptr
->redirect
)
5461 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
5462 case SYMBOL_VARALIAS
:
5465 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
5469 case SYMBOL_LOCALIZED
:
5471 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
5472 /* If the value is forwarded to a buffer or keyboard field,
5473 these are marked when we see the corresponding object.
5474 And if it's forwarded to a C variable, either it's not
5475 a Lisp_Object var, or it's staticpro'd already. */
5476 mark_object (blv
->where
);
5477 mark_object (blv
->valcell
);
5478 mark_object (blv
->defcell
);
5481 case SYMBOL_FORWARDED
:
5482 /* If the value is forwarded to a buffer or keyboard field,
5483 these are marked when we see the corresponding object.
5484 And if it's forwarded to a C variable, either it's not
5485 a Lisp_Object var, or it's staticpro'd already. */
5489 if (!PURE_POINTER_P (XSTRING (ptr
->xname
)))
5490 MARK_STRING (XSTRING (ptr
->xname
));
5491 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr
->xname
));
5496 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
5497 XSETSYMBOL (obj
, ptrx
);
5504 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5505 if (XMISCANY (obj
)->gcmarkbit
)
5507 XMISCANY (obj
)->gcmarkbit
= 1;
5509 switch (XMISCTYPE (obj
))
5512 case Lisp_Misc_Marker
:
5513 /* DO NOT mark thru the marker's chain.
5514 The buffer's markers chain does not preserve markers from gc;
5515 instead, markers are removed from the chain when freed by gc. */
5518 case Lisp_Misc_Save_Value
:
5521 register struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5522 /* If DOGC is set, POINTER is the address of a memory
5523 area containing INTEGER potential Lisp_Objects. */
5526 Lisp_Object
*p
= (Lisp_Object
*) ptr
->pointer
;
5528 for (nelt
= ptr
->integer
; nelt
> 0; nelt
--, p
++)
5529 mark_maybe_object (*p
);
5535 case Lisp_Misc_Overlay
:
5537 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
5538 mark_object (ptr
->start
);
5539 mark_object (ptr
->end
);
5540 mark_object (ptr
->plist
);
5543 XSETMISC (obj
, ptr
->next
);
5556 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5557 if (CONS_MARKED_P (ptr
))
5559 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5561 /* If the cdr is nil, avoid recursion for the car. */
5562 if (EQ (ptr
->u
.cdr
, Qnil
))
5568 mark_object (ptr
->car
);
5571 if (cdr_count
== mark_object_loop_halt
)
5577 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
5578 FLOAT_MARK (XFLOAT (obj
));
5589 #undef CHECK_ALLOCATED
5590 #undef CHECK_ALLOCATED_AND_LIVE
5593 /* Mark the pointers in a buffer structure. */
5596 mark_buffer (Lisp_Object buf
)
5598 register struct buffer
*buffer
= XBUFFER (buf
);
5599 register Lisp_Object
*ptr
, tmp
;
5600 Lisp_Object base_buffer
;
5602 eassert (!VECTOR_MARKED_P (buffer
));
5603 VECTOR_MARK (buffer
);
5605 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
5607 /* For now, we just don't mark the undo_list. It's done later in
5608 a special way just before the sweep phase, and after stripping
5609 some of its elements that are not needed any more. */
5611 if (buffer
->overlays_before
)
5613 XSETMISC (tmp
, buffer
->overlays_before
);
5616 if (buffer
->overlays_after
)
5618 XSETMISC (tmp
, buffer
->overlays_after
);
5622 /* buffer-local Lisp variables start at `undo_list',
5623 tho only the ones from `name' on are GC'd normally. */
5624 for (ptr
= &buffer
->name
;
5625 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
5629 /* If this is an indirect buffer, mark its base buffer. */
5630 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5632 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
5633 mark_buffer (base_buffer
);
5637 /* Mark the Lisp pointers in the terminal objects.
5638 Called by the Fgarbage_collector. */
5641 mark_terminals (void)
5644 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5646 eassert (t
->name
!= NULL
);
5647 if (!VECTOR_MARKED_P (t
))
5649 #ifdef HAVE_WINDOW_SYSTEM
5650 mark_image_cache (t
->image_cache
);
5651 #endif /* HAVE_WINDOW_SYSTEM */
5652 mark_vectorlike ((struct Lisp_Vector
*)t
);
5659 /* Value is non-zero if OBJ will survive the current GC because it's
5660 either marked or does not need to be marked to survive. */
5663 survives_gc_p (Lisp_Object obj
)
5667 switch (XTYPE (obj
))
5674 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
5678 survives_p
= XMISCANY (obj
)->gcmarkbit
;
5682 survives_p
= STRING_MARKED_P (XSTRING (obj
));
5685 case Lisp_Vectorlike
:
5686 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
5690 survives_p
= CONS_MARKED_P (XCONS (obj
));
5694 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
5701 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
5706 /* Sweep: find all structures not marked, and free them. */
5711 /* Remove or mark entries in weak hash tables.
5712 This must be done before any object is unmarked. */
5713 sweep_weak_hash_tables ();
5716 #ifdef GC_CHECK_STRING_BYTES
5717 if (!noninteractive
)
5718 check_string_bytes (1);
5721 /* Put all unmarked conses on free list */
5723 register struct cons_block
*cblk
;
5724 struct cons_block
**cprev
= &cons_block
;
5725 register int lim
= cons_block_index
;
5726 register int num_free
= 0, num_used
= 0;
5730 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
5734 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
5736 /* Scan the mark bits an int at a time. */
5737 for (i
= 0; i
<= ilim
; i
++)
5739 if (cblk
->gcmarkbits
[i
] == -1)
5741 /* Fast path - all cons cells for this int are marked. */
5742 cblk
->gcmarkbits
[i
] = 0;
5743 num_used
+= BITS_PER_INT
;
5747 /* Some cons cells for this int are not marked.
5748 Find which ones, and free them. */
5749 int start
, pos
, stop
;
5751 start
= i
* BITS_PER_INT
;
5753 if (stop
> BITS_PER_INT
)
5754 stop
= BITS_PER_INT
;
5757 for (pos
= start
; pos
< stop
; pos
++)
5759 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
5762 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
5763 cons_free_list
= &cblk
->conses
[pos
];
5765 cons_free_list
->car
= Vdead
;
5771 CONS_UNMARK (&cblk
->conses
[pos
]);
5777 lim
= CONS_BLOCK_SIZE
;
5778 /* If this block contains only free conses and we have already
5779 seen more than two blocks worth of free conses then deallocate
5781 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
5783 *cprev
= cblk
->next
;
5784 /* Unhook from the free list. */
5785 cons_free_list
= cblk
->conses
[0].u
.chain
;
5786 lisp_align_free (cblk
);
5791 num_free
+= this_free
;
5792 cprev
= &cblk
->next
;
5795 total_conses
= num_used
;
5796 total_free_conses
= num_free
;
5799 /* Put all unmarked floats on free list */
5801 register struct float_block
*fblk
;
5802 struct float_block
**fprev
= &float_block
;
5803 register int lim
= float_block_index
;
5804 register int num_free
= 0, num_used
= 0;
5806 float_free_list
= 0;
5808 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
5812 for (i
= 0; i
< lim
; i
++)
5813 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
5816 fblk
->floats
[i
].u
.chain
= float_free_list
;
5817 float_free_list
= &fblk
->floats
[i
];
5822 FLOAT_UNMARK (&fblk
->floats
[i
]);
5824 lim
= FLOAT_BLOCK_SIZE
;
5825 /* If this block contains only free floats and we have already
5826 seen more than two blocks worth of free floats then deallocate
5828 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
5830 *fprev
= fblk
->next
;
5831 /* Unhook from the free list. */
5832 float_free_list
= fblk
->floats
[0].u
.chain
;
5833 lisp_align_free (fblk
);
5838 num_free
+= this_free
;
5839 fprev
= &fblk
->next
;
5842 total_floats
= num_used
;
5843 total_free_floats
= num_free
;
5846 /* Put all unmarked intervals on free list */
5848 register struct interval_block
*iblk
;
5849 struct interval_block
**iprev
= &interval_block
;
5850 register int lim
= interval_block_index
;
5851 register int num_free
= 0, num_used
= 0;
5853 interval_free_list
= 0;
5855 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
5860 for (i
= 0; i
< lim
; i
++)
5862 if (!iblk
->intervals
[i
].gcmarkbit
)
5864 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
5865 interval_free_list
= &iblk
->intervals
[i
];
5871 iblk
->intervals
[i
].gcmarkbit
= 0;
5874 lim
= INTERVAL_BLOCK_SIZE
;
5875 /* If this block contains only free intervals and we have already
5876 seen more than two blocks worth of free intervals then
5877 deallocate this block. */
5878 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
5880 *iprev
= iblk
->next
;
5881 /* Unhook from the free list. */
5882 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
5884 n_interval_blocks
--;
5888 num_free
+= this_free
;
5889 iprev
= &iblk
->next
;
5892 total_intervals
= num_used
;
5893 total_free_intervals
= num_free
;
5896 /* Put all unmarked symbols on free list */
5898 register struct symbol_block
*sblk
;
5899 struct symbol_block
**sprev
= &symbol_block
;
5900 register int lim
= symbol_block_index
;
5901 register int num_free
= 0, num_used
= 0;
5903 symbol_free_list
= NULL
;
5905 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
5908 struct Lisp_Symbol
*sym
= sblk
->symbols
;
5909 struct Lisp_Symbol
*end
= sym
+ lim
;
5911 for (; sym
< end
; ++sym
)
5913 /* Check if the symbol was created during loadup. In such a case
5914 it might be pointed to by pure bytecode which we don't trace,
5915 so we conservatively assume that it is live. */
5916 int pure_p
= PURE_POINTER_P (XSTRING (sym
->xname
));
5918 if (!sym
->gcmarkbit
&& !pure_p
)
5920 if (sym
->redirect
== SYMBOL_LOCALIZED
)
5921 xfree (SYMBOL_BLV (sym
));
5922 sym
->next
= symbol_free_list
;
5923 symbol_free_list
= sym
;
5925 symbol_free_list
->function
= Vdead
;
5933 UNMARK_STRING (XSTRING (sym
->xname
));
5938 lim
= SYMBOL_BLOCK_SIZE
;
5939 /* If this block contains only free symbols and we have already
5940 seen more than two blocks worth of free symbols then deallocate
5942 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
5944 *sprev
= sblk
->next
;
5945 /* Unhook from the free list. */
5946 symbol_free_list
= sblk
->symbols
[0].next
;
5952 num_free
+= this_free
;
5953 sprev
= &sblk
->next
;
5956 total_symbols
= num_used
;
5957 total_free_symbols
= num_free
;
5960 /* Put all unmarked misc's on free list.
5961 For a marker, first unchain it from the buffer it points into. */
5963 register struct marker_block
*mblk
;
5964 struct marker_block
**mprev
= &marker_block
;
5965 register int lim
= marker_block_index
;
5966 register int num_free
= 0, num_used
= 0;
5968 marker_free_list
= 0;
5970 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
5975 for (i
= 0; i
< lim
; i
++)
5977 if (!mblk
->markers
[i
].u_any
.gcmarkbit
)
5979 if (mblk
->markers
[i
].u_any
.type
== Lisp_Misc_Marker
)
5980 unchain_marker (&mblk
->markers
[i
].u_marker
);
5981 /* Set the type of the freed object to Lisp_Misc_Free.
5982 We could leave the type alone, since nobody checks it,
5983 but this might catch bugs faster. */
5984 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
5985 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
5986 marker_free_list
= &mblk
->markers
[i
];
5992 mblk
->markers
[i
].u_any
.gcmarkbit
= 0;
5995 lim
= MARKER_BLOCK_SIZE
;
5996 /* If this block contains only free markers and we have already
5997 seen more than two blocks worth of free markers then deallocate
5999 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6001 *mprev
= mblk
->next
;
6002 /* Unhook from the free list. */
6003 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
6009 num_free
+= this_free
;
6010 mprev
= &mblk
->next
;
6014 total_markers
= num_used
;
6015 total_free_markers
= num_free
;
6018 /* Free all unmarked buffers */
6020 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
6023 if (!VECTOR_MARKED_P (buffer
))
6026 prev
->next
= buffer
->next
;
6028 all_buffers
= buffer
->next
;
6029 next
= buffer
->next
;
6035 VECTOR_UNMARK (buffer
);
6036 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
6037 prev
= buffer
, buffer
= buffer
->next
;
6041 /* Free all unmarked vectors */
6043 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
6044 total_vector_size
= 0;
6047 if (!VECTOR_MARKED_P (vector
))
6050 prev
->next
= vector
->next
;
6052 all_vectors
= vector
->next
;
6053 next
= vector
->next
;
6061 VECTOR_UNMARK (vector
);
6062 if (vector
->size
& PSEUDOVECTOR_FLAG
)
6063 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
6065 total_vector_size
+= vector
->size
;
6066 prev
= vector
, vector
= vector
->next
;
6070 #ifdef GC_CHECK_STRING_BYTES
6071 if (!noninteractive
)
6072 check_string_bytes (1);
6079 /* Debugging aids. */
6081 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6082 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6083 This may be helpful in debugging Emacs's memory usage.
6084 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6089 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
6094 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6095 doc
: /* Return a list of counters that measure how much consing there has been.
6096 Each of these counters increments for a certain kind of object.
6097 The counters wrap around from the largest positive integer to zero.
6098 Garbage collection does not decrease them.
6099 The elements of the value are as follows:
6100 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6101 All are in units of 1 = one object consed
6102 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6104 MISCS include overlays, markers, and some internal types.
6105 Frames, windows, buffers, and subprocesses count as vectors
6106 (but the contents of a buffer's text do not count here). */)
6109 Lisp_Object consed
[8];
6111 consed
[0] = make_number (min (MOST_POSITIVE_FIXNUM
, cons_cells_consed
));
6112 consed
[1] = make_number (min (MOST_POSITIVE_FIXNUM
, floats_consed
));
6113 consed
[2] = make_number (min (MOST_POSITIVE_FIXNUM
, vector_cells_consed
));
6114 consed
[3] = make_number (min (MOST_POSITIVE_FIXNUM
, symbols_consed
));
6115 consed
[4] = make_number (min (MOST_POSITIVE_FIXNUM
, string_chars_consed
));
6116 consed
[5] = make_number (min (MOST_POSITIVE_FIXNUM
, misc_objects_consed
));
6117 consed
[6] = make_number (min (MOST_POSITIVE_FIXNUM
, intervals_consed
));
6118 consed
[7] = make_number (min (MOST_POSITIVE_FIXNUM
, strings_consed
));
6120 return Flist (8, consed
);
6123 int suppress_checking
;
6126 die (const char *msg
, const char *file
, int line
)
6128 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6133 /* Initialization */
6136 init_alloc_once (void)
6138 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6140 pure_size
= PURESIZE
;
6141 pure_bytes_used
= 0;
6142 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
6143 pure_bytes_used_before_overflow
= 0;
6145 /* Initialize the list of free aligned blocks. */
6148 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6150 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6154 ignore_warnings
= 1;
6155 #ifdef DOUG_LEA_MALLOC
6156 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
6157 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
6158 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
6166 init_weak_hash_tables ();
6169 malloc_hysteresis
= 32;
6171 malloc_hysteresis
= 0;
6174 refill_memory_reserve ();
6176 ignore_warnings
= 0;
6178 byte_stack_list
= 0;
6180 consing_since_gc
= 0;
6181 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
6182 gc_relative_threshold
= 0;
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);
6200 syms_of_alloc (void)
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.
6250 It can also be set to a hash-table, in which case this table is used to
6251 do hash-consing of the objects allocated to pure space. */);
6253 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
6254 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6255 garbage_collection_messages
= 0;
6257 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook
,
6258 doc
: /* Hook run after garbage collection has finished. */);
6259 Vpost_gc_hook
= Qnil
;
6260 Qpost_gc_hook
= intern_c_string ("post-gc-hook");
6261 staticpro (&Qpost_gc_hook
);
6263 DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data
,
6264 doc
: /* Precomputed `signal' argument for memory-full error. */);
6265 /* We build this in advance because if we wait until we need it, we might
6266 not be able to allocate the memory to hold it. */
6268 = pure_cons (Qerror
,
6269 pure_cons (make_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil
));
6271 DEFVAR_LISP ("memory-full", &Vmemory_full
,
6272 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6273 Vmemory_full
= Qnil
;
6275 staticpro (&Qgc_cons_threshold
);
6276 Qgc_cons_threshold
= intern_c_string ("gc-cons-threshold");
6278 staticpro (&Qchar_table_extra_slots
);
6279 Qchar_table_extra_slots
= intern_c_string ("char-table-extra-slots");
6281 DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed
,
6282 doc
: /* Accumulated time elapsed in garbage collections.
6283 The time is in seconds as a floating point value. */);
6284 DEFVAR_INT ("gcs-done", &gcs_done
,
6285 doc
: /* Accumulated number of garbage collections done. */);
6290 defsubr (&Smake_byte_code
);
6291 defsubr (&Smake_list
);
6292 defsubr (&Smake_vector
);
6293 defsubr (&Smake_string
);
6294 defsubr (&Smake_bool_vector
);
6295 defsubr (&Smake_symbol
);
6296 defsubr (&Smake_marker
);
6297 defsubr (&Spurecopy
);
6298 defsubr (&Sgarbage_collect
);
6299 defsubr (&Smemory_limit
);
6300 defsubr (&Smemory_use_counts
);
6302 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6303 defsubr (&Sgc_status
);
6307 /* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
6308 (do not change this comment) */