Make erc use auth-source to look up channel keys
[emacs.git] / src / alloc.c
blob16b004fc0e97e579576ae194335901f19940faee
1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
3 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2012
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/>. */
21 #include <config.h>
22 #include <stdio.h>
23 #include <limits.h> /* For CHAR_BIT. */
24 #include <setjmp.h>
26 #include <signal.h>
28 #ifdef HAVE_PTHREAD
29 #include <pthread.h>
30 #endif
32 /* This file is part of the core Lisp implementation, and thus must
33 deal with the real data structures. If the Lisp implementation is
34 replaced, this file likely will not be used. */
36 #undef HIDE_LISP_IMPLEMENTATION
37 #include "lisp.h"
38 #include "process.h"
39 #include "intervals.h"
40 #include "puresize.h"
41 #include "buffer.h"
42 #include "window.h"
43 #include "keyboard.h"
44 #include "frame.h"
45 #include "blockinput.h"
46 #include "character.h"
47 #include "syssignal.h"
48 #include "termhooks.h" /* For struct terminal. */
49 #include <setjmp.h>
50 #include <verify.h>
52 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
53 memory. Can do this only if using gmalloc.c. */
55 #if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
56 #undef GC_MALLOC_CHECK
57 #endif
59 #include <unistd.h>
60 #ifndef HAVE_UNISTD_H
61 extern POINTER_TYPE *sbrk ();
62 #endif
64 #include <fcntl.h>
66 #ifdef WINDOWSNT
67 #include "w32.h"
68 #endif
70 #ifdef DOUG_LEA_MALLOC
72 #include <malloc.h>
74 /* Specify maximum number of areas to mmap. It would be nice to use a
75 value that explicitly means "no limit". */
77 #define MMAP_MAX_AREAS 100000000
79 #else /* not DOUG_LEA_MALLOC */
81 /* The following come from gmalloc.c. */
83 extern size_t _bytes_used;
84 extern size_t __malloc_extra_blocks;
86 #endif /* not DOUG_LEA_MALLOC */
88 #if ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT
89 #ifdef HAVE_PTHREAD
91 /* When GTK uses the file chooser dialog, different backends can be loaded
92 dynamically. One such a backend is the Gnome VFS backend that gets loaded
93 if you run Gnome. That backend creates several threads and also allocates
94 memory with malloc.
96 Also, gconf and gsettings may create several threads.
98 If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
99 functions below are called from malloc, there is a chance that one
100 of these threads preempts the Emacs main thread and the hook variables
101 end up in an inconsistent state. So we have a mutex to prevent that (note
102 that the backend handles concurrent access to malloc within its own threads
103 but Emacs code running in the main thread is not included in that control).
105 When UNBLOCK_INPUT is called, reinvoke_input_signal may be called. If this
106 happens in one of the backend threads we will have two threads that tries
107 to run Emacs code at once, and the code is not prepared for that.
108 To prevent that, we only call BLOCK/UNBLOCK from the main thread. */
110 static pthread_mutex_t alloc_mutex;
112 #define BLOCK_INPUT_ALLOC \
113 do \
115 if (pthread_equal (pthread_self (), main_thread)) \
116 BLOCK_INPUT; \
117 pthread_mutex_lock (&alloc_mutex); \
119 while (0)
120 #define UNBLOCK_INPUT_ALLOC \
121 do \
123 pthread_mutex_unlock (&alloc_mutex); \
124 if (pthread_equal (pthread_self (), main_thread)) \
125 UNBLOCK_INPUT; \
127 while (0)
129 #else /* ! defined HAVE_PTHREAD */
131 #define BLOCK_INPUT_ALLOC BLOCK_INPUT
132 #define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
134 #endif /* ! defined HAVE_PTHREAD */
135 #endif /* ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT */
137 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
138 to a struct Lisp_String. */
140 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
141 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
142 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
144 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
145 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
146 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
148 /* Value is the number of bytes of S, a pointer to a struct Lisp_String.
149 Be careful during GC, because S->size contains the mark bit for
150 strings. */
152 #define GC_STRING_BYTES(S) (STRING_BYTES (S))
154 /* Global variables. */
155 struct emacs_globals globals;
157 /* Number of bytes of consing done since the last gc. */
159 EMACS_INT consing_since_gc;
161 /* Similar minimum, computed from Vgc_cons_percentage. */
163 EMACS_INT gc_relative_threshold;
165 /* Minimum number of bytes of consing since GC before next GC,
166 when memory is full. */
168 EMACS_INT memory_full_cons_threshold;
170 /* Nonzero during GC. */
172 int gc_in_progress;
174 /* Nonzero means abort if try to GC.
175 This is for code which is written on the assumption that
176 no GC will happen, so as to verify that assumption. */
178 int abort_on_gc;
180 /* Number of live and free conses etc. */
182 static EMACS_INT total_conses, total_markers, total_symbols, total_vector_size;
183 static EMACS_INT total_free_conses, total_free_markers, total_free_symbols;
184 static EMACS_INT total_free_floats, total_floats;
186 /* Points to memory space allocated as "spare", to be freed if we run
187 out of memory. We keep one large block, four cons-blocks, and
188 two string blocks. */
190 static char *spare_memory[7];
192 /* Amount of spare memory to keep in large reserve block, or to see
193 whether this much is available when malloc fails on a larger request. */
195 #define SPARE_MEMORY (1 << 14)
197 /* Number of extra blocks malloc should get when it needs more core. */
199 static int malloc_hysteresis;
201 /* Initialize it to a nonzero value to force it into data space
202 (rather than bss space). That way unexec will remap it into text
203 space (pure), on some systems. We have not implemented the
204 remapping on more recent systems because this is less important
205 nowadays than in the days of small memories and timesharing. */
207 EMACS_INT pure[(PURESIZE + sizeof (EMACS_INT) - 1) / sizeof (EMACS_INT)] = {1,};
208 #define PUREBEG (char *) pure
210 /* Pointer to the pure area, and its size. */
212 static char *purebeg;
213 static ptrdiff_t pure_size;
215 /* Number of bytes of pure storage used before pure storage overflowed.
216 If this is non-zero, this implies that an overflow occurred. */
218 static ptrdiff_t pure_bytes_used_before_overflow;
220 /* Value is non-zero if P points into pure space. */
222 #define PURE_POINTER_P(P) \
223 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
225 /* Index in pure at which next pure Lisp object will be allocated.. */
227 static EMACS_INT pure_bytes_used_lisp;
229 /* Number of bytes allocated for non-Lisp objects in pure storage. */
231 static EMACS_INT pure_bytes_used_non_lisp;
233 /* If nonzero, this is a warning delivered by malloc and not yet
234 displayed. */
236 const char *pending_malloc_warning;
238 /* Maximum amount of C stack to save when a GC happens. */
240 #ifndef MAX_SAVE_STACK
241 #define MAX_SAVE_STACK 16000
242 #endif
244 /* Buffer in which we save a copy of the C stack at each GC. */
246 #if MAX_SAVE_STACK > 0
247 static char *stack_copy;
248 static ptrdiff_t stack_copy_size;
249 #endif
251 /* Non-zero means ignore malloc warnings. Set during initialization.
252 Currently not used. */
254 static int ignore_warnings;
256 static Lisp_Object Qgc_cons_threshold;
257 Lisp_Object Qchar_table_extra_slots;
259 /* Hook run after GC has finished. */
261 static Lisp_Object Qpost_gc_hook;
263 static void mark_buffer (Lisp_Object);
264 static void mark_terminals (void);
265 static void gc_sweep (void);
266 static void mark_glyph_matrix (struct glyph_matrix *);
267 static void mark_face_cache (struct face_cache *);
269 #if !defined REL_ALLOC || defined SYSTEM_MALLOC
270 static void refill_memory_reserve (void);
271 #endif
272 static struct Lisp_String *allocate_string (void);
273 static void compact_small_strings (void);
274 static void free_large_strings (void);
275 static void sweep_strings (void);
276 static void free_misc (Lisp_Object);
277 extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
279 /* When scanning the C stack for live Lisp objects, Emacs keeps track
280 of what memory allocated via lisp_malloc is intended for what
281 purpose. This enumeration specifies the type of memory. */
283 enum mem_type
285 MEM_TYPE_NON_LISP,
286 MEM_TYPE_BUFFER,
287 MEM_TYPE_CONS,
288 MEM_TYPE_STRING,
289 MEM_TYPE_MISC,
290 MEM_TYPE_SYMBOL,
291 MEM_TYPE_FLOAT,
292 /* We used to keep separate mem_types for subtypes of vectors such as
293 process, hash_table, frame, terminal, and window, but we never made
294 use of the distinction, so it only caused source-code complexity
295 and runtime slowdown. Minor but pointless. */
296 MEM_TYPE_VECTORLIKE
299 static POINTER_TYPE *lisp_align_malloc (size_t, enum mem_type);
300 static POINTER_TYPE *lisp_malloc (size_t, enum mem_type);
303 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
305 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
306 #include <stdio.h> /* For fprintf. */
307 #endif
309 /* A unique object in pure space used to make some Lisp objects
310 on free lists recognizable in O(1). */
312 static Lisp_Object Vdead;
313 #define DEADP(x) EQ (x, Vdead)
315 #ifdef GC_MALLOC_CHECK
317 enum mem_type allocated_mem_type;
318 static int dont_register_blocks;
320 #endif /* GC_MALLOC_CHECK */
322 /* A node in the red-black tree describing allocated memory containing
323 Lisp data. Each such block is recorded with its start and end
324 address when it is allocated, and removed from the tree when it
325 is freed.
327 A red-black tree is a balanced binary tree with the following
328 properties:
330 1. Every node is either red or black.
331 2. Every leaf is black.
332 3. If a node is red, then both of its children are black.
333 4. Every simple path from a node to a descendant leaf contains
334 the same number of black nodes.
335 5. The root is always black.
337 When nodes are inserted into the tree, or deleted from the tree,
338 the tree is "fixed" so that these properties are always true.
340 A red-black tree with N internal nodes has height at most 2
341 log(N+1). Searches, insertions and deletions are done in O(log N).
342 Please see a text book about data structures for a detailed
343 description of red-black trees. Any book worth its salt should
344 describe them. */
346 struct mem_node
348 /* Children of this node. These pointers are never NULL. When there
349 is no child, the value is MEM_NIL, which points to a dummy node. */
350 struct mem_node *left, *right;
352 /* The parent of this node. In the root node, this is NULL. */
353 struct mem_node *parent;
355 /* Start and end of allocated region. */
356 void *start, *end;
358 /* Node color. */
359 enum {MEM_BLACK, MEM_RED} color;
361 /* Memory type. */
362 enum mem_type type;
365 /* Base address of stack. Set in main. */
367 Lisp_Object *stack_base;
369 /* Root of the tree describing allocated Lisp memory. */
371 static struct mem_node *mem_root;
373 /* Lowest and highest known address in the heap. */
375 static void *min_heap_address, *max_heap_address;
377 /* Sentinel node of the tree. */
379 static struct mem_node mem_z;
380 #define MEM_NIL &mem_z
382 static struct Lisp_Vector *allocate_vectorlike (EMACS_INT);
383 static void lisp_free (POINTER_TYPE *);
384 static void mark_stack (void);
385 static int live_vector_p (struct mem_node *, void *);
386 static int live_buffer_p (struct mem_node *, void *);
387 static int live_string_p (struct mem_node *, void *);
388 static int live_cons_p (struct mem_node *, void *);
389 static int live_symbol_p (struct mem_node *, void *);
390 static int live_float_p (struct mem_node *, void *);
391 static int live_misc_p (struct mem_node *, void *);
392 static void mark_maybe_object (Lisp_Object);
393 static void mark_memory (void *, void *);
394 static void mem_init (void);
395 static struct mem_node *mem_insert (void *, void *, enum mem_type);
396 static void mem_insert_fixup (struct mem_node *);
397 static void mem_rotate_left (struct mem_node *);
398 static void mem_rotate_right (struct mem_node *);
399 static void mem_delete (struct mem_node *);
400 static void mem_delete_fixup (struct mem_node *);
401 static inline struct mem_node *mem_find (void *);
404 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
405 static void check_gcpros (void);
406 #endif
408 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
410 #ifndef DEADP
411 # define DEADP(x) 0
412 #endif
414 /* Recording what needs to be marked for gc. */
416 struct gcpro *gcprolist;
418 /* Addresses of staticpro'd variables. Initialize it to a nonzero
419 value; otherwise some compilers put it into BSS. */
421 #define NSTATICS 0x640
422 static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
424 /* Index of next unused slot in staticvec. */
426 static int staticidx = 0;
428 static POINTER_TYPE *pure_alloc (size_t, int);
431 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
432 ALIGNMENT must be a power of 2. */
434 #define ALIGN(ptr, ALIGNMENT) \
435 ((POINTER_TYPE *) ((((uintptr_t) (ptr)) + (ALIGNMENT) - 1) \
436 & ~((ALIGNMENT) - 1)))
440 /************************************************************************
441 Malloc
442 ************************************************************************/
444 /* Function malloc calls this if it finds we are near exhausting storage. */
446 void
447 malloc_warning (const char *str)
449 pending_malloc_warning = str;
453 /* Display an already-pending malloc warning. */
455 void
456 display_malloc_warning (void)
458 call3 (intern ("display-warning"),
459 intern ("alloc"),
460 build_string (pending_malloc_warning),
461 intern ("emergency"));
462 pending_malloc_warning = 0;
465 /* Called if we can't allocate relocatable space for a buffer. */
467 void
468 buffer_memory_full (EMACS_INT nbytes)
470 /* If buffers use the relocating allocator, no need to free
471 spare_memory, because we may have plenty of malloc space left
472 that we could get, and if we don't, the malloc that fails will
473 itself cause spare_memory to be freed. If buffers don't use the
474 relocating allocator, treat this like any other failing
475 malloc. */
477 #ifndef REL_ALLOC
478 memory_full (nbytes);
479 #endif
481 /* This used to call error, but if we've run out of memory, we could
482 get infinite recursion trying to build the string. */
483 xsignal (Qnil, Vmemory_signal_data);
487 #ifndef XMALLOC_OVERRUN_CHECK
488 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
489 #else
491 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
492 around each block.
494 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
495 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
496 block size in little-endian order. The trailer consists of
497 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
499 The header is used to detect whether this block has been allocated
500 through these functions, as some low-level libc functions may
501 bypass the malloc hooks. */
503 #define XMALLOC_OVERRUN_CHECK_SIZE 16
504 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
505 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
507 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
508 hold a size_t value and (2) the header size is a multiple of the
509 alignment that Emacs needs for C types and for USE_LSB_TAG. */
510 #define XMALLOC_BASE_ALIGNMENT \
511 offsetof ( \
512 struct { \
513 union { long double d; intmax_t i; void *p; } u; \
514 char c; \
515 }, \
517 #ifdef USE_LSB_TAG
518 /* A common multiple of the positive integers A and B. Ideally this
519 would be the least common multiple, but there's no way to do that
520 as a constant expression in C, so do the best that we can easily do. */
521 # define COMMON_MULTIPLE(a, b) \
522 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
523 # define XMALLOC_HEADER_ALIGNMENT \
524 COMMON_MULTIPLE (1 << GCTYPEBITS, XMALLOC_BASE_ALIGNMENT)
525 #else
526 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
527 #endif
528 #define XMALLOC_OVERRUN_SIZE_SIZE \
529 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
530 + XMALLOC_HEADER_ALIGNMENT - 1) \
531 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
532 - XMALLOC_OVERRUN_CHECK_SIZE)
534 static char const xmalloc_overrun_check_header[XMALLOC_OVERRUN_CHECK_SIZE] =
535 { '\x9a', '\x9b', '\xae', '\xaf',
536 '\xbf', '\xbe', '\xce', '\xcf',
537 '\xea', '\xeb', '\xec', '\xed',
538 '\xdf', '\xde', '\x9c', '\x9d' };
540 static char const xmalloc_overrun_check_trailer[XMALLOC_OVERRUN_CHECK_SIZE] =
541 { '\xaa', '\xab', '\xac', '\xad',
542 '\xba', '\xbb', '\xbc', '\xbd',
543 '\xca', '\xcb', '\xcc', '\xcd',
544 '\xda', '\xdb', '\xdc', '\xdd' };
546 /* Insert and extract the block size in the header. */
548 static void
549 xmalloc_put_size (unsigned char *ptr, size_t size)
551 int i;
552 for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
554 *--ptr = size & ((1 << CHAR_BIT) - 1);
555 size >>= CHAR_BIT;
559 static size_t
560 xmalloc_get_size (unsigned char *ptr)
562 size_t size = 0;
563 int i;
564 ptr -= XMALLOC_OVERRUN_SIZE_SIZE;
565 for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
567 size <<= CHAR_BIT;
568 size += *ptr++;
570 return size;
574 /* The call depth in overrun_check functions. For example, this might happen:
575 xmalloc()
576 overrun_check_malloc()
577 -> malloc -> (via hook)_-> emacs_blocked_malloc
578 -> overrun_check_malloc
579 call malloc (hooks are NULL, so real malloc is called).
580 malloc returns 10000.
581 add overhead, return 10016.
582 <- (back in overrun_check_malloc)
583 add overhead again, return 10032
584 xmalloc returns 10032.
586 (time passes).
588 xfree(10032)
589 overrun_check_free(10032)
590 decrease overhead
591 free(10016) <- crash, because 10000 is the original pointer. */
593 static ptrdiff_t check_depth;
595 /* Like malloc, but wraps allocated block with header and trailer. */
597 static POINTER_TYPE *
598 overrun_check_malloc (size_t size)
600 register unsigned char *val;
601 int overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD : 0;
602 if (SIZE_MAX - overhead < size)
603 abort ();
605 val = (unsigned char *) malloc (size + overhead);
606 if (val && check_depth == 1)
608 memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
609 val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
610 xmalloc_put_size (val, size);
611 memcpy (val + size, xmalloc_overrun_check_trailer,
612 XMALLOC_OVERRUN_CHECK_SIZE);
614 --check_depth;
615 return (POINTER_TYPE *)val;
619 /* Like realloc, but checks old block for overrun, and wraps new block
620 with header and trailer. */
622 static POINTER_TYPE *
623 overrun_check_realloc (POINTER_TYPE *block, size_t size)
625 register unsigned char *val = (unsigned char *) block;
626 int overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD : 0;
627 if (SIZE_MAX - overhead < size)
628 abort ();
630 if (val
631 && check_depth == 1
632 && memcmp (xmalloc_overrun_check_header,
633 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
634 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
636 size_t osize = xmalloc_get_size (val);
637 if (memcmp (xmalloc_overrun_check_trailer, val + osize,
638 XMALLOC_OVERRUN_CHECK_SIZE))
639 abort ();
640 memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
641 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
642 memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
645 val = (unsigned char *) realloc ((POINTER_TYPE *)val, size + overhead);
647 if (val && check_depth == 1)
649 memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
650 val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
651 xmalloc_put_size (val, size);
652 memcpy (val + size, xmalloc_overrun_check_trailer,
653 XMALLOC_OVERRUN_CHECK_SIZE);
655 --check_depth;
656 return (POINTER_TYPE *)val;
659 /* Like free, but checks block for overrun. */
661 static void
662 overrun_check_free (POINTER_TYPE *block)
664 unsigned char *val = (unsigned char *) block;
666 ++check_depth;
667 if (val
668 && check_depth == 1
669 && memcmp (xmalloc_overrun_check_header,
670 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
671 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
673 size_t osize = xmalloc_get_size (val);
674 if (memcmp (xmalloc_overrun_check_trailer, val + osize,
675 XMALLOC_OVERRUN_CHECK_SIZE))
676 abort ();
677 #ifdef XMALLOC_CLEAR_FREE_MEMORY
678 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
679 memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_OVERHEAD);
680 #else
681 memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
682 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
683 memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
684 #endif
687 free (val);
688 --check_depth;
691 #undef malloc
692 #undef realloc
693 #undef free
694 #define malloc overrun_check_malloc
695 #define realloc overrun_check_realloc
696 #define free overrun_check_free
697 #endif
699 #ifdef SYNC_INPUT
700 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
701 there's no need to block input around malloc. */
702 #define MALLOC_BLOCK_INPUT ((void)0)
703 #define MALLOC_UNBLOCK_INPUT ((void)0)
704 #else
705 #define MALLOC_BLOCK_INPUT BLOCK_INPUT
706 #define MALLOC_UNBLOCK_INPUT UNBLOCK_INPUT
707 #endif
709 /* Like malloc but check for no memory and block interrupt input.. */
711 POINTER_TYPE *
712 xmalloc (size_t size)
714 register POINTER_TYPE *val;
716 MALLOC_BLOCK_INPUT;
717 val = (POINTER_TYPE *) malloc (size);
718 MALLOC_UNBLOCK_INPUT;
720 if (!val && size)
721 memory_full (size);
722 return val;
726 /* Like realloc but check for no memory and block interrupt input.. */
728 POINTER_TYPE *
729 xrealloc (POINTER_TYPE *block, size_t size)
731 register POINTER_TYPE *val;
733 MALLOC_BLOCK_INPUT;
734 /* We must call malloc explicitly when BLOCK is 0, since some
735 reallocs don't do this. */
736 if (! block)
737 val = (POINTER_TYPE *) malloc (size);
738 else
739 val = (POINTER_TYPE *) realloc (block, size);
740 MALLOC_UNBLOCK_INPUT;
742 if (!val && size)
743 memory_full (size);
744 return val;
748 /* Like free but block interrupt input. */
750 void
751 xfree (POINTER_TYPE *block)
753 if (!block)
754 return;
755 MALLOC_BLOCK_INPUT;
756 free (block);
757 MALLOC_UNBLOCK_INPUT;
758 /* We don't call refill_memory_reserve here
759 because that duplicates doing so in emacs_blocked_free
760 and the criterion should go there. */
764 /* Other parts of Emacs pass large int values to allocator functions
765 expecting ptrdiff_t. This is portable in practice, but check it to
766 be safe. */
767 verify (INT_MAX <= PTRDIFF_MAX);
770 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
771 Signal an error on memory exhaustion, and block interrupt input. */
773 void *
774 xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size)
776 xassert (0 <= nitems && 0 < item_size);
777 if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems)
778 memory_full (SIZE_MAX);
779 return xmalloc (nitems * item_size);
783 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
784 Signal an error on memory exhaustion, and block interrupt input. */
786 void *
787 xnrealloc (void *pa, ptrdiff_t nitems, ptrdiff_t item_size)
789 xassert (0 <= nitems && 0 < item_size);
790 if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems)
791 memory_full (SIZE_MAX);
792 return xrealloc (pa, nitems * item_size);
796 /* Grow PA, which points to an array of *NITEMS items, and return the
797 location of the reallocated array, updating *NITEMS to reflect its
798 new size. The new array will contain at least NITEMS_INCR_MIN more
799 items, but will not contain more than NITEMS_MAX items total.
800 ITEM_SIZE is the size of each item, in bytes.
802 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
803 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
804 infinity.
806 If PA is null, then allocate a new array instead of reallocating
807 the old one. Thus, to grow an array A without saving its old
808 contents, invoke xfree (A) immediately followed by xgrowalloc (0,
809 &NITEMS, ...).
811 Block interrupt input as needed. If memory exhaustion occurs, set
812 *NITEMS to zero if PA is null, and signal an error (i.e., do not
813 return). */
815 void *
816 xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
817 ptrdiff_t nitems_max, ptrdiff_t item_size)
819 /* The approximate size to use for initial small allocation
820 requests. This is the largest "small" request for the GNU C
821 library malloc. */
822 enum { DEFAULT_MXFAST = 64 * sizeof (size_t) / 4 };
824 /* If the array is tiny, grow it to about (but no greater than)
825 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
826 ptrdiff_t n = *nitems;
827 ptrdiff_t tiny_max = DEFAULT_MXFAST / item_size - n;
828 ptrdiff_t half_again = n >> 1;
829 ptrdiff_t incr_estimate = max (tiny_max, half_again);
831 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
832 NITEMS_MAX, and what the C language can represent safely. */
833 ptrdiff_t C_language_max = min (PTRDIFF_MAX, SIZE_MAX) / item_size;
834 ptrdiff_t n_max = (0 <= nitems_max && nitems_max < C_language_max
835 ? nitems_max : C_language_max);
836 ptrdiff_t nitems_incr_max = n_max - n;
837 ptrdiff_t incr = max (nitems_incr_min, min (incr_estimate, nitems_incr_max));
839 xassert (0 < item_size && 0 < nitems_incr_min && 0 <= n && -1 <= nitems_max);
840 if (! pa)
841 *nitems = 0;
842 if (nitems_incr_max < incr)
843 memory_full (SIZE_MAX);
844 n += incr;
845 pa = xrealloc (pa, n * item_size);
846 *nitems = n;
847 return pa;
851 /* Like strdup, but uses xmalloc. */
853 char *
854 xstrdup (const char *s)
856 size_t len = strlen (s) + 1;
857 char *p = (char *) xmalloc (len);
858 memcpy (p, s, len);
859 return p;
863 /* Unwind for SAFE_ALLOCA */
865 Lisp_Object
866 safe_alloca_unwind (Lisp_Object arg)
868 register struct Lisp_Save_Value *p = XSAVE_VALUE (arg);
870 p->dogc = 0;
871 xfree (p->pointer);
872 p->pointer = 0;
873 free_misc (arg);
874 return Qnil;
878 /* Like malloc but used for allocating Lisp data. NBYTES is the
879 number of bytes to allocate, TYPE describes the intended use of the
880 allocated memory block (for strings, for conses, ...). */
882 #ifndef USE_LSB_TAG
883 static void *lisp_malloc_loser;
884 #endif
886 static POINTER_TYPE *
887 lisp_malloc (size_t nbytes, enum mem_type type)
889 register void *val;
891 MALLOC_BLOCK_INPUT;
893 #ifdef GC_MALLOC_CHECK
894 allocated_mem_type = type;
895 #endif
897 val = (void *) malloc (nbytes);
899 #ifndef USE_LSB_TAG
900 /* If the memory just allocated cannot be addressed thru a Lisp
901 object's pointer, and it needs to be,
902 that's equivalent to running out of memory. */
903 if (val && type != MEM_TYPE_NON_LISP)
905 Lisp_Object tem;
906 XSETCONS (tem, (char *) val + nbytes - 1);
907 if ((char *) XCONS (tem) != (char *) val + nbytes - 1)
909 lisp_malloc_loser = val;
910 free (val);
911 val = 0;
914 #endif
916 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
917 if (val && type != MEM_TYPE_NON_LISP)
918 mem_insert (val, (char *) val + nbytes, type);
919 #endif
921 MALLOC_UNBLOCK_INPUT;
922 if (!val && nbytes)
923 memory_full (nbytes);
924 return val;
927 /* Free BLOCK. This must be called to free memory allocated with a
928 call to lisp_malloc. */
930 static void
931 lisp_free (POINTER_TYPE *block)
933 MALLOC_BLOCK_INPUT;
934 free (block);
935 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
936 mem_delete (mem_find (block));
937 #endif
938 MALLOC_UNBLOCK_INPUT;
941 /* Allocation of aligned blocks of memory to store Lisp data. */
942 /* The entry point is lisp_align_malloc which returns blocks of at most */
943 /* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
945 /* Use posix_memalloc if the system has it and we're using the system's
946 malloc (because our gmalloc.c routines don't have posix_memalign although
947 its memalloc could be used). */
948 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
949 #define USE_POSIX_MEMALIGN 1
950 #endif
952 /* BLOCK_ALIGN has to be a power of 2. */
953 #define BLOCK_ALIGN (1 << 10)
955 /* Padding to leave at the end of a malloc'd block. This is to give
956 malloc a chance to minimize the amount of memory wasted to alignment.
957 It should be tuned to the particular malloc library used.
958 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
959 posix_memalign on the other hand would ideally prefer a value of 4
960 because otherwise, there's 1020 bytes wasted between each ablocks.
961 In Emacs, testing shows that those 1020 can most of the time be
962 efficiently used by malloc to place other objects, so a value of 0 can
963 still preferable unless you have a lot of aligned blocks and virtually
964 nothing else. */
965 #define BLOCK_PADDING 0
966 #define BLOCK_BYTES \
967 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
969 /* Internal data structures and constants. */
971 #define ABLOCKS_SIZE 16
973 /* An aligned block of memory. */
974 struct ablock
976 union
978 char payload[BLOCK_BYTES];
979 struct ablock *next_free;
980 } x;
981 /* `abase' is the aligned base of the ablocks. */
982 /* It is overloaded to hold the virtual `busy' field that counts
983 the number of used ablock in the parent ablocks.
984 The first ablock has the `busy' field, the others have the `abase'
985 field. To tell the difference, we assume that pointers will have
986 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
987 is used to tell whether the real base of the parent ablocks is `abase'
988 (if not, the word before the first ablock holds a pointer to the
989 real base). */
990 struct ablocks *abase;
991 /* The padding of all but the last ablock is unused. The padding of
992 the last ablock in an ablocks is not allocated. */
993 #if BLOCK_PADDING
994 char padding[BLOCK_PADDING];
995 #endif
998 /* A bunch of consecutive aligned blocks. */
999 struct ablocks
1001 struct ablock blocks[ABLOCKS_SIZE];
1004 /* Size of the block requested from malloc or memalign. */
1005 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
1007 #define ABLOCK_ABASE(block) \
1008 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
1009 ? (struct ablocks *)(block) \
1010 : (block)->abase)
1012 /* Virtual `busy' field. */
1013 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
1015 /* Pointer to the (not necessarily aligned) malloc block. */
1016 #ifdef USE_POSIX_MEMALIGN
1017 #define ABLOCKS_BASE(abase) (abase)
1018 #else
1019 #define ABLOCKS_BASE(abase) \
1020 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
1021 #endif
1023 /* The list of free ablock. */
1024 static struct ablock *free_ablock;
1026 /* Allocate an aligned block of nbytes.
1027 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
1028 smaller or equal to BLOCK_BYTES. */
1029 static POINTER_TYPE *
1030 lisp_align_malloc (size_t nbytes, enum mem_type type)
1032 void *base, *val;
1033 struct ablocks *abase;
1035 eassert (nbytes <= BLOCK_BYTES);
1037 MALLOC_BLOCK_INPUT;
1039 #ifdef GC_MALLOC_CHECK
1040 allocated_mem_type = type;
1041 #endif
1043 if (!free_ablock)
1045 int i;
1046 intptr_t aligned; /* int gets warning casting to 64-bit pointer. */
1048 #ifdef DOUG_LEA_MALLOC
1049 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1050 because mapped region contents are not preserved in
1051 a dumped Emacs. */
1052 mallopt (M_MMAP_MAX, 0);
1053 #endif
1055 #ifdef USE_POSIX_MEMALIGN
1057 int err = posix_memalign (&base, BLOCK_ALIGN, ABLOCKS_BYTES);
1058 if (err)
1059 base = NULL;
1060 abase = base;
1062 #else
1063 base = malloc (ABLOCKS_BYTES);
1064 abase = ALIGN (base, BLOCK_ALIGN);
1065 #endif
1067 if (base == 0)
1069 MALLOC_UNBLOCK_INPUT;
1070 memory_full (ABLOCKS_BYTES);
1073 aligned = (base == abase);
1074 if (!aligned)
1075 ((void**)abase)[-1] = base;
1077 #ifdef DOUG_LEA_MALLOC
1078 /* Back to a reasonable maximum of mmap'ed areas. */
1079 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
1080 #endif
1082 #ifndef USE_LSB_TAG
1083 /* If the memory just allocated cannot be addressed thru a Lisp
1084 object's pointer, and it needs to be, that's equivalent to
1085 running out of memory. */
1086 if (type != MEM_TYPE_NON_LISP)
1088 Lisp_Object tem;
1089 char *end = (char *) base + ABLOCKS_BYTES - 1;
1090 XSETCONS (tem, end);
1091 if ((char *) XCONS (tem) != end)
1093 lisp_malloc_loser = base;
1094 free (base);
1095 MALLOC_UNBLOCK_INPUT;
1096 memory_full (SIZE_MAX);
1099 #endif
1101 /* Initialize the blocks and put them on the free list.
1102 Is `base' was not properly aligned, we can't use the last block. */
1103 for (i = 0; i < (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1); i++)
1105 abase->blocks[i].abase = abase;
1106 abase->blocks[i].x.next_free = free_ablock;
1107 free_ablock = &abase->blocks[i];
1109 ABLOCKS_BUSY (abase) = (struct ablocks *) aligned;
1111 eassert (0 == ((uintptr_t) abase) % BLOCK_ALIGN);
1112 eassert (ABLOCK_ABASE (&abase->blocks[3]) == abase); /* 3 is arbitrary */
1113 eassert (ABLOCK_ABASE (&abase->blocks[0]) == abase);
1114 eassert (ABLOCKS_BASE (abase) == base);
1115 eassert (aligned == (intptr_t) ABLOCKS_BUSY (abase));
1118 abase = ABLOCK_ABASE (free_ablock);
1119 ABLOCKS_BUSY (abase) =
1120 (struct ablocks *) (2 + (intptr_t) ABLOCKS_BUSY (abase));
1121 val = free_ablock;
1122 free_ablock = free_ablock->x.next_free;
1124 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1125 if (type != MEM_TYPE_NON_LISP)
1126 mem_insert (val, (char *) val + nbytes, type);
1127 #endif
1129 MALLOC_UNBLOCK_INPUT;
1131 eassert (0 == ((uintptr_t) val) % BLOCK_ALIGN);
1132 return val;
1135 static void
1136 lisp_align_free (POINTER_TYPE *block)
1138 struct ablock *ablock = block;
1139 struct ablocks *abase = ABLOCK_ABASE (ablock);
1141 MALLOC_BLOCK_INPUT;
1142 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1143 mem_delete (mem_find (block));
1144 #endif
1145 /* Put on free list. */
1146 ablock->x.next_free = free_ablock;
1147 free_ablock = ablock;
1148 /* Update busy count. */
1149 ABLOCKS_BUSY (abase) =
1150 (struct ablocks *) (-2 + (intptr_t) ABLOCKS_BUSY (abase));
1152 if (2 > (intptr_t) ABLOCKS_BUSY (abase))
1153 { /* All the blocks are free. */
1154 int i = 0, aligned = (intptr_t) ABLOCKS_BUSY (abase);
1155 struct ablock **tem = &free_ablock;
1156 struct ablock *atop = &abase->blocks[aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1];
1158 while (*tem)
1160 if (*tem >= (struct ablock *) abase && *tem < atop)
1162 i++;
1163 *tem = (*tem)->x.next_free;
1165 else
1166 tem = &(*tem)->x.next_free;
1168 eassert ((aligned & 1) == aligned);
1169 eassert (i == (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1));
1170 #ifdef USE_POSIX_MEMALIGN
1171 eassert ((uintptr_t) ABLOCKS_BASE (abase) % BLOCK_ALIGN == 0);
1172 #endif
1173 free (ABLOCKS_BASE (abase));
1175 MALLOC_UNBLOCK_INPUT;
1178 /* Return a new buffer structure allocated from the heap with
1179 a call to lisp_malloc. */
1181 struct buffer *
1182 allocate_buffer (void)
1184 struct buffer *b
1185 = (struct buffer *) lisp_malloc (sizeof (struct buffer),
1186 MEM_TYPE_BUFFER);
1187 XSETPVECTYPESIZE (b, PVEC_BUFFER,
1188 ((sizeof (struct buffer) + sizeof (EMACS_INT) - 1)
1189 / sizeof (EMACS_INT)));
1190 return b;
1194 #ifndef SYSTEM_MALLOC
1196 /* Arranging to disable input signals while we're in malloc.
1198 This only works with GNU malloc. To help out systems which can't
1199 use GNU malloc, all the calls to malloc, realloc, and free
1200 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
1201 pair; unfortunately, we have no idea what C library functions
1202 might call malloc, so we can't really protect them unless you're
1203 using GNU malloc. Fortunately, most of the major operating systems
1204 can use GNU malloc. */
1206 #ifndef SYNC_INPUT
1207 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
1208 there's no need to block input around malloc. */
1210 #ifndef DOUG_LEA_MALLOC
1211 extern void * (*__malloc_hook) (size_t, const void *);
1212 extern void * (*__realloc_hook) (void *, size_t, const void *);
1213 extern void (*__free_hook) (void *, const void *);
1214 /* Else declared in malloc.h, perhaps with an extra arg. */
1215 #endif /* DOUG_LEA_MALLOC */
1216 static void * (*old_malloc_hook) (size_t, const void *);
1217 static void * (*old_realloc_hook) (void *, size_t, const void*);
1218 static void (*old_free_hook) (void*, const void*);
1220 #ifdef DOUG_LEA_MALLOC
1221 # define BYTES_USED (mallinfo ().uordblks)
1222 #else
1223 # define BYTES_USED _bytes_used
1224 #endif
1226 static size_t bytes_used_when_reconsidered;
1228 /* Value of _bytes_used, when spare_memory was freed. */
1230 static size_t bytes_used_when_full;
1232 /* This function is used as the hook for free to call. */
1234 static void
1235 emacs_blocked_free (void *ptr, const void *ptr2)
1237 BLOCK_INPUT_ALLOC;
1239 #ifdef GC_MALLOC_CHECK
1240 if (ptr)
1242 struct mem_node *m;
1244 m = mem_find (ptr);
1245 if (m == MEM_NIL || m->start != ptr)
1247 fprintf (stderr,
1248 "Freeing `%p' which wasn't allocated with malloc\n", ptr);
1249 abort ();
1251 else
1253 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
1254 mem_delete (m);
1257 #endif /* GC_MALLOC_CHECK */
1259 __free_hook = old_free_hook;
1260 free (ptr);
1262 /* If we released our reserve (due to running out of memory),
1263 and we have a fair amount free once again,
1264 try to set aside another reserve in case we run out once more. */
1265 if (! NILP (Vmemory_full)
1266 /* Verify there is enough space that even with the malloc
1267 hysteresis this call won't run out again.
1268 The code here is correct as long as SPARE_MEMORY
1269 is substantially larger than the block size malloc uses. */
1270 && (bytes_used_when_full
1271 > ((bytes_used_when_reconsidered = BYTES_USED)
1272 + max (malloc_hysteresis, 4) * SPARE_MEMORY)))
1273 refill_memory_reserve ();
1275 __free_hook = emacs_blocked_free;
1276 UNBLOCK_INPUT_ALLOC;
1280 /* This function is the malloc hook that Emacs uses. */
1282 static void *
1283 emacs_blocked_malloc (size_t size, const void *ptr)
1285 void *value;
1287 BLOCK_INPUT_ALLOC;
1288 __malloc_hook = old_malloc_hook;
1289 #ifdef DOUG_LEA_MALLOC
1290 /* Segfaults on my system. --lorentey */
1291 /* mallopt (M_TOP_PAD, malloc_hysteresis * 4096); */
1292 #else
1293 __malloc_extra_blocks = malloc_hysteresis;
1294 #endif
1296 value = (void *) malloc (size);
1298 #ifdef GC_MALLOC_CHECK
1300 struct mem_node *m = mem_find (value);
1301 if (m != MEM_NIL)
1303 fprintf (stderr, "Malloc returned %p which is already in use\n",
1304 value);
1305 fprintf (stderr, "Region in use is %p...%p, %u bytes, type %d\n",
1306 m->start, m->end, (char *) m->end - (char *) m->start,
1307 m->type);
1308 abort ();
1311 if (!dont_register_blocks)
1313 mem_insert (value, (char *) value + max (1, size), allocated_mem_type);
1314 allocated_mem_type = MEM_TYPE_NON_LISP;
1317 #endif /* GC_MALLOC_CHECK */
1319 __malloc_hook = emacs_blocked_malloc;
1320 UNBLOCK_INPUT_ALLOC;
1322 /* fprintf (stderr, "%p malloc\n", value); */
1323 return value;
1327 /* This function is the realloc hook that Emacs uses. */
1329 static void *
1330 emacs_blocked_realloc (void *ptr, size_t size, const void *ptr2)
1332 void *value;
1334 BLOCK_INPUT_ALLOC;
1335 __realloc_hook = old_realloc_hook;
1337 #ifdef GC_MALLOC_CHECK
1338 if (ptr)
1340 struct mem_node *m = mem_find (ptr);
1341 if (m == MEM_NIL || m->start != ptr)
1343 fprintf (stderr,
1344 "Realloc of %p which wasn't allocated with malloc\n",
1345 ptr);
1346 abort ();
1349 mem_delete (m);
1352 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1354 /* Prevent malloc from registering blocks. */
1355 dont_register_blocks = 1;
1356 #endif /* GC_MALLOC_CHECK */
1358 value = (void *) realloc (ptr, size);
1360 #ifdef GC_MALLOC_CHECK
1361 dont_register_blocks = 0;
1364 struct mem_node *m = mem_find (value);
1365 if (m != MEM_NIL)
1367 fprintf (stderr, "Realloc returns memory that is already in use\n");
1368 abort ();
1371 /* Can't handle zero size regions in the red-black tree. */
1372 mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP);
1375 /* fprintf (stderr, "%p <- realloc\n", value); */
1376 #endif /* GC_MALLOC_CHECK */
1378 __realloc_hook = emacs_blocked_realloc;
1379 UNBLOCK_INPUT_ALLOC;
1381 return value;
1385 #ifdef HAVE_PTHREAD
1386 /* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
1387 normal malloc. Some thread implementations need this as they call
1388 malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
1389 calls malloc because it is the first call, and we have an endless loop. */
1391 void
1392 reset_malloc_hooks (void)
1394 __free_hook = old_free_hook;
1395 __malloc_hook = old_malloc_hook;
1396 __realloc_hook = old_realloc_hook;
1398 #endif /* HAVE_PTHREAD */
1401 /* Called from main to set up malloc to use our hooks. */
1403 void
1404 uninterrupt_malloc (void)
1406 #ifdef HAVE_PTHREAD
1407 #ifdef DOUG_LEA_MALLOC
1408 pthread_mutexattr_t attr;
1410 /* GLIBC has a faster way to do this, but let's keep it portable.
1411 This is according to the Single UNIX Specification. */
1412 pthread_mutexattr_init (&attr);
1413 pthread_mutexattr_settype (&attr, PTHREAD_MUTEX_RECURSIVE);
1414 pthread_mutex_init (&alloc_mutex, &attr);
1415 #else /* !DOUG_LEA_MALLOC */
1416 /* Some systems such as Solaris 2.6 don't have a recursive mutex,
1417 and the bundled gmalloc.c doesn't require it. */
1418 pthread_mutex_init (&alloc_mutex, NULL);
1419 #endif /* !DOUG_LEA_MALLOC */
1420 #endif /* HAVE_PTHREAD */
1422 if (__free_hook != emacs_blocked_free)
1423 old_free_hook = __free_hook;
1424 __free_hook = emacs_blocked_free;
1426 if (__malloc_hook != emacs_blocked_malloc)
1427 old_malloc_hook = __malloc_hook;
1428 __malloc_hook = emacs_blocked_malloc;
1430 if (__realloc_hook != emacs_blocked_realloc)
1431 old_realloc_hook = __realloc_hook;
1432 __realloc_hook = emacs_blocked_realloc;
1435 #endif /* not SYNC_INPUT */
1436 #endif /* not SYSTEM_MALLOC */
1440 /***********************************************************************
1441 Interval Allocation
1442 ***********************************************************************/
1444 /* Number of intervals allocated in an interval_block structure.
1445 The 1020 is 1024 minus malloc overhead. */
1447 #define INTERVAL_BLOCK_SIZE \
1448 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1450 /* Intervals are allocated in chunks in form of an interval_block
1451 structure. */
1453 struct interval_block
1455 /* Place `intervals' first, to preserve alignment. */
1456 struct interval intervals[INTERVAL_BLOCK_SIZE];
1457 struct interval_block *next;
1460 /* Current interval block. Its `next' pointer points to older
1461 blocks. */
1463 static struct interval_block *interval_block;
1465 /* Index in interval_block above of the next unused interval
1466 structure. */
1468 static int interval_block_index;
1470 /* Number of free and live intervals. */
1472 static EMACS_INT total_free_intervals, total_intervals;
1474 /* List of free intervals. */
1476 static INTERVAL interval_free_list;
1479 /* Initialize interval allocation. */
1481 static void
1482 init_intervals (void)
1484 interval_block = NULL;
1485 interval_block_index = INTERVAL_BLOCK_SIZE;
1486 interval_free_list = 0;
1490 /* Return a new interval. */
1492 INTERVAL
1493 make_interval (void)
1495 INTERVAL val;
1497 /* eassert (!handling_signal); */
1499 MALLOC_BLOCK_INPUT;
1501 if (interval_free_list)
1503 val = interval_free_list;
1504 interval_free_list = INTERVAL_PARENT (interval_free_list);
1506 else
1508 if (interval_block_index == INTERVAL_BLOCK_SIZE)
1510 register struct interval_block *newi;
1512 newi = (struct interval_block *) lisp_malloc (sizeof *newi,
1513 MEM_TYPE_NON_LISP);
1515 newi->next = interval_block;
1516 interval_block = newi;
1517 interval_block_index = 0;
1519 val = &interval_block->intervals[interval_block_index++];
1522 MALLOC_UNBLOCK_INPUT;
1524 consing_since_gc += sizeof (struct interval);
1525 intervals_consed++;
1526 RESET_INTERVAL (val);
1527 val->gcmarkbit = 0;
1528 return val;
1532 /* Mark Lisp objects in interval I. */
1534 static void
1535 mark_interval (register INTERVAL i, Lisp_Object dummy)
1537 eassert (!i->gcmarkbit); /* Intervals are never shared. */
1538 i->gcmarkbit = 1;
1539 mark_object (i->plist);
1543 /* Mark the interval tree rooted in TREE. Don't call this directly;
1544 use the macro MARK_INTERVAL_TREE instead. */
1546 static void
1547 mark_interval_tree (register INTERVAL tree)
1549 /* No need to test if this tree has been marked already; this
1550 function is always called through the MARK_INTERVAL_TREE macro,
1551 which takes care of that. */
1553 traverse_intervals_noorder (tree, mark_interval, Qnil);
1557 /* Mark the interval tree rooted in I. */
1559 #define MARK_INTERVAL_TREE(i) \
1560 do { \
1561 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
1562 mark_interval_tree (i); \
1563 } while (0)
1566 #define UNMARK_BALANCE_INTERVALS(i) \
1567 do { \
1568 if (! NULL_INTERVAL_P (i)) \
1569 (i) = balance_intervals (i); \
1570 } while (0)
1573 /* Number support. If USE_LISP_UNION_TYPE is in effect, we
1574 can't create number objects in macros. */
1575 #ifndef make_number
1576 Lisp_Object
1577 make_number (EMACS_INT n)
1579 Lisp_Object obj;
1580 obj.s.val = n;
1581 obj.s.type = Lisp_Int;
1582 return obj;
1584 #endif
1586 /* Convert the pointer-sized word P to EMACS_INT while preserving its
1587 type and ptr fields. */
1588 static Lisp_Object
1589 widen_to_Lisp_Object (void *p)
1591 intptr_t i = (intptr_t) p;
1592 #ifdef USE_LISP_UNION_TYPE
1593 Lisp_Object obj;
1594 obj.i = i;
1595 return obj;
1596 #else
1597 return i;
1598 #endif
1601 /***********************************************************************
1602 String Allocation
1603 ***********************************************************************/
1605 /* Lisp_Strings are allocated in string_block structures. When a new
1606 string_block is allocated, all the Lisp_Strings it contains are
1607 added to a free-list string_free_list. When a new Lisp_String is
1608 needed, it is taken from that list. During the sweep phase of GC,
1609 string_blocks that are entirely free are freed, except two which
1610 we keep.
1612 String data is allocated from sblock structures. Strings larger
1613 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1614 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1616 Sblocks consist internally of sdata structures, one for each
1617 Lisp_String. The sdata structure points to the Lisp_String it
1618 belongs to. The Lisp_String points back to the `u.data' member of
1619 its sdata structure.
1621 When a Lisp_String is freed during GC, it is put back on
1622 string_free_list, and its `data' member and its sdata's `string'
1623 pointer is set to null. The size of the string is recorded in the
1624 `u.nbytes' member of the sdata. So, sdata structures that are no
1625 longer used, can be easily recognized, and it's easy to compact the
1626 sblocks of small strings which we do in compact_small_strings. */
1628 /* Size in bytes of an sblock structure used for small strings. This
1629 is 8192 minus malloc overhead. */
1631 #define SBLOCK_SIZE 8188
1633 /* Strings larger than this are considered large strings. String data
1634 for large strings is allocated from individual sblocks. */
1636 #define LARGE_STRING_BYTES 1024
1638 /* Structure describing string memory sub-allocated from an sblock.
1639 This is where the contents of Lisp strings are stored. */
1641 struct sdata
1643 /* Back-pointer to the string this sdata belongs to. If null, this
1644 structure is free, and the NBYTES member of the union below
1645 contains the string's byte size (the same value that STRING_BYTES
1646 would return if STRING were non-null). If non-null, STRING_BYTES
1647 (STRING) is the size of the data, and DATA contains the string's
1648 contents. */
1649 struct Lisp_String *string;
1651 #ifdef GC_CHECK_STRING_BYTES
1653 EMACS_INT nbytes;
1654 unsigned char data[1];
1656 #define SDATA_NBYTES(S) (S)->nbytes
1657 #define SDATA_DATA(S) (S)->data
1658 #define SDATA_SELECTOR(member) member
1660 #else /* not GC_CHECK_STRING_BYTES */
1662 union
1664 /* When STRING is non-null. */
1665 unsigned char data[1];
1667 /* When STRING is null. */
1668 EMACS_INT nbytes;
1669 } u;
1671 #define SDATA_NBYTES(S) (S)->u.nbytes
1672 #define SDATA_DATA(S) (S)->u.data
1673 #define SDATA_SELECTOR(member) u.member
1675 #endif /* not GC_CHECK_STRING_BYTES */
1677 #define SDATA_DATA_OFFSET offsetof (struct sdata, SDATA_SELECTOR (data))
1681 /* Structure describing a block of memory which is sub-allocated to
1682 obtain string data memory for strings. Blocks for small strings
1683 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1684 as large as needed. */
1686 struct sblock
1688 /* Next in list. */
1689 struct sblock *next;
1691 /* Pointer to the next free sdata block. This points past the end
1692 of the sblock if there isn't any space left in this block. */
1693 struct sdata *next_free;
1695 /* Start of data. */
1696 struct sdata first_data;
1699 /* Number of Lisp strings in a string_block structure. The 1020 is
1700 1024 minus malloc overhead. */
1702 #define STRING_BLOCK_SIZE \
1703 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1705 /* Structure describing a block from which Lisp_String structures
1706 are allocated. */
1708 struct string_block
1710 /* Place `strings' first, to preserve alignment. */
1711 struct Lisp_String strings[STRING_BLOCK_SIZE];
1712 struct string_block *next;
1715 /* Head and tail of the list of sblock structures holding Lisp string
1716 data. We always allocate from current_sblock. The NEXT pointers
1717 in the sblock structures go from oldest_sblock to current_sblock. */
1719 static struct sblock *oldest_sblock, *current_sblock;
1721 /* List of sblocks for large strings. */
1723 static struct sblock *large_sblocks;
1725 /* List of string_block structures. */
1727 static struct string_block *string_blocks;
1729 /* Free-list of Lisp_Strings. */
1731 static struct Lisp_String *string_free_list;
1733 /* Number of live and free Lisp_Strings. */
1735 static EMACS_INT total_strings, total_free_strings;
1737 /* Number of bytes used by live strings. */
1739 static EMACS_INT total_string_size;
1741 /* Given a pointer to a Lisp_String S which is on the free-list
1742 string_free_list, return a pointer to its successor in the
1743 free-list. */
1745 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1747 /* Return a pointer to the sdata structure belonging to Lisp string S.
1748 S must be live, i.e. S->data must not be null. S->data is actually
1749 a pointer to the `u.data' member of its sdata structure; the
1750 structure starts at a constant offset in front of that. */
1752 #define SDATA_OF_STRING(S) ((struct sdata *) ((S)->data - SDATA_DATA_OFFSET))
1755 #ifdef GC_CHECK_STRING_OVERRUN
1757 /* We check for overrun in string data blocks by appending a small
1758 "cookie" after each allocated string data block, and check for the
1759 presence of this cookie during GC. */
1761 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1762 static char const string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
1763 { '\xde', '\xad', '\xbe', '\xef' };
1765 #else
1766 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1767 #endif
1769 /* Value is the size of an sdata structure large enough to hold NBYTES
1770 bytes of string data. The value returned includes a terminating
1771 NUL byte, the size of the sdata structure, and padding. */
1773 #ifdef GC_CHECK_STRING_BYTES
1775 #define SDATA_SIZE(NBYTES) \
1776 ((SDATA_DATA_OFFSET \
1777 + (NBYTES) + 1 \
1778 + sizeof (EMACS_INT) - 1) \
1779 & ~(sizeof (EMACS_INT) - 1))
1781 #else /* not GC_CHECK_STRING_BYTES */
1783 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1784 less than the size of that member. The 'max' is not needed when
1785 SDATA_DATA_OFFSET is a multiple of sizeof (EMACS_INT), because then the
1786 alignment code reserves enough space. */
1788 #define SDATA_SIZE(NBYTES) \
1789 ((SDATA_DATA_OFFSET \
1790 + (SDATA_DATA_OFFSET % sizeof (EMACS_INT) == 0 \
1791 ? NBYTES \
1792 : max (NBYTES, sizeof (EMACS_INT) - 1)) \
1793 + 1 \
1794 + sizeof (EMACS_INT) - 1) \
1795 & ~(sizeof (EMACS_INT) - 1))
1797 #endif /* not GC_CHECK_STRING_BYTES */
1799 /* Extra bytes to allocate for each string. */
1801 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1803 /* Exact bound on the number of bytes in a string, not counting the
1804 terminating null. A string cannot contain more bytes than
1805 STRING_BYTES_BOUND, nor can it be so long that the size_t
1806 arithmetic in allocate_string_data would overflow while it is
1807 calculating a value to be passed to malloc. */
1808 #define STRING_BYTES_MAX \
1809 min (STRING_BYTES_BOUND, \
1810 ((SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD \
1811 - GC_STRING_EXTRA \
1812 - offsetof (struct sblock, first_data) \
1813 - SDATA_DATA_OFFSET) \
1814 & ~(sizeof (EMACS_INT) - 1)))
1816 /* Initialize string allocation. Called from init_alloc_once. */
1818 static void
1819 init_strings (void)
1821 total_strings = total_free_strings = total_string_size = 0;
1822 oldest_sblock = current_sblock = large_sblocks = NULL;
1823 string_blocks = NULL;
1824 string_free_list = NULL;
1825 empty_unibyte_string = make_pure_string ("", 0, 0, 0);
1826 empty_multibyte_string = make_pure_string ("", 0, 0, 1);
1830 #ifdef GC_CHECK_STRING_BYTES
1832 static int check_string_bytes_count;
1834 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1837 /* Like GC_STRING_BYTES, but with debugging check. */
1839 EMACS_INT
1840 string_bytes (struct Lisp_String *s)
1842 EMACS_INT nbytes =
1843 (s->size_byte < 0 ? s->size & ~ARRAY_MARK_FLAG : s->size_byte);
1845 if (!PURE_POINTER_P (s)
1846 && s->data
1847 && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
1848 abort ();
1849 return nbytes;
1852 /* Check validity of Lisp strings' string_bytes member in B. */
1854 static void
1855 check_sblock (struct sblock *b)
1857 struct sdata *from, *end, *from_end;
1859 end = b->next_free;
1861 for (from = &b->first_data; from < end; from = from_end)
1863 /* Compute the next FROM here because copying below may
1864 overwrite data we need to compute it. */
1865 EMACS_INT nbytes;
1867 /* Check that the string size recorded in the string is the
1868 same as the one recorded in the sdata structure. */
1869 if (from->string)
1870 CHECK_STRING_BYTES (from->string);
1872 if (from->string)
1873 nbytes = GC_STRING_BYTES (from->string);
1874 else
1875 nbytes = SDATA_NBYTES (from);
1877 nbytes = SDATA_SIZE (nbytes);
1878 from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
1883 /* Check validity of Lisp strings' string_bytes member. ALL_P
1884 non-zero means check all strings, otherwise check only most
1885 recently allocated strings. Used for hunting a bug. */
1887 static void
1888 check_string_bytes (int all_p)
1890 if (all_p)
1892 struct sblock *b;
1894 for (b = large_sblocks; b; b = b->next)
1896 struct Lisp_String *s = b->first_data.string;
1897 if (s)
1898 CHECK_STRING_BYTES (s);
1901 for (b = oldest_sblock; b; b = b->next)
1902 check_sblock (b);
1904 else
1905 check_sblock (current_sblock);
1908 #endif /* GC_CHECK_STRING_BYTES */
1910 #ifdef GC_CHECK_STRING_FREE_LIST
1912 /* Walk through the string free list looking for bogus next pointers.
1913 This may catch buffer overrun from a previous string. */
1915 static void
1916 check_string_free_list (void)
1918 struct Lisp_String *s;
1920 /* Pop a Lisp_String off the free-list. */
1921 s = string_free_list;
1922 while (s != NULL)
1924 if ((uintptr_t) s < 1024)
1925 abort ();
1926 s = NEXT_FREE_LISP_STRING (s);
1929 #else
1930 #define check_string_free_list()
1931 #endif
1933 /* Return a new Lisp_String. */
1935 static struct Lisp_String *
1936 allocate_string (void)
1938 struct Lisp_String *s;
1940 /* eassert (!handling_signal); */
1942 MALLOC_BLOCK_INPUT;
1944 /* If the free-list is empty, allocate a new string_block, and
1945 add all the Lisp_Strings in it to the free-list. */
1946 if (string_free_list == NULL)
1948 struct string_block *b;
1949 int i;
1951 b = (struct string_block *) lisp_malloc (sizeof *b, MEM_TYPE_STRING);
1952 memset (b, 0, sizeof *b);
1953 b->next = string_blocks;
1954 string_blocks = b;
1956 for (i = STRING_BLOCK_SIZE - 1; i >= 0; --i)
1958 s = b->strings + i;
1959 NEXT_FREE_LISP_STRING (s) = string_free_list;
1960 string_free_list = s;
1963 total_free_strings += STRING_BLOCK_SIZE;
1966 check_string_free_list ();
1968 /* Pop a Lisp_String off the free-list. */
1969 s = string_free_list;
1970 string_free_list = NEXT_FREE_LISP_STRING (s);
1972 MALLOC_UNBLOCK_INPUT;
1974 /* Probably not strictly necessary, but play it safe. */
1975 memset (s, 0, sizeof *s);
1977 --total_free_strings;
1978 ++total_strings;
1979 ++strings_consed;
1980 consing_since_gc += sizeof *s;
1982 #ifdef GC_CHECK_STRING_BYTES
1983 if (!noninteractive)
1985 if (++check_string_bytes_count == 200)
1987 check_string_bytes_count = 0;
1988 check_string_bytes (1);
1990 else
1991 check_string_bytes (0);
1993 #endif /* GC_CHECK_STRING_BYTES */
1995 return s;
1999 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
2000 plus a NUL byte at the end. Allocate an sdata structure for S, and
2001 set S->data to its `u.data' member. Store a NUL byte at the end of
2002 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
2003 S->data if it was initially non-null. */
2005 void
2006 allocate_string_data (struct Lisp_String *s,
2007 EMACS_INT nchars, EMACS_INT nbytes)
2009 struct sdata *data, *old_data;
2010 struct sblock *b;
2011 EMACS_INT needed, old_nbytes;
2013 if (STRING_BYTES_MAX < nbytes)
2014 string_overflow ();
2016 /* Determine the number of bytes needed to store NBYTES bytes
2017 of string data. */
2018 needed = SDATA_SIZE (nbytes);
2019 old_data = s->data ? SDATA_OF_STRING (s) : NULL;
2020 old_nbytes = GC_STRING_BYTES (s);
2022 MALLOC_BLOCK_INPUT;
2024 if (nbytes > LARGE_STRING_BYTES)
2026 size_t size = offsetof (struct sblock, first_data) + needed;
2028 #ifdef DOUG_LEA_MALLOC
2029 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2030 because mapped region contents are not preserved in
2031 a dumped Emacs.
2033 In case you think of allowing it in a dumped Emacs at the
2034 cost of not being able to re-dump, there's another reason:
2035 mmap'ed data typically have an address towards the top of the
2036 address space, which won't fit into an EMACS_INT (at least on
2037 32-bit systems with the current tagging scheme). --fx */
2038 mallopt (M_MMAP_MAX, 0);
2039 #endif
2041 b = (struct sblock *) lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP);
2043 #ifdef DOUG_LEA_MALLOC
2044 /* Back to a reasonable maximum of mmap'ed areas. */
2045 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
2046 #endif
2048 b->next_free = &b->first_data;
2049 b->first_data.string = NULL;
2050 b->next = large_sblocks;
2051 large_sblocks = b;
2053 else if (current_sblock == NULL
2054 || (((char *) current_sblock + SBLOCK_SIZE
2055 - (char *) current_sblock->next_free)
2056 < (needed + GC_STRING_EXTRA)))
2058 /* Not enough room in the current sblock. */
2059 b = (struct sblock *) lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
2060 b->next_free = &b->first_data;
2061 b->first_data.string = NULL;
2062 b->next = NULL;
2064 if (current_sblock)
2065 current_sblock->next = b;
2066 else
2067 oldest_sblock = b;
2068 current_sblock = b;
2070 else
2071 b = current_sblock;
2073 data = b->next_free;
2074 b->next_free = (struct sdata *) ((char *) data + needed + GC_STRING_EXTRA);
2076 MALLOC_UNBLOCK_INPUT;
2078 data->string = s;
2079 s->data = SDATA_DATA (data);
2080 #ifdef GC_CHECK_STRING_BYTES
2081 SDATA_NBYTES (data) = nbytes;
2082 #endif
2083 s->size = nchars;
2084 s->size_byte = nbytes;
2085 s->data[nbytes] = '\0';
2086 #ifdef GC_CHECK_STRING_OVERRUN
2087 memcpy ((char *) data + needed, string_overrun_cookie,
2088 GC_STRING_OVERRUN_COOKIE_SIZE);
2089 #endif
2091 /* If S had already data assigned, mark that as free by setting its
2092 string back-pointer to null, and recording the size of the data
2093 in it. */
2094 if (old_data)
2096 SDATA_NBYTES (old_data) = old_nbytes;
2097 old_data->string = NULL;
2100 consing_since_gc += needed;
2104 /* Sweep and compact strings. */
2106 static void
2107 sweep_strings (void)
2109 struct string_block *b, *next;
2110 struct string_block *live_blocks = NULL;
2112 string_free_list = NULL;
2113 total_strings = total_free_strings = 0;
2114 total_string_size = 0;
2116 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2117 for (b = string_blocks; b; b = next)
2119 int i, nfree = 0;
2120 struct Lisp_String *free_list_before = string_free_list;
2122 next = b->next;
2124 for (i = 0; i < STRING_BLOCK_SIZE; ++i)
2126 struct Lisp_String *s = b->strings + i;
2128 if (s->data)
2130 /* String was not on free-list before. */
2131 if (STRING_MARKED_P (s))
2133 /* String is live; unmark it and its intervals. */
2134 UNMARK_STRING (s);
2136 if (!NULL_INTERVAL_P (s->intervals))
2137 UNMARK_BALANCE_INTERVALS (s->intervals);
2139 ++total_strings;
2140 total_string_size += STRING_BYTES (s);
2142 else
2144 /* String is dead. Put it on the free-list. */
2145 struct sdata *data = SDATA_OF_STRING (s);
2147 /* Save the size of S in its sdata so that we know
2148 how large that is. Reset the sdata's string
2149 back-pointer so that we know it's free. */
2150 #ifdef GC_CHECK_STRING_BYTES
2151 if (GC_STRING_BYTES (s) != SDATA_NBYTES (data))
2152 abort ();
2153 #else
2154 data->u.nbytes = GC_STRING_BYTES (s);
2155 #endif
2156 data->string = NULL;
2158 /* Reset the strings's `data' member so that we
2159 know it's free. */
2160 s->data = NULL;
2162 /* Put the string on the free-list. */
2163 NEXT_FREE_LISP_STRING (s) = string_free_list;
2164 string_free_list = s;
2165 ++nfree;
2168 else
2170 /* S was on the free-list before. Put it there again. */
2171 NEXT_FREE_LISP_STRING (s) = string_free_list;
2172 string_free_list = s;
2173 ++nfree;
2177 /* Free blocks that contain free Lisp_Strings only, except
2178 the first two of them. */
2179 if (nfree == STRING_BLOCK_SIZE
2180 && total_free_strings > STRING_BLOCK_SIZE)
2182 lisp_free (b);
2183 string_free_list = free_list_before;
2185 else
2187 total_free_strings += nfree;
2188 b->next = live_blocks;
2189 live_blocks = b;
2193 check_string_free_list ();
2195 string_blocks = live_blocks;
2196 free_large_strings ();
2197 compact_small_strings ();
2199 check_string_free_list ();
2203 /* Free dead large strings. */
2205 static void
2206 free_large_strings (void)
2208 struct sblock *b, *next;
2209 struct sblock *live_blocks = NULL;
2211 for (b = large_sblocks; b; b = next)
2213 next = b->next;
2215 if (b->first_data.string == NULL)
2216 lisp_free (b);
2217 else
2219 b->next = live_blocks;
2220 live_blocks = b;
2224 large_sblocks = live_blocks;
2228 /* Compact data of small strings. Free sblocks that don't contain
2229 data of live strings after compaction. */
2231 static void
2232 compact_small_strings (void)
2234 struct sblock *b, *tb, *next;
2235 struct sdata *from, *to, *end, *tb_end;
2236 struct sdata *to_end, *from_end;
2238 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2239 to, and TB_END is the end of TB. */
2240 tb = oldest_sblock;
2241 tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
2242 to = &tb->first_data;
2244 /* Step through the blocks from the oldest to the youngest. We
2245 expect that old blocks will stabilize over time, so that less
2246 copying will happen this way. */
2247 for (b = oldest_sblock; b; b = b->next)
2249 end = b->next_free;
2250 xassert ((char *) end <= (char *) b + SBLOCK_SIZE);
2252 for (from = &b->first_data; from < end; from = from_end)
2254 /* Compute the next FROM here because copying below may
2255 overwrite data we need to compute it. */
2256 EMACS_INT nbytes;
2258 #ifdef GC_CHECK_STRING_BYTES
2259 /* Check that the string size recorded in the string is the
2260 same as the one recorded in the sdata structure. */
2261 if (from->string
2262 && GC_STRING_BYTES (from->string) != SDATA_NBYTES (from))
2263 abort ();
2264 #endif /* GC_CHECK_STRING_BYTES */
2266 if (from->string)
2267 nbytes = GC_STRING_BYTES (from->string);
2268 else
2269 nbytes = SDATA_NBYTES (from);
2271 if (nbytes > LARGE_STRING_BYTES)
2272 abort ();
2274 nbytes = SDATA_SIZE (nbytes);
2275 from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
2277 #ifdef GC_CHECK_STRING_OVERRUN
2278 if (memcmp (string_overrun_cookie,
2279 (char *) from_end - GC_STRING_OVERRUN_COOKIE_SIZE,
2280 GC_STRING_OVERRUN_COOKIE_SIZE))
2281 abort ();
2282 #endif
2284 /* FROM->string non-null means it's alive. Copy its data. */
2285 if (from->string)
2287 /* If TB is full, proceed with the next sblock. */
2288 to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
2289 if (to_end > tb_end)
2291 tb->next_free = to;
2292 tb = tb->next;
2293 tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
2294 to = &tb->first_data;
2295 to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
2298 /* Copy, and update the string's `data' pointer. */
2299 if (from != to)
2301 xassert (tb != b || to < from);
2302 memmove (to, from, nbytes + GC_STRING_EXTRA);
2303 to->string->data = SDATA_DATA (to);
2306 /* Advance past the sdata we copied to. */
2307 to = to_end;
2312 /* The rest of the sblocks following TB don't contain live data, so
2313 we can free them. */
2314 for (b = tb->next; b; b = next)
2316 next = b->next;
2317 lisp_free (b);
2320 tb->next_free = to;
2321 tb->next = NULL;
2322 current_sblock = tb;
2325 void
2326 string_overflow (void)
2328 error ("Maximum string size exceeded");
2331 DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
2332 doc: /* Return a newly created string of length LENGTH, with INIT in each element.
2333 LENGTH must be an integer.
2334 INIT must be an integer that represents a character. */)
2335 (Lisp_Object length, Lisp_Object init)
2337 register Lisp_Object val;
2338 register unsigned char *p, *end;
2339 int c;
2340 EMACS_INT nbytes;
2342 CHECK_NATNUM (length);
2343 CHECK_CHARACTER (init);
2345 c = XFASTINT (init);
2346 if (ASCII_CHAR_P (c))
2348 nbytes = XINT (length);
2349 val = make_uninit_string (nbytes);
2350 p = SDATA (val);
2351 end = p + SCHARS (val);
2352 while (p != end)
2353 *p++ = c;
2355 else
2357 unsigned char str[MAX_MULTIBYTE_LENGTH];
2358 int len = CHAR_STRING (c, str);
2359 EMACS_INT string_len = XINT (length);
2361 if (string_len > STRING_BYTES_MAX / len)
2362 string_overflow ();
2363 nbytes = len * string_len;
2364 val = make_uninit_multibyte_string (string_len, nbytes);
2365 p = SDATA (val);
2366 end = p + nbytes;
2367 while (p != end)
2369 memcpy (p, str, len);
2370 p += len;
2374 *p = 0;
2375 return val;
2379 DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
2380 doc: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2381 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2382 (Lisp_Object length, Lisp_Object init)
2384 register Lisp_Object val;
2385 struct Lisp_Bool_Vector *p;
2386 EMACS_INT length_in_chars, length_in_elts;
2387 int bits_per_value;
2389 CHECK_NATNUM (length);
2391 bits_per_value = sizeof (EMACS_INT) * BOOL_VECTOR_BITS_PER_CHAR;
2393 length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
2394 length_in_chars = ((XFASTINT (length) + BOOL_VECTOR_BITS_PER_CHAR - 1)
2395 / BOOL_VECTOR_BITS_PER_CHAR);
2397 /* We must allocate one more elements than LENGTH_IN_ELTS for the
2398 slot `size' of the struct Lisp_Bool_Vector. */
2399 val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
2401 /* No Lisp_Object to trace in there. */
2402 XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0);
2404 p = XBOOL_VECTOR (val);
2405 p->size = XFASTINT (length);
2407 if (length_in_chars)
2409 memset (p->data, ! NILP (init) ? -1 : 0, length_in_chars);
2411 /* Clear any extraneous bits in the last byte. */
2412 p->data[length_in_chars - 1]
2413 &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
2416 return val;
2420 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2421 of characters from the contents. This string may be unibyte or
2422 multibyte, depending on the contents. */
2424 Lisp_Object
2425 make_string (const char *contents, EMACS_INT nbytes)
2427 register Lisp_Object val;
2428 EMACS_INT nchars, multibyte_nbytes;
2430 parse_str_as_multibyte ((const unsigned char *) contents, nbytes,
2431 &nchars, &multibyte_nbytes);
2432 if (nbytes == nchars || nbytes != multibyte_nbytes)
2433 /* CONTENTS contains no multibyte sequences or contains an invalid
2434 multibyte sequence. We must make unibyte string. */
2435 val = make_unibyte_string (contents, nbytes);
2436 else
2437 val = make_multibyte_string (contents, nchars, nbytes);
2438 return val;
2442 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2444 Lisp_Object
2445 make_unibyte_string (const char *contents, EMACS_INT length)
2447 register Lisp_Object val;
2448 val = make_uninit_string (length);
2449 memcpy (SDATA (val), contents, length);
2450 return val;
2454 /* Make a multibyte string from NCHARS characters occupying NBYTES
2455 bytes at CONTENTS. */
2457 Lisp_Object
2458 make_multibyte_string (const char *contents,
2459 EMACS_INT nchars, EMACS_INT nbytes)
2461 register Lisp_Object val;
2462 val = make_uninit_multibyte_string (nchars, nbytes);
2463 memcpy (SDATA (val), contents, nbytes);
2464 return val;
2468 /* Make a string from NCHARS characters occupying NBYTES bytes at
2469 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2471 Lisp_Object
2472 make_string_from_bytes (const char *contents,
2473 EMACS_INT nchars, EMACS_INT nbytes)
2475 register Lisp_Object val;
2476 val = make_uninit_multibyte_string (nchars, nbytes);
2477 memcpy (SDATA (val), contents, nbytes);
2478 if (SBYTES (val) == SCHARS (val))
2479 STRING_SET_UNIBYTE (val);
2480 return val;
2484 /* Make a string from NCHARS characters occupying NBYTES bytes at
2485 CONTENTS. The argument MULTIBYTE controls whether to label the
2486 string as multibyte. If NCHARS is negative, it counts the number of
2487 characters by itself. */
2489 Lisp_Object
2490 make_specified_string (const char *contents,
2491 EMACS_INT nchars, EMACS_INT nbytes, int multibyte)
2493 register Lisp_Object val;
2495 if (nchars < 0)
2497 if (multibyte)
2498 nchars = multibyte_chars_in_text ((const unsigned char *) contents,
2499 nbytes);
2500 else
2501 nchars = nbytes;
2503 val = make_uninit_multibyte_string (nchars, nbytes);
2504 memcpy (SDATA (val), contents, nbytes);
2505 if (!multibyte)
2506 STRING_SET_UNIBYTE (val);
2507 return val;
2511 /* Make a string from the data at STR, treating it as multibyte if the
2512 data warrants. */
2514 Lisp_Object
2515 build_string (const char *str)
2517 return make_string (str, strlen (str));
2521 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2522 occupying LENGTH bytes. */
2524 Lisp_Object
2525 make_uninit_string (EMACS_INT length)
2527 Lisp_Object val;
2529 if (!length)
2530 return empty_unibyte_string;
2531 val = make_uninit_multibyte_string (length, length);
2532 STRING_SET_UNIBYTE (val);
2533 return val;
2537 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2538 which occupy NBYTES bytes. */
2540 Lisp_Object
2541 make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes)
2543 Lisp_Object string;
2544 struct Lisp_String *s;
2546 if (nchars < 0)
2547 abort ();
2548 if (!nbytes)
2549 return empty_multibyte_string;
2551 s = allocate_string ();
2552 allocate_string_data (s, nchars, nbytes);
2553 XSETSTRING (string, s);
2554 string_chars_consed += nbytes;
2555 return string;
2560 /***********************************************************************
2561 Float Allocation
2562 ***********************************************************************/
2564 /* We store float cells inside of float_blocks, allocating a new
2565 float_block with malloc whenever necessary. Float cells reclaimed
2566 by GC are put on a free list to be reallocated before allocating
2567 any new float cells from the latest float_block. */
2569 #define FLOAT_BLOCK_SIZE \
2570 (((BLOCK_BYTES - sizeof (struct float_block *) \
2571 /* The compiler might add padding at the end. */ \
2572 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2573 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2575 #define GETMARKBIT(block,n) \
2576 (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2577 >> ((n) % (sizeof (int) * CHAR_BIT))) \
2578 & 1)
2580 #define SETMARKBIT(block,n) \
2581 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2582 |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
2584 #define UNSETMARKBIT(block,n) \
2585 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2586 &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
2588 #define FLOAT_BLOCK(fptr) \
2589 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2591 #define FLOAT_INDEX(fptr) \
2592 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2594 struct float_block
2596 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2597 struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
2598 int gcmarkbits[1 + FLOAT_BLOCK_SIZE / (sizeof (int) * CHAR_BIT)];
2599 struct float_block *next;
2602 #define FLOAT_MARKED_P(fptr) \
2603 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2605 #define FLOAT_MARK(fptr) \
2606 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2608 #define FLOAT_UNMARK(fptr) \
2609 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2611 /* Current float_block. */
2613 static struct float_block *float_block;
2615 /* Index of first unused Lisp_Float in the current float_block. */
2617 static int float_block_index;
2619 /* Free-list of Lisp_Floats. */
2621 static struct Lisp_Float *float_free_list;
2624 /* Initialize float allocation. */
2626 static void
2627 init_float (void)
2629 float_block = NULL;
2630 float_block_index = FLOAT_BLOCK_SIZE; /* Force alloc of new float_block. */
2631 float_free_list = 0;
2635 /* Return a new float object with value FLOAT_VALUE. */
2637 Lisp_Object
2638 make_float (double float_value)
2640 register Lisp_Object val;
2642 /* eassert (!handling_signal); */
2644 MALLOC_BLOCK_INPUT;
2646 if (float_free_list)
2648 /* We use the data field for chaining the free list
2649 so that we won't use the same field that has the mark bit. */
2650 XSETFLOAT (val, float_free_list);
2651 float_free_list = float_free_list->u.chain;
2653 else
2655 if (float_block_index == FLOAT_BLOCK_SIZE)
2657 register struct float_block *new;
2659 new = (struct float_block *) lisp_align_malloc (sizeof *new,
2660 MEM_TYPE_FLOAT);
2661 new->next = float_block;
2662 memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
2663 float_block = new;
2664 float_block_index = 0;
2666 XSETFLOAT (val, &float_block->floats[float_block_index]);
2667 float_block_index++;
2670 MALLOC_UNBLOCK_INPUT;
2672 XFLOAT_INIT (val, float_value);
2673 eassert (!FLOAT_MARKED_P (XFLOAT (val)));
2674 consing_since_gc += sizeof (struct Lisp_Float);
2675 floats_consed++;
2676 return val;
2681 /***********************************************************************
2682 Cons Allocation
2683 ***********************************************************************/
2685 /* We store cons cells inside of cons_blocks, allocating a new
2686 cons_block with malloc whenever necessary. Cons cells reclaimed by
2687 GC are put on a free list to be reallocated before allocating
2688 any new cons cells from the latest cons_block. */
2690 #define CONS_BLOCK_SIZE \
2691 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2692 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2694 #define CONS_BLOCK(fptr) \
2695 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2697 #define CONS_INDEX(fptr) \
2698 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2700 struct cons_block
2702 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2703 struct Lisp_Cons conses[CONS_BLOCK_SIZE];
2704 int gcmarkbits[1 + CONS_BLOCK_SIZE / (sizeof (int) * CHAR_BIT)];
2705 struct cons_block *next;
2708 #define CONS_MARKED_P(fptr) \
2709 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2711 #define CONS_MARK(fptr) \
2712 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2714 #define CONS_UNMARK(fptr) \
2715 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2717 /* Current cons_block. */
2719 static struct cons_block *cons_block;
2721 /* Index of first unused Lisp_Cons in the current block. */
2723 static int cons_block_index;
2725 /* Free-list of Lisp_Cons structures. */
2727 static struct Lisp_Cons *cons_free_list;
2730 /* Initialize cons allocation. */
2732 static void
2733 init_cons (void)
2735 cons_block = NULL;
2736 cons_block_index = CONS_BLOCK_SIZE; /* Force alloc of new cons_block. */
2737 cons_free_list = 0;
2741 /* Explicitly free a cons cell by putting it on the free-list. */
2743 void
2744 free_cons (struct Lisp_Cons *ptr)
2746 ptr->u.chain = cons_free_list;
2747 #if GC_MARK_STACK
2748 ptr->car = Vdead;
2749 #endif
2750 cons_free_list = ptr;
2753 DEFUN ("cons", Fcons, Scons, 2, 2, 0,
2754 doc: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2755 (Lisp_Object car, Lisp_Object cdr)
2757 register Lisp_Object val;
2759 /* eassert (!handling_signal); */
2761 MALLOC_BLOCK_INPUT;
2763 if (cons_free_list)
2765 /* We use the cdr for chaining the free list
2766 so that we won't use the same field that has the mark bit. */
2767 XSETCONS (val, cons_free_list);
2768 cons_free_list = cons_free_list->u.chain;
2770 else
2772 if (cons_block_index == CONS_BLOCK_SIZE)
2774 register struct cons_block *new;
2775 new = (struct cons_block *) lisp_align_malloc (sizeof *new,
2776 MEM_TYPE_CONS);
2777 memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
2778 new->next = cons_block;
2779 cons_block = new;
2780 cons_block_index = 0;
2782 XSETCONS (val, &cons_block->conses[cons_block_index]);
2783 cons_block_index++;
2786 MALLOC_UNBLOCK_INPUT;
2788 XSETCAR (val, car);
2789 XSETCDR (val, cdr);
2790 eassert (!CONS_MARKED_P (XCONS (val)));
2791 consing_since_gc += sizeof (struct Lisp_Cons);
2792 cons_cells_consed++;
2793 return val;
2796 #ifdef GC_CHECK_CONS_LIST
2797 /* Get an error now if there's any junk in the cons free list. */
2798 void
2799 check_cons_list (void)
2801 struct Lisp_Cons *tail = cons_free_list;
2803 while (tail)
2804 tail = tail->u.chain;
2806 #endif
2808 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2810 Lisp_Object
2811 list1 (Lisp_Object arg1)
2813 return Fcons (arg1, Qnil);
2816 Lisp_Object
2817 list2 (Lisp_Object arg1, Lisp_Object arg2)
2819 return Fcons (arg1, Fcons (arg2, Qnil));
2823 Lisp_Object
2824 list3 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
2826 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
2830 Lisp_Object
2831 list4 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4)
2833 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil))));
2837 Lisp_Object
2838 list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
2840 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
2841 Fcons (arg5, Qnil)))));
2845 DEFUN ("list", Flist, Slist, 0, MANY, 0,
2846 doc: /* Return a newly created list with specified arguments as elements.
2847 Any number of arguments, even zero arguments, are allowed.
2848 usage: (list &rest OBJECTS) */)
2849 (ptrdiff_t nargs, Lisp_Object *args)
2851 register Lisp_Object val;
2852 val = Qnil;
2854 while (nargs > 0)
2856 nargs--;
2857 val = Fcons (args[nargs], val);
2859 return val;
2863 DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
2864 doc: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2865 (register Lisp_Object length, Lisp_Object init)
2867 register Lisp_Object val;
2868 register EMACS_INT size;
2870 CHECK_NATNUM (length);
2871 size = XFASTINT (length);
2873 val = Qnil;
2874 while (size > 0)
2876 val = Fcons (init, val);
2877 --size;
2879 if (size > 0)
2881 val = Fcons (init, val);
2882 --size;
2884 if (size > 0)
2886 val = Fcons (init, val);
2887 --size;
2889 if (size > 0)
2891 val = Fcons (init, val);
2892 --size;
2894 if (size > 0)
2896 val = Fcons (init, val);
2897 --size;
2903 QUIT;
2906 return val;
2911 /***********************************************************************
2912 Vector Allocation
2913 ***********************************************************************/
2915 /* Singly-linked list of all vectors. */
2917 static struct Lisp_Vector *all_vectors;
2919 /* Handy constants for vectorlike objects. */
2920 enum
2922 header_size = offsetof (struct Lisp_Vector, contents),
2923 word_size = sizeof (Lisp_Object)
2926 /* Value is a pointer to a newly allocated Lisp_Vector structure
2927 with room for LEN Lisp_Objects. */
2929 static struct Lisp_Vector *
2930 allocate_vectorlike (EMACS_INT len)
2932 struct Lisp_Vector *p;
2933 size_t nbytes;
2935 MALLOC_BLOCK_INPUT;
2937 #ifdef DOUG_LEA_MALLOC
2938 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2939 because mapped region contents are not preserved in
2940 a dumped Emacs. */
2941 mallopt (M_MMAP_MAX, 0);
2942 #endif
2944 /* This gets triggered by code which I haven't bothered to fix. --Stef */
2945 /* eassert (!handling_signal); */
2947 nbytes = header_size + len * word_size;
2948 p = (struct Lisp_Vector *) lisp_malloc (nbytes, MEM_TYPE_VECTORLIKE);
2950 #ifdef DOUG_LEA_MALLOC
2951 /* Back to a reasonable maximum of mmap'ed areas. */
2952 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
2953 #endif
2955 consing_since_gc += nbytes;
2956 vector_cells_consed += len;
2958 p->header.next.vector = all_vectors;
2959 all_vectors = p;
2961 MALLOC_UNBLOCK_INPUT;
2963 return p;
2967 /* Allocate a vector with LEN slots. */
2969 struct Lisp_Vector *
2970 allocate_vector (EMACS_INT len)
2972 struct Lisp_Vector *v;
2973 ptrdiff_t nbytes_max = min (PTRDIFF_MAX, SIZE_MAX);
2975 if (min ((nbytes_max - header_size) / word_size, MOST_POSITIVE_FIXNUM) < len)
2976 memory_full (SIZE_MAX);
2977 v = allocate_vectorlike (len);
2978 v->header.size = len;
2979 return v;
2983 /* Allocate other vector-like structures. */
2985 struct Lisp_Vector *
2986 allocate_pseudovector (int memlen, int lisplen, EMACS_INT tag)
2988 struct Lisp_Vector *v = allocate_vectorlike (memlen);
2989 int i;
2991 /* Only the first lisplen slots will be traced normally by the GC. */
2992 for (i = 0; i < lisplen; ++i)
2993 v->contents[i] = Qnil;
2995 XSETPVECTYPESIZE (v, tag, lisplen);
2996 return v;
2999 struct Lisp_Hash_Table *
3000 allocate_hash_table (void)
3002 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table, count, PVEC_HASH_TABLE);
3006 struct window *
3007 allocate_window (void)
3009 return ALLOCATE_PSEUDOVECTOR (struct window, current_matrix, PVEC_WINDOW);
3013 struct terminal *
3014 allocate_terminal (void)
3016 struct terminal *t = ALLOCATE_PSEUDOVECTOR (struct terminal,
3017 next_terminal, PVEC_TERMINAL);
3018 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
3019 memset (&t->next_terminal, 0,
3020 (char*) (t + 1) - (char*) &t->next_terminal);
3022 return t;
3025 struct frame *
3026 allocate_frame (void)
3028 struct frame *f = ALLOCATE_PSEUDOVECTOR (struct frame,
3029 face_cache, PVEC_FRAME);
3030 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
3031 memset (&f->face_cache, 0,
3032 (char *) (f + 1) - (char *) &f->face_cache);
3033 return f;
3037 struct Lisp_Process *
3038 allocate_process (void)
3040 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS);
3044 DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
3045 doc: /* Return a newly created vector of length LENGTH, with each element being INIT.
3046 See also the function `vector'. */)
3047 (register Lisp_Object length, Lisp_Object init)
3049 Lisp_Object vector;
3050 register EMACS_INT sizei;
3051 register EMACS_INT i;
3052 register struct Lisp_Vector *p;
3054 CHECK_NATNUM (length);
3055 sizei = XFASTINT (length);
3057 p = allocate_vector (sizei);
3058 for (i = 0; i < sizei; i++)
3059 p->contents[i] = init;
3061 XSETVECTOR (vector, p);
3062 return vector;
3066 DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
3067 doc: /* Return a newly created vector with specified arguments as elements.
3068 Any number of arguments, even zero arguments, are allowed.
3069 usage: (vector &rest OBJECTS) */)
3070 (ptrdiff_t nargs, Lisp_Object *args)
3072 register Lisp_Object len, val;
3073 ptrdiff_t i;
3074 register struct Lisp_Vector *p;
3076 XSETFASTINT (len, nargs);
3077 val = Fmake_vector (len, Qnil);
3078 p = XVECTOR (val);
3079 for (i = 0; i < nargs; i++)
3080 p->contents[i] = args[i];
3081 return val;
3085 DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
3086 doc: /* Create a byte-code object with specified arguments as elements.
3087 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3088 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3089 and (optional) INTERACTIVE-SPEC.
3090 The first four arguments are required; at most six have any
3091 significance.
3092 The ARGLIST can be either like the one of `lambda', in which case the arguments
3093 will be dynamically bound before executing the byte code, or it can be an
3094 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3095 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3096 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3097 argument to catch the left-over arguments. If such an integer is used, the
3098 arguments will not be dynamically bound but will be instead pushed on the
3099 stack before executing the byte-code.
3100 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3101 (ptrdiff_t nargs, Lisp_Object *args)
3103 register Lisp_Object len, val;
3104 ptrdiff_t i;
3105 register struct Lisp_Vector *p;
3107 XSETFASTINT (len, nargs);
3108 if (!NILP (Vpurify_flag))
3109 val = make_pure_vector (nargs);
3110 else
3111 val = Fmake_vector (len, Qnil);
3113 if (nargs > 1 && STRINGP (args[1]) && STRING_MULTIBYTE (args[1]))
3114 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3115 earlier because they produced a raw 8-bit string for byte-code
3116 and now such a byte-code string is loaded as multibyte while
3117 raw 8-bit characters converted to multibyte form. Thus, now we
3118 must convert them back to the original unibyte form. */
3119 args[1] = Fstring_as_unibyte (args[1]);
3121 p = XVECTOR (val);
3122 for (i = 0; i < nargs; i++)
3124 if (!NILP (Vpurify_flag))
3125 args[i] = Fpurecopy (args[i]);
3126 p->contents[i] = args[i];
3128 XSETPVECTYPE (p, PVEC_COMPILED);
3129 XSETCOMPILED (val, p);
3130 return val;
3135 /***********************************************************************
3136 Symbol Allocation
3137 ***********************************************************************/
3139 /* Each symbol_block is just under 1020 bytes long, since malloc
3140 really allocates in units of powers of two and uses 4 bytes for its
3141 own overhead. */
3143 #define SYMBOL_BLOCK_SIZE \
3144 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
3146 struct symbol_block
3148 /* Place `symbols' first, to preserve alignment. */
3149 struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
3150 struct symbol_block *next;
3153 /* Current symbol block and index of first unused Lisp_Symbol
3154 structure in it. */
3156 static struct symbol_block *symbol_block;
3157 static int symbol_block_index;
3159 /* List of free symbols. */
3161 static struct Lisp_Symbol *symbol_free_list;
3164 /* Initialize symbol allocation. */
3166 static void
3167 init_symbol (void)
3169 symbol_block = NULL;
3170 symbol_block_index = SYMBOL_BLOCK_SIZE;
3171 symbol_free_list = 0;
3175 DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
3176 doc: /* Return a newly allocated uninterned symbol whose name is NAME.
3177 Its value and function definition are void, and its property list is nil. */)
3178 (Lisp_Object name)
3180 register Lisp_Object val;
3181 register struct Lisp_Symbol *p;
3183 CHECK_STRING (name);
3185 /* eassert (!handling_signal); */
3187 MALLOC_BLOCK_INPUT;
3189 if (symbol_free_list)
3191 XSETSYMBOL (val, symbol_free_list);
3192 symbol_free_list = symbol_free_list->next;
3194 else
3196 if (symbol_block_index == SYMBOL_BLOCK_SIZE)
3198 struct symbol_block *new;
3199 new = (struct symbol_block *) lisp_malloc (sizeof *new,
3200 MEM_TYPE_SYMBOL);
3201 new->next = symbol_block;
3202 symbol_block = new;
3203 symbol_block_index = 0;
3205 XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]);
3206 symbol_block_index++;
3209 MALLOC_UNBLOCK_INPUT;
3211 p = XSYMBOL (val);
3212 p->xname = name;
3213 p->plist = Qnil;
3214 p->redirect = SYMBOL_PLAINVAL;
3215 SET_SYMBOL_VAL (p, Qunbound);
3216 p->function = Qunbound;
3217 p->next = NULL;
3218 p->gcmarkbit = 0;
3219 p->interned = SYMBOL_UNINTERNED;
3220 p->constant = 0;
3221 p->declared_special = 0;
3222 consing_since_gc += sizeof (struct Lisp_Symbol);
3223 symbols_consed++;
3224 return val;
3229 /***********************************************************************
3230 Marker (Misc) Allocation
3231 ***********************************************************************/
3233 /* Allocation of markers and other objects that share that structure.
3234 Works like allocation of conses. */
3236 #define MARKER_BLOCK_SIZE \
3237 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
3239 struct marker_block
3241 /* Place `markers' first, to preserve alignment. */
3242 union Lisp_Misc markers[MARKER_BLOCK_SIZE];
3243 struct marker_block *next;
3246 static struct marker_block *marker_block;
3247 static int marker_block_index;
3249 static union Lisp_Misc *marker_free_list;
3251 static void
3252 init_marker (void)
3254 marker_block = NULL;
3255 marker_block_index = MARKER_BLOCK_SIZE;
3256 marker_free_list = 0;
3259 /* Return a newly allocated Lisp_Misc object, with no substructure. */
3261 Lisp_Object
3262 allocate_misc (void)
3264 Lisp_Object val;
3266 /* eassert (!handling_signal); */
3268 MALLOC_BLOCK_INPUT;
3270 if (marker_free_list)
3272 XSETMISC (val, marker_free_list);
3273 marker_free_list = marker_free_list->u_free.chain;
3275 else
3277 if (marker_block_index == MARKER_BLOCK_SIZE)
3279 struct marker_block *new;
3280 new = (struct marker_block *) lisp_malloc (sizeof *new,
3281 MEM_TYPE_MISC);
3282 new->next = marker_block;
3283 marker_block = new;
3284 marker_block_index = 0;
3285 total_free_markers += MARKER_BLOCK_SIZE;
3287 XSETMISC (val, &marker_block->markers[marker_block_index]);
3288 marker_block_index++;
3291 MALLOC_UNBLOCK_INPUT;
3293 --total_free_markers;
3294 consing_since_gc += sizeof (union Lisp_Misc);
3295 misc_objects_consed++;
3296 XMISCANY (val)->gcmarkbit = 0;
3297 return val;
3300 /* Free a Lisp_Misc object */
3302 static void
3303 free_misc (Lisp_Object misc)
3305 XMISCTYPE (misc) = Lisp_Misc_Free;
3306 XMISC (misc)->u_free.chain = marker_free_list;
3307 marker_free_list = XMISC (misc);
3309 total_free_markers++;
3312 /* Return a Lisp_Misc_Save_Value object containing POINTER and
3313 INTEGER. This is used to package C values to call record_unwind_protect.
3314 The unwind function can get the C values back using XSAVE_VALUE. */
3316 Lisp_Object
3317 make_save_value (void *pointer, ptrdiff_t integer)
3319 register Lisp_Object val;
3320 register struct Lisp_Save_Value *p;
3322 val = allocate_misc ();
3323 XMISCTYPE (val) = Lisp_Misc_Save_Value;
3324 p = XSAVE_VALUE (val);
3325 p->pointer = pointer;
3326 p->integer = integer;
3327 p->dogc = 0;
3328 return val;
3331 DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
3332 doc: /* Return a newly allocated marker which does not point at any place. */)
3333 (void)
3335 register Lisp_Object val;
3336 register struct Lisp_Marker *p;
3338 val = allocate_misc ();
3339 XMISCTYPE (val) = Lisp_Misc_Marker;
3340 p = XMARKER (val);
3341 p->buffer = 0;
3342 p->bytepos = 0;
3343 p->charpos = 0;
3344 p->next = NULL;
3345 p->insertion_type = 0;
3346 return val;
3349 /* Put MARKER back on the free list after using it temporarily. */
3351 void
3352 free_marker (Lisp_Object marker)
3354 unchain_marker (XMARKER (marker));
3355 free_misc (marker);
3359 /* Return a newly created vector or string with specified arguments as
3360 elements. If all the arguments are characters that can fit
3361 in a string of events, make a string; otherwise, make a vector.
3363 Any number of arguments, even zero arguments, are allowed. */
3365 Lisp_Object
3366 make_event_array (register int nargs, Lisp_Object *args)
3368 int i;
3370 for (i = 0; i < nargs; i++)
3371 /* The things that fit in a string
3372 are characters that are in 0...127,
3373 after discarding the meta bit and all the bits above it. */
3374 if (!INTEGERP (args[i])
3375 || (XINT (args[i]) & ~(-CHAR_META)) >= 0200)
3376 return Fvector (nargs, args);
3378 /* Since the loop exited, we know that all the things in it are
3379 characters, so we can make a string. */
3381 Lisp_Object result;
3383 result = Fmake_string (make_number (nargs), make_number (0));
3384 for (i = 0; i < nargs; i++)
3386 SSET (result, i, XINT (args[i]));
3387 /* Move the meta bit to the right place for a string char. */
3388 if (XINT (args[i]) & CHAR_META)
3389 SSET (result, i, SREF (result, i) | 0x80);
3392 return result;
3398 /************************************************************************
3399 Memory Full Handling
3400 ************************************************************************/
3403 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3404 there may have been size_t overflow so that malloc was never
3405 called, or perhaps malloc was invoked successfully but the
3406 resulting pointer had problems fitting into a tagged EMACS_INT. In
3407 either case this counts as memory being full even though malloc did
3408 not fail. */
3410 void
3411 memory_full (size_t nbytes)
3413 /* Do not go into hysterics merely because a large request failed. */
3414 int enough_free_memory = 0;
3415 if (SPARE_MEMORY < nbytes)
3417 void *p;
3419 MALLOC_BLOCK_INPUT;
3420 p = malloc (SPARE_MEMORY);
3421 if (p)
3423 free (p);
3424 enough_free_memory = 1;
3426 MALLOC_UNBLOCK_INPUT;
3429 if (! enough_free_memory)
3431 int i;
3433 Vmemory_full = Qt;
3435 memory_full_cons_threshold = sizeof (struct cons_block);
3437 /* The first time we get here, free the spare memory. */
3438 for (i = 0; i < sizeof (spare_memory) / sizeof (char *); i++)
3439 if (spare_memory[i])
3441 if (i == 0)
3442 free (spare_memory[i]);
3443 else if (i >= 1 && i <= 4)
3444 lisp_align_free (spare_memory[i]);
3445 else
3446 lisp_free (spare_memory[i]);
3447 spare_memory[i] = 0;
3450 /* Record the space now used. When it decreases substantially,
3451 we can refill the memory reserve. */
3452 #if !defined SYSTEM_MALLOC && !defined SYNC_INPUT
3453 bytes_used_when_full = BYTES_USED;
3454 #endif
3457 /* This used to call error, but if we've run out of memory, we could
3458 get infinite recursion trying to build the string. */
3459 xsignal (Qnil, Vmemory_signal_data);
3462 /* If we released our reserve (due to running out of memory),
3463 and we have a fair amount free once again,
3464 try to set aside another reserve in case we run out once more.
3466 This is called when a relocatable block is freed in ralloc.c,
3467 and also directly from this file, in case we're not using ralloc.c. */
3469 void
3470 refill_memory_reserve (void)
3472 #ifndef SYSTEM_MALLOC
3473 if (spare_memory[0] == 0)
3474 spare_memory[0] = (char *) malloc (SPARE_MEMORY);
3475 if (spare_memory[1] == 0)
3476 spare_memory[1] = (char *) lisp_align_malloc (sizeof (struct cons_block),
3477 MEM_TYPE_CONS);
3478 if (spare_memory[2] == 0)
3479 spare_memory[2] = (char *) lisp_align_malloc (sizeof (struct cons_block),
3480 MEM_TYPE_CONS);
3481 if (spare_memory[3] == 0)
3482 spare_memory[3] = (char *) lisp_align_malloc (sizeof (struct cons_block),
3483 MEM_TYPE_CONS);
3484 if (spare_memory[4] == 0)
3485 spare_memory[4] = (char *) lisp_align_malloc (sizeof (struct cons_block),
3486 MEM_TYPE_CONS);
3487 if (spare_memory[5] == 0)
3488 spare_memory[5] = (char *) lisp_malloc (sizeof (struct string_block),
3489 MEM_TYPE_STRING);
3490 if (spare_memory[6] == 0)
3491 spare_memory[6] = (char *) lisp_malloc (sizeof (struct string_block),
3492 MEM_TYPE_STRING);
3493 if (spare_memory[0] && spare_memory[1] && spare_memory[5])
3494 Vmemory_full = Qnil;
3495 #endif
3498 /************************************************************************
3499 C Stack Marking
3500 ************************************************************************/
3502 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3504 /* Conservative C stack marking requires a method to identify possibly
3505 live Lisp objects given a pointer value. We do this by keeping
3506 track of blocks of Lisp data that are allocated in a red-black tree
3507 (see also the comment of mem_node which is the type of nodes in
3508 that tree). Function lisp_malloc adds information for an allocated
3509 block to the red-black tree with calls to mem_insert, and function
3510 lisp_free removes it with mem_delete. Functions live_string_p etc
3511 call mem_find to lookup information about a given pointer in the
3512 tree, and use that to determine if the pointer points to a Lisp
3513 object or not. */
3515 /* Initialize this part of alloc.c. */
3517 static void
3518 mem_init (void)
3520 mem_z.left = mem_z.right = MEM_NIL;
3521 mem_z.parent = NULL;
3522 mem_z.color = MEM_BLACK;
3523 mem_z.start = mem_z.end = NULL;
3524 mem_root = MEM_NIL;
3528 /* Value is a pointer to the mem_node containing START. Value is
3529 MEM_NIL if there is no node in the tree containing START. */
3531 static inline struct mem_node *
3532 mem_find (void *start)
3534 struct mem_node *p;
3536 if (start < min_heap_address || start > max_heap_address)
3537 return MEM_NIL;
3539 /* Make the search always successful to speed up the loop below. */
3540 mem_z.start = start;
3541 mem_z.end = (char *) start + 1;
3543 p = mem_root;
3544 while (start < p->start || start >= p->end)
3545 p = start < p->start ? p->left : p->right;
3546 return p;
3550 /* Insert a new node into the tree for a block of memory with start
3551 address START, end address END, and type TYPE. Value is a
3552 pointer to the node that was inserted. */
3554 static struct mem_node *
3555 mem_insert (void *start, void *end, enum mem_type type)
3557 struct mem_node *c, *parent, *x;
3559 if (min_heap_address == NULL || start < min_heap_address)
3560 min_heap_address = start;
3561 if (max_heap_address == NULL || end > max_heap_address)
3562 max_heap_address = end;
3564 /* See where in the tree a node for START belongs. In this
3565 particular application, it shouldn't happen that a node is already
3566 present. For debugging purposes, let's check that. */
3567 c = mem_root;
3568 parent = NULL;
3570 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3572 while (c != MEM_NIL)
3574 if (start >= c->start && start < c->end)
3575 abort ();
3576 parent = c;
3577 c = start < c->start ? c->left : c->right;
3580 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3582 while (c != MEM_NIL)
3584 parent = c;
3585 c = start < c->start ? c->left : c->right;
3588 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3590 /* Create a new node. */
3591 #ifdef GC_MALLOC_CHECK
3592 x = (struct mem_node *) _malloc_internal (sizeof *x);
3593 if (x == NULL)
3594 abort ();
3595 #else
3596 x = (struct mem_node *) xmalloc (sizeof *x);
3597 #endif
3598 x->start = start;
3599 x->end = end;
3600 x->type = type;
3601 x->parent = parent;
3602 x->left = x->right = MEM_NIL;
3603 x->color = MEM_RED;
3605 /* Insert it as child of PARENT or install it as root. */
3606 if (parent)
3608 if (start < parent->start)
3609 parent->left = x;
3610 else
3611 parent->right = x;
3613 else
3614 mem_root = x;
3616 /* Re-establish red-black tree properties. */
3617 mem_insert_fixup (x);
3619 return x;
3623 /* Re-establish the red-black properties of the tree, and thereby
3624 balance the tree, after node X has been inserted; X is always red. */
3626 static void
3627 mem_insert_fixup (struct mem_node *x)
3629 while (x != mem_root && x->parent->color == MEM_RED)
3631 /* X is red and its parent is red. This is a violation of
3632 red-black tree property #3. */
3634 if (x->parent == x->parent->parent->left)
3636 /* We're on the left side of our grandparent, and Y is our
3637 "uncle". */
3638 struct mem_node *y = x->parent->parent->right;
3640 if (y->color == MEM_RED)
3642 /* Uncle and parent are red but should be black because
3643 X is red. Change the colors accordingly and proceed
3644 with the grandparent. */
3645 x->parent->color = MEM_BLACK;
3646 y->color = MEM_BLACK;
3647 x->parent->parent->color = MEM_RED;
3648 x = x->parent->parent;
3650 else
3652 /* Parent and uncle have different colors; parent is
3653 red, uncle is black. */
3654 if (x == x->parent->right)
3656 x = x->parent;
3657 mem_rotate_left (x);
3660 x->parent->color = MEM_BLACK;
3661 x->parent->parent->color = MEM_RED;
3662 mem_rotate_right (x->parent->parent);
3665 else
3667 /* This is the symmetrical case of above. */
3668 struct mem_node *y = x->parent->parent->left;
3670 if (y->color == MEM_RED)
3672 x->parent->color = MEM_BLACK;
3673 y->color = MEM_BLACK;
3674 x->parent->parent->color = MEM_RED;
3675 x = x->parent->parent;
3677 else
3679 if (x == x->parent->left)
3681 x = x->parent;
3682 mem_rotate_right (x);
3685 x->parent->color = MEM_BLACK;
3686 x->parent->parent->color = MEM_RED;
3687 mem_rotate_left (x->parent->parent);
3692 /* The root may have been changed to red due to the algorithm. Set
3693 it to black so that property #5 is satisfied. */
3694 mem_root->color = MEM_BLACK;
3698 /* (x) (y)
3699 / \ / \
3700 a (y) ===> (x) c
3701 / \ / \
3702 b c a b */
3704 static void
3705 mem_rotate_left (struct mem_node *x)
3707 struct mem_node *y;
3709 /* Turn y's left sub-tree into x's right sub-tree. */
3710 y = x->right;
3711 x->right = y->left;
3712 if (y->left != MEM_NIL)
3713 y->left->parent = x;
3715 /* Y's parent was x's parent. */
3716 if (y != MEM_NIL)
3717 y->parent = x->parent;
3719 /* Get the parent to point to y instead of x. */
3720 if (x->parent)
3722 if (x == x->parent->left)
3723 x->parent->left = y;
3724 else
3725 x->parent->right = y;
3727 else
3728 mem_root = y;
3730 /* Put x on y's left. */
3731 y->left = x;
3732 if (x != MEM_NIL)
3733 x->parent = y;
3737 /* (x) (Y)
3738 / \ / \
3739 (y) c ===> a (x)
3740 / \ / \
3741 a b b c */
3743 static void
3744 mem_rotate_right (struct mem_node *x)
3746 struct mem_node *y = x->left;
3748 x->left = y->right;
3749 if (y->right != MEM_NIL)
3750 y->right->parent = x;
3752 if (y != MEM_NIL)
3753 y->parent = x->parent;
3754 if (x->parent)
3756 if (x == x->parent->right)
3757 x->parent->right = y;
3758 else
3759 x->parent->left = y;
3761 else
3762 mem_root = y;
3764 y->right = x;
3765 if (x != MEM_NIL)
3766 x->parent = y;
3770 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3772 static void
3773 mem_delete (struct mem_node *z)
3775 struct mem_node *x, *y;
3777 if (!z || z == MEM_NIL)
3778 return;
3780 if (z->left == MEM_NIL || z->right == MEM_NIL)
3781 y = z;
3782 else
3784 y = z->right;
3785 while (y->left != MEM_NIL)
3786 y = y->left;
3789 if (y->left != MEM_NIL)
3790 x = y->left;
3791 else
3792 x = y->right;
3794 x->parent = y->parent;
3795 if (y->parent)
3797 if (y == y->parent->left)
3798 y->parent->left = x;
3799 else
3800 y->parent->right = x;
3802 else
3803 mem_root = x;
3805 if (y != z)
3807 z->start = y->start;
3808 z->end = y->end;
3809 z->type = y->type;
3812 if (y->color == MEM_BLACK)
3813 mem_delete_fixup (x);
3815 #ifdef GC_MALLOC_CHECK
3816 _free_internal (y);
3817 #else
3818 xfree (y);
3819 #endif
3823 /* Re-establish the red-black properties of the tree, after a
3824 deletion. */
3826 static void
3827 mem_delete_fixup (struct mem_node *x)
3829 while (x != mem_root && x->color == MEM_BLACK)
3831 if (x == x->parent->left)
3833 struct mem_node *w = x->parent->right;
3835 if (w->color == MEM_RED)
3837 w->color = MEM_BLACK;
3838 x->parent->color = MEM_RED;
3839 mem_rotate_left (x->parent);
3840 w = x->parent->right;
3843 if (w->left->color == MEM_BLACK && w->right->color == MEM_BLACK)
3845 w->color = MEM_RED;
3846 x = x->parent;
3848 else
3850 if (w->right->color == MEM_BLACK)
3852 w->left->color = MEM_BLACK;
3853 w->color = MEM_RED;
3854 mem_rotate_right (w);
3855 w = x->parent->right;
3857 w->color = x->parent->color;
3858 x->parent->color = MEM_BLACK;
3859 w->right->color = MEM_BLACK;
3860 mem_rotate_left (x->parent);
3861 x = mem_root;
3864 else
3866 struct mem_node *w = x->parent->left;
3868 if (w->color == MEM_RED)
3870 w->color = MEM_BLACK;
3871 x->parent->color = MEM_RED;
3872 mem_rotate_right (x->parent);
3873 w = x->parent->left;
3876 if (w->right->color == MEM_BLACK && w->left->color == MEM_BLACK)
3878 w->color = MEM_RED;
3879 x = x->parent;
3881 else
3883 if (w->left->color == MEM_BLACK)
3885 w->right->color = MEM_BLACK;
3886 w->color = MEM_RED;
3887 mem_rotate_left (w);
3888 w = x->parent->left;
3891 w->color = x->parent->color;
3892 x->parent->color = MEM_BLACK;
3893 w->left->color = MEM_BLACK;
3894 mem_rotate_right (x->parent);
3895 x = mem_root;
3900 x->color = MEM_BLACK;
3904 /* Value is non-zero if P is a pointer to a live Lisp string on
3905 the heap. M is a pointer to the mem_block for P. */
3907 static inline int
3908 live_string_p (struct mem_node *m, void *p)
3910 if (m->type == MEM_TYPE_STRING)
3912 struct string_block *b = (struct string_block *) m->start;
3913 ptrdiff_t offset = (char *) p - (char *) &b->strings[0];
3915 /* P must point to the start of a Lisp_String structure, and it
3916 must not be on the free-list. */
3917 return (offset >= 0
3918 && offset % sizeof b->strings[0] == 0
3919 && offset < (STRING_BLOCK_SIZE * sizeof b->strings[0])
3920 && ((struct Lisp_String *) p)->data != NULL);
3922 else
3923 return 0;
3927 /* Value is non-zero if P is a pointer to a live Lisp cons on
3928 the heap. M is a pointer to the mem_block for P. */
3930 static inline int
3931 live_cons_p (struct mem_node *m, void *p)
3933 if (m->type == MEM_TYPE_CONS)
3935 struct cons_block *b = (struct cons_block *) m->start;
3936 ptrdiff_t offset = (char *) p - (char *) &b->conses[0];
3938 /* P must point to the start of a Lisp_Cons, not be
3939 one of the unused cells in the current cons block,
3940 and not be on the free-list. */
3941 return (offset >= 0
3942 && offset % sizeof b->conses[0] == 0
3943 && offset < (CONS_BLOCK_SIZE * sizeof b->conses[0])
3944 && (b != cons_block
3945 || offset / sizeof b->conses[0] < cons_block_index)
3946 && !EQ (((struct Lisp_Cons *) p)->car, Vdead));
3948 else
3949 return 0;
3953 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3954 the heap. M is a pointer to the mem_block for P. */
3956 static inline int
3957 live_symbol_p (struct mem_node *m, void *p)
3959 if (m->type == MEM_TYPE_SYMBOL)
3961 struct symbol_block *b = (struct symbol_block *) m->start;
3962 ptrdiff_t offset = (char *) p - (char *) &b->symbols[0];
3964 /* P must point to the start of a Lisp_Symbol, not be
3965 one of the unused cells in the current symbol block,
3966 and not be on the free-list. */
3967 return (offset >= 0
3968 && offset % sizeof b->symbols[0] == 0
3969 && offset < (SYMBOL_BLOCK_SIZE * sizeof b->symbols[0])
3970 && (b != symbol_block
3971 || offset / sizeof b->symbols[0] < symbol_block_index)
3972 && !EQ (((struct Lisp_Symbol *) p)->function, Vdead));
3974 else
3975 return 0;
3979 /* Value is non-zero if P is a pointer to a live Lisp float on
3980 the heap. M is a pointer to the mem_block for P. */
3982 static inline int
3983 live_float_p (struct mem_node *m, void *p)
3985 if (m->type == MEM_TYPE_FLOAT)
3987 struct float_block *b = (struct float_block *) m->start;
3988 ptrdiff_t offset = (char *) p - (char *) &b->floats[0];
3990 /* P must point to the start of a Lisp_Float and not be
3991 one of the unused cells in the current float block. */
3992 return (offset >= 0
3993 && offset % sizeof b->floats[0] == 0
3994 && offset < (FLOAT_BLOCK_SIZE * sizeof b->floats[0])
3995 && (b != float_block
3996 || offset / sizeof b->floats[0] < float_block_index));
3998 else
3999 return 0;
4003 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4004 the heap. M is a pointer to the mem_block for P. */
4006 static inline int
4007 live_misc_p (struct mem_node *m, void *p)
4009 if (m->type == MEM_TYPE_MISC)
4011 struct marker_block *b = (struct marker_block *) m->start;
4012 ptrdiff_t offset = (char *) p - (char *) &b->markers[0];
4014 /* P must point to the start of a Lisp_Misc, not be
4015 one of the unused cells in the current misc block,
4016 and not be on the free-list. */
4017 return (offset >= 0
4018 && offset % sizeof b->markers[0] == 0
4019 && offset < (MARKER_BLOCK_SIZE * sizeof b->markers[0])
4020 && (b != marker_block
4021 || offset / sizeof b->markers[0] < marker_block_index)
4022 && ((union Lisp_Misc *) p)->u_any.type != Lisp_Misc_Free);
4024 else
4025 return 0;
4029 /* Value is non-zero if P is a pointer to a live vector-like object.
4030 M is a pointer to the mem_block for P. */
4032 static inline int
4033 live_vector_p (struct mem_node *m, void *p)
4035 return (p == m->start && m->type == MEM_TYPE_VECTORLIKE);
4039 /* Value is non-zero if P is a pointer to a live buffer. M is a
4040 pointer to the mem_block for P. */
4042 static inline int
4043 live_buffer_p (struct mem_node *m, void *p)
4045 /* P must point to the start of the block, and the buffer
4046 must not have been killed. */
4047 return (m->type == MEM_TYPE_BUFFER
4048 && p == m->start
4049 && !NILP (((struct buffer *) p)->BUFFER_INTERNAL_FIELD (name)));
4052 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4054 #if GC_MARK_STACK
4056 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4058 /* Array of objects that are kept alive because the C stack contains
4059 a pattern that looks like a reference to them . */
4061 #define MAX_ZOMBIES 10
4062 static Lisp_Object zombies[MAX_ZOMBIES];
4064 /* Number of zombie objects. */
4066 static EMACS_INT nzombies;
4068 /* Number of garbage collections. */
4070 static EMACS_INT ngcs;
4072 /* Average percentage of zombies per collection. */
4074 static double avg_zombies;
4076 /* Max. number of live and zombie objects. */
4078 static EMACS_INT max_live, max_zombies;
4080 /* Average number of live objects per GC. */
4082 static double avg_live;
4084 DEFUN ("gc-status", Fgc_status, Sgc_status, 0, 0, "",
4085 doc: /* Show information about live and zombie objects. */)
4086 (void)
4088 Lisp_Object args[8], zombie_list = Qnil;
4089 EMACS_INT i;
4090 for (i = 0; i < min (MAX_ZOMBIES, nzombies); i++)
4091 zombie_list = Fcons (zombies[i], zombie_list);
4092 args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4093 args[1] = make_number (ngcs);
4094 args[2] = make_float (avg_live);
4095 args[3] = make_float (avg_zombies);
4096 args[4] = make_float (avg_zombies / avg_live / 100);
4097 args[5] = make_number (max_live);
4098 args[6] = make_number (max_zombies);
4099 args[7] = zombie_list;
4100 return Fmessage (8, args);
4103 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4106 /* Mark OBJ if we can prove it's a Lisp_Object. */
4108 static inline void
4109 mark_maybe_object (Lisp_Object obj)
4111 void *po;
4112 struct mem_node *m;
4114 if (INTEGERP (obj))
4115 return;
4117 po = (void *) XPNTR (obj);
4118 m = mem_find (po);
4120 if (m != MEM_NIL)
4122 int mark_p = 0;
4124 switch (XTYPE (obj))
4126 case Lisp_String:
4127 mark_p = (live_string_p (m, po)
4128 && !STRING_MARKED_P ((struct Lisp_String *) po));
4129 break;
4131 case Lisp_Cons:
4132 mark_p = (live_cons_p (m, po) && !CONS_MARKED_P (XCONS (obj)));
4133 break;
4135 case Lisp_Symbol:
4136 mark_p = (live_symbol_p (m, po) && !XSYMBOL (obj)->gcmarkbit);
4137 break;
4139 case Lisp_Float:
4140 mark_p = (live_float_p (m, po) && !FLOAT_MARKED_P (XFLOAT (obj)));
4141 break;
4143 case Lisp_Vectorlike:
4144 /* Note: can't check BUFFERP before we know it's a
4145 buffer because checking that dereferences the pointer
4146 PO which might point anywhere. */
4147 if (live_vector_p (m, po))
4148 mark_p = !SUBRP (obj) && !VECTOR_MARKED_P (XVECTOR (obj));
4149 else if (live_buffer_p (m, po))
4150 mark_p = BUFFERP (obj) && !VECTOR_MARKED_P (XBUFFER (obj));
4151 break;
4153 case Lisp_Misc:
4154 mark_p = (live_misc_p (m, po) && !XMISCANY (obj)->gcmarkbit);
4155 break;
4157 default:
4158 break;
4161 if (mark_p)
4163 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4164 if (nzombies < MAX_ZOMBIES)
4165 zombies[nzombies] = obj;
4166 ++nzombies;
4167 #endif
4168 mark_object (obj);
4174 /* If P points to Lisp data, mark that as live if it isn't already
4175 marked. */
4177 static inline void
4178 mark_maybe_pointer (void *p)
4180 struct mem_node *m;
4182 /* Quickly rule out some values which can't point to Lisp data. */
4183 if ((intptr_t) p %
4184 #ifdef USE_LSB_TAG
4185 8 /* USE_LSB_TAG needs Lisp data to be aligned on multiples of 8. */
4186 #else
4187 2 /* We assume that Lisp data is aligned on even addresses. */
4188 #endif
4190 return;
4192 m = mem_find (p);
4193 if (m != MEM_NIL)
4195 Lisp_Object obj = Qnil;
4197 switch (m->type)
4199 case MEM_TYPE_NON_LISP:
4200 /* Nothing to do; not a pointer to Lisp memory. */
4201 break;
4203 case MEM_TYPE_BUFFER:
4204 if (live_buffer_p (m, p) && !VECTOR_MARKED_P ((struct buffer *)p))
4205 XSETVECTOR (obj, p);
4206 break;
4208 case MEM_TYPE_CONS:
4209 if (live_cons_p (m, p) && !CONS_MARKED_P ((struct Lisp_Cons *) p))
4210 XSETCONS (obj, p);
4211 break;
4213 case MEM_TYPE_STRING:
4214 if (live_string_p (m, p)
4215 && !STRING_MARKED_P ((struct Lisp_String *) p))
4216 XSETSTRING (obj, p);
4217 break;
4219 case MEM_TYPE_MISC:
4220 if (live_misc_p (m, p) && !((struct Lisp_Free *) p)->gcmarkbit)
4221 XSETMISC (obj, p);
4222 break;
4224 case MEM_TYPE_SYMBOL:
4225 if (live_symbol_p (m, p) && !((struct Lisp_Symbol *) p)->gcmarkbit)
4226 XSETSYMBOL (obj, p);
4227 break;
4229 case MEM_TYPE_FLOAT:
4230 if (live_float_p (m, p) && !FLOAT_MARKED_P (p))
4231 XSETFLOAT (obj, p);
4232 break;
4234 case MEM_TYPE_VECTORLIKE:
4235 if (live_vector_p (m, p))
4237 Lisp_Object tem;
4238 XSETVECTOR (tem, p);
4239 if (!SUBRP (tem) && !VECTOR_MARKED_P (XVECTOR (tem)))
4240 obj = tem;
4242 break;
4244 default:
4245 abort ();
4248 if (!NILP (obj))
4249 mark_object (obj);
4254 /* Alignment of pointer values. Use offsetof, as it sometimes returns
4255 a smaller alignment than GCC's __alignof__ and mark_memory might
4256 miss objects if __alignof__ were used. */
4257 #define GC_POINTER_ALIGNMENT offsetof (struct {char a; void *b;}, b)
4259 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4260 not suffice, which is the typical case. A host where a Lisp_Object is
4261 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4262 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4263 suffice to widen it to to a Lisp_Object and check it that way. */
4264 #if defined USE_LSB_TAG || UINTPTR_MAX >> VALBITS != 0
4265 # if !defined USE_LSB_TAG && UINTPTR_MAX >> VALBITS >> GCTYPEBITS != 0
4266 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4267 nor mark_maybe_object can follow the pointers. This should not occur on
4268 any practical porting target. */
4269 # error "MSB type bits straddle pointer-word boundaries"
4270 # endif
4271 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4272 pointer words that hold pointers ORed with type bits. */
4273 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4274 #else
4275 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4276 words that hold unmodified pointers. */
4277 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4278 #endif
4280 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4281 or END+OFFSET..START. */
4283 static void
4284 mark_memory (void *start, void *end)
4286 void **pp;
4287 int i;
4289 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4290 nzombies = 0;
4291 #endif
4293 /* Make START the pointer to the start of the memory region,
4294 if it isn't already. */
4295 if (end < start)
4297 void *tem = start;
4298 start = end;
4299 end = tem;
4302 /* Mark Lisp data pointed to. This is necessary because, in some
4303 situations, the C compiler optimizes Lisp objects away, so that
4304 only a pointer to them remains. Example:
4306 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4309 Lisp_Object obj = build_string ("test");
4310 struct Lisp_String *s = XSTRING (obj);
4311 Fgarbage_collect ();
4312 fprintf (stderr, "test `%s'\n", s->data);
4313 return Qnil;
4316 Here, `obj' isn't really used, and the compiler optimizes it
4317 away. The only reference to the life string is through the
4318 pointer `s'. */
4320 for (pp = start; (void *) pp < end; pp++)
4321 for (i = 0; i < sizeof *pp; i += GC_POINTER_ALIGNMENT)
4323 void *p = *(void **) ((char *) pp + i);
4324 mark_maybe_pointer (p);
4325 if (POINTERS_MIGHT_HIDE_IN_OBJECTS)
4326 mark_maybe_object (widen_to_Lisp_Object (p));
4330 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4331 the GCC system configuration. In gcc 3.2, the only systems for
4332 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4333 by others?) and ns32k-pc532-min. */
4335 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4337 static int setjmp_tested_p, longjmps_done;
4339 #define SETJMP_WILL_LIKELY_WORK "\
4341 Emacs garbage collector has been changed to use conservative stack\n\
4342 marking. Emacs has determined that the method it uses to do the\n\
4343 marking will likely work on your system, but this isn't sure.\n\
4345 If you are a system-programmer, or can get the help of a local wizard\n\
4346 who is, please take a look at the function mark_stack in alloc.c, and\n\
4347 verify that the methods used are appropriate for your system.\n\
4349 Please mail the result to <emacs-devel@gnu.org>.\n\
4352 #define SETJMP_WILL_NOT_WORK "\
4354 Emacs garbage collector has been changed to use conservative stack\n\
4355 marking. Emacs has determined that the default method it uses to do the\n\
4356 marking will not work on your system. We will need a system-dependent\n\
4357 solution for your system.\n\
4359 Please take a look at the function mark_stack in alloc.c, and\n\
4360 try to find a way to make it work on your system.\n\
4362 Note that you may get false negatives, depending on the compiler.\n\
4363 In particular, you need to use -O with GCC for this test.\n\
4365 Please mail the result to <emacs-devel@gnu.org>.\n\
4369 /* Perform a quick check if it looks like setjmp saves registers in a
4370 jmp_buf. Print a message to stderr saying so. When this test
4371 succeeds, this is _not_ a proof that setjmp is sufficient for
4372 conservative stack marking. Only the sources or a disassembly
4373 can prove that. */
4375 static void
4376 test_setjmp (void)
4378 char buf[10];
4379 register int x;
4380 jmp_buf jbuf;
4381 int result = 0;
4383 /* Arrange for X to be put in a register. */
4384 sprintf (buf, "1");
4385 x = strlen (buf);
4386 x = 2 * x - 1;
4388 setjmp (jbuf);
4389 if (longjmps_done == 1)
4391 /* Came here after the longjmp at the end of the function.
4393 If x == 1, the longjmp has restored the register to its
4394 value before the setjmp, and we can hope that setjmp
4395 saves all such registers in the jmp_buf, although that
4396 isn't sure.
4398 For other values of X, either something really strange is
4399 taking place, or the setjmp just didn't save the register. */
4401 if (x == 1)
4402 fprintf (stderr, SETJMP_WILL_LIKELY_WORK);
4403 else
4405 fprintf (stderr, SETJMP_WILL_NOT_WORK);
4406 exit (1);
4410 ++longjmps_done;
4411 x = 2;
4412 if (longjmps_done == 1)
4413 longjmp (jbuf, 1);
4416 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4419 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4421 /* Abort if anything GCPRO'd doesn't survive the GC. */
4423 static void
4424 check_gcpros (void)
4426 struct gcpro *p;
4427 ptrdiff_t i;
4429 for (p = gcprolist; p; p = p->next)
4430 for (i = 0; i < p->nvars; ++i)
4431 if (!survives_gc_p (p->var[i]))
4432 /* FIXME: It's not necessarily a bug. It might just be that the
4433 GCPRO is unnecessary or should release the object sooner. */
4434 abort ();
4437 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4439 static void
4440 dump_zombies (void)
4442 int i;
4444 fprintf (stderr, "\nZombies kept alive = %"pI"d:\n", nzombies);
4445 for (i = 0; i < min (MAX_ZOMBIES, nzombies); ++i)
4447 fprintf (stderr, " %d = ", i);
4448 debug_print (zombies[i]);
4452 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4455 /* Mark live Lisp objects on the C stack.
4457 There are several system-dependent problems to consider when
4458 porting this to new architectures:
4460 Processor Registers
4462 We have to mark Lisp objects in CPU registers that can hold local
4463 variables or are used to pass parameters.
4465 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4466 something that either saves relevant registers on the stack, or
4467 calls mark_maybe_object passing it each register's contents.
4469 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4470 implementation assumes that calling setjmp saves registers we need
4471 to see in a jmp_buf which itself lies on the stack. This doesn't
4472 have to be true! It must be verified for each system, possibly
4473 by taking a look at the source code of setjmp.
4475 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4476 can use it as a machine independent method to store all registers
4477 to the stack. In this case the macros described in the previous
4478 two paragraphs are not used.
4480 Stack Layout
4482 Architectures differ in the way their processor stack is organized.
4483 For example, the stack might look like this
4485 +----------------+
4486 | Lisp_Object | size = 4
4487 +----------------+
4488 | something else | size = 2
4489 +----------------+
4490 | Lisp_Object | size = 4
4491 +----------------+
4492 | ... |
4494 In such a case, not every Lisp_Object will be aligned equally. To
4495 find all Lisp_Object on the stack it won't be sufficient to walk
4496 the stack in steps of 4 bytes. Instead, two passes will be
4497 necessary, one starting at the start of the stack, and a second
4498 pass starting at the start of the stack + 2. Likewise, if the
4499 minimal alignment of Lisp_Objects on the stack is 1, four passes
4500 would be necessary, each one starting with one byte more offset
4501 from the stack start. */
4503 static void
4504 mark_stack (void)
4506 void *end;
4508 #ifdef HAVE___BUILTIN_UNWIND_INIT
4509 /* Force callee-saved registers and register windows onto the stack.
4510 This is the preferred method if available, obviating the need for
4511 machine dependent methods. */
4512 __builtin_unwind_init ();
4513 end = &end;
4514 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4515 #ifndef GC_SAVE_REGISTERS_ON_STACK
4516 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4517 union aligned_jmpbuf {
4518 Lisp_Object o;
4519 jmp_buf j;
4520 } j;
4521 volatile int stack_grows_down_p = (char *) &j > (char *) stack_base;
4522 #endif
4523 /* This trick flushes the register windows so that all the state of
4524 the process is contained in the stack. */
4525 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4526 needed on ia64 too. See mach_dep.c, where it also says inline
4527 assembler doesn't work with relevant proprietary compilers. */
4528 #ifdef __sparc__
4529 #if defined (__sparc64__) && defined (__FreeBSD__)
4530 /* FreeBSD does not have a ta 3 handler. */
4531 asm ("flushw");
4532 #else
4533 asm ("ta 3");
4534 #endif
4535 #endif
4537 /* Save registers that we need to see on the stack. We need to see
4538 registers used to hold register variables and registers used to
4539 pass parameters. */
4540 #ifdef GC_SAVE_REGISTERS_ON_STACK
4541 GC_SAVE_REGISTERS_ON_STACK (end);
4542 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4544 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4545 setjmp will definitely work, test it
4546 and print a message with the result
4547 of the test. */
4548 if (!setjmp_tested_p)
4550 setjmp_tested_p = 1;
4551 test_setjmp ();
4553 #endif /* GC_SETJMP_WORKS */
4555 setjmp (j.j);
4556 end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
4557 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4558 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4560 /* This assumes that the stack is a contiguous region in memory. If
4561 that's not the case, something has to be done here to iterate
4562 over the stack segments. */
4563 mark_memory (stack_base, end);
4565 /* Allow for marking a secondary stack, like the register stack on the
4566 ia64. */
4567 #ifdef GC_MARK_SECONDARY_STACK
4568 GC_MARK_SECONDARY_STACK ();
4569 #endif
4571 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4572 check_gcpros ();
4573 #endif
4576 #endif /* GC_MARK_STACK != 0 */
4579 /* Determine whether it is safe to access memory at address P. */
4580 static int
4581 valid_pointer_p (void *p)
4583 #ifdef WINDOWSNT
4584 return w32_valid_pointer_p (p, 16);
4585 #else
4586 int fd[2];
4588 /* Obviously, we cannot just access it (we would SEGV trying), so we
4589 trick the o/s to tell us whether p is a valid pointer.
4590 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4591 not validate p in that case. */
4593 if (pipe (fd) == 0)
4595 int valid = (emacs_write (fd[1], (char *) p, 16) == 16);
4596 emacs_close (fd[1]);
4597 emacs_close (fd[0]);
4598 return valid;
4601 return -1;
4602 #endif
4605 /* Return 1 if OBJ is a valid lisp object.
4606 Return 0 if OBJ is NOT a valid lisp object.
4607 Return -1 if we cannot validate OBJ.
4608 This function can be quite slow,
4609 so it should only be used in code for manual debugging. */
4612 valid_lisp_object_p (Lisp_Object obj)
4614 void *p;
4615 #if GC_MARK_STACK
4616 struct mem_node *m;
4617 #endif
4619 if (INTEGERP (obj))
4620 return 1;
4622 p = (void *) XPNTR (obj);
4623 if (PURE_POINTER_P (p))
4624 return 1;
4626 #if !GC_MARK_STACK
4627 return valid_pointer_p (p);
4628 #else
4630 m = mem_find (p);
4632 if (m == MEM_NIL)
4634 int valid = valid_pointer_p (p);
4635 if (valid <= 0)
4636 return valid;
4638 if (SUBRP (obj))
4639 return 1;
4641 return 0;
4644 switch (m->type)
4646 case MEM_TYPE_NON_LISP:
4647 return 0;
4649 case MEM_TYPE_BUFFER:
4650 return live_buffer_p (m, p);
4652 case MEM_TYPE_CONS:
4653 return live_cons_p (m, p);
4655 case MEM_TYPE_STRING:
4656 return live_string_p (m, p);
4658 case MEM_TYPE_MISC:
4659 return live_misc_p (m, p);
4661 case MEM_TYPE_SYMBOL:
4662 return live_symbol_p (m, p);
4664 case MEM_TYPE_FLOAT:
4665 return live_float_p (m, p);
4667 case MEM_TYPE_VECTORLIKE:
4668 return live_vector_p (m, p);
4670 default:
4671 break;
4674 return 0;
4675 #endif
4681 /***********************************************************************
4682 Pure Storage Management
4683 ***********************************************************************/
4685 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4686 pointer to it. TYPE is the Lisp type for which the memory is
4687 allocated. TYPE < 0 means it's not used for a Lisp object. */
4689 static POINTER_TYPE *
4690 pure_alloc (size_t size, int type)
4692 POINTER_TYPE *result;
4693 #ifdef USE_LSB_TAG
4694 size_t alignment = (1 << GCTYPEBITS);
4695 #else
4696 size_t alignment = sizeof (EMACS_INT);
4698 /* Give Lisp_Floats an extra alignment. */
4699 if (type == Lisp_Float)
4701 #if defined __GNUC__ && __GNUC__ >= 2
4702 alignment = __alignof (struct Lisp_Float);
4703 #else
4704 alignment = sizeof (struct Lisp_Float);
4705 #endif
4707 #endif
4709 again:
4710 if (type >= 0)
4712 /* Allocate space for a Lisp object from the beginning of the free
4713 space with taking account of alignment. */
4714 result = ALIGN (purebeg + pure_bytes_used_lisp, alignment);
4715 pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size;
4717 else
4719 /* Allocate space for a non-Lisp object from the end of the free
4720 space. */
4721 pure_bytes_used_non_lisp += size;
4722 result = purebeg + pure_size - pure_bytes_used_non_lisp;
4724 pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp;
4726 if (pure_bytes_used <= pure_size)
4727 return result;
4729 /* Don't allocate a large amount here,
4730 because it might get mmap'd and then its address
4731 might not be usable. */
4732 purebeg = (char *) xmalloc (10000);
4733 pure_size = 10000;
4734 pure_bytes_used_before_overflow += pure_bytes_used - size;
4735 pure_bytes_used = 0;
4736 pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
4737 goto again;
4741 /* Print a warning if PURESIZE is too small. */
4743 void
4744 check_pure_size (void)
4746 if (pure_bytes_used_before_overflow)
4747 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI"d"
4748 " bytes needed)"),
4749 pure_bytes_used + pure_bytes_used_before_overflow);
4753 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4754 the non-Lisp data pool of the pure storage, and return its start
4755 address. Return NULL if not found. */
4757 static char *
4758 find_string_data_in_pure (const char *data, EMACS_INT nbytes)
4760 int i;
4761 EMACS_INT skip, bm_skip[256], last_char_skip, infinity, start, start_max;
4762 const unsigned char *p;
4763 char *non_lisp_beg;
4765 if (pure_bytes_used_non_lisp < nbytes + 1)
4766 return NULL;
4768 /* Set up the Boyer-Moore table. */
4769 skip = nbytes + 1;
4770 for (i = 0; i < 256; i++)
4771 bm_skip[i] = skip;
4773 p = (const unsigned char *) data;
4774 while (--skip > 0)
4775 bm_skip[*p++] = skip;
4777 last_char_skip = bm_skip['\0'];
4779 non_lisp_beg = purebeg + pure_size - pure_bytes_used_non_lisp;
4780 start_max = pure_bytes_used_non_lisp - (nbytes + 1);
4782 /* See the comments in the function `boyer_moore' (search.c) for the
4783 use of `infinity'. */
4784 infinity = pure_bytes_used_non_lisp + 1;
4785 bm_skip['\0'] = infinity;
4787 p = (const unsigned char *) non_lisp_beg + nbytes;
4788 start = 0;
4791 /* Check the last character (== '\0'). */
4794 start += bm_skip[*(p + start)];
4796 while (start <= start_max);
4798 if (start < infinity)
4799 /* Couldn't find the last character. */
4800 return NULL;
4802 /* No less than `infinity' means we could find the last
4803 character at `p[start - infinity]'. */
4804 start -= infinity;
4806 /* Check the remaining characters. */
4807 if (memcmp (data, non_lisp_beg + start, nbytes) == 0)
4808 /* Found. */
4809 return non_lisp_beg + start;
4811 start += last_char_skip;
4813 while (start <= start_max);
4815 return NULL;
4819 /* Return a string allocated in pure space. DATA is a buffer holding
4820 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4821 non-zero means make the result string multibyte.
4823 Must get an error if pure storage is full, since if it cannot hold
4824 a large string it may be able to hold conses that point to that
4825 string; then the string is not protected from gc. */
4827 Lisp_Object
4828 make_pure_string (const char *data,
4829 EMACS_INT nchars, EMACS_INT nbytes, int multibyte)
4831 Lisp_Object string;
4832 struct Lisp_String *s;
4834 s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
4835 s->data = (unsigned char *) find_string_data_in_pure (data, nbytes);
4836 if (s->data == NULL)
4838 s->data = (unsigned char *) pure_alloc (nbytes + 1, -1);
4839 memcpy (s->data, data, nbytes);
4840 s->data[nbytes] = '\0';
4842 s->size = nchars;
4843 s->size_byte = multibyte ? nbytes : -1;
4844 s->intervals = NULL_INTERVAL;
4845 XSETSTRING (string, s);
4846 return string;
4849 /* Return a string a string allocated in pure space. Do not allocate
4850 the string data, just point to DATA. */
4852 Lisp_Object
4853 make_pure_c_string (const char *data)
4855 Lisp_Object string;
4856 struct Lisp_String *s;
4857 EMACS_INT nchars = strlen (data);
4859 s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
4860 s->size = nchars;
4861 s->size_byte = -1;
4862 s->data = (unsigned char *) data;
4863 s->intervals = NULL_INTERVAL;
4864 XSETSTRING (string, s);
4865 return string;
4868 /* Return a cons allocated from pure space. Give it pure copies
4869 of CAR as car and CDR as cdr. */
4871 Lisp_Object
4872 pure_cons (Lisp_Object car, Lisp_Object cdr)
4874 register Lisp_Object new;
4875 struct Lisp_Cons *p;
4877 p = (struct Lisp_Cons *) pure_alloc (sizeof *p, Lisp_Cons);
4878 XSETCONS (new, p);
4879 XSETCAR (new, Fpurecopy (car));
4880 XSETCDR (new, Fpurecopy (cdr));
4881 return new;
4885 /* Value is a float object with value NUM allocated from pure space. */
4887 static Lisp_Object
4888 make_pure_float (double num)
4890 register Lisp_Object new;
4891 struct Lisp_Float *p;
4893 p = (struct Lisp_Float *) pure_alloc (sizeof *p, Lisp_Float);
4894 XSETFLOAT (new, p);
4895 XFLOAT_INIT (new, num);
4896 return new;
4900 /* Return a vector with room for LEN Lisp_Objects allocated from
4901 pure space. */
4903 Lisp_Object
4904 make_pure_vector (EMACS_INT len)
4906 Lisp_Object new;
4907 struct Lisp_Vector *p;
4908 size_t size = (offsetof (struct Lisp_Vector, contents)
4909 + len * sizeof (Lisp_Object));
4911 p = (struct Lisp_Vector *) pure_alloc (size, Lisp_Vectorlike);
4912 XSETVECTOR (new, p);
4913 XVECTOR (new)->header.size = len;
4914 return new;
4918 DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
4919 doc: /* Make a copy of object OBJ in pure storage.
4920 Recursively copies contents of vectors and cons cells.
4921 Does not copy symbols. Copies strings without text properties. */)
4922 (register Lisp_Object obj)
4924 if (NILP (Vpurify_flag))
4925 return obj;
4927 if (PURE_POINTER_P (XPNTR (obj)))
4928 return obj;
4930 if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */
4932 Lisp_Object tmp = Fgethash (obj, Vpurify_flag, Qnil);
4933 if (!NILP (tmp))
4934 return tmp;
4937 if (CONSP (obj))
4938 obj = pure_cons (XCAR (obj), XCDR (obj));
4939 else if (FLOATP (obj))
4940 obj = make_pure_float (XFLOAT_DATA (obj));
4941 else if (STRINGP (obj))
4942 obj = make_pure_string (SSDATA (obj), SCHARS (obj),
4943 SBYTES (obj),
4944 STRING_MULTIBYTE (obj));
4945 else if (COMPILEDP (obj) || VECTORP (obj))
4947 register struct Lisp_Vector *vec;
4948 register EMACS_INT i;
4949 EMACS_INT size;
4951 size = ASIZE (obj);
4952 if (size & PSEUDOVECTOR_FLAG)
4953 size &= PSEUDOVECTOR_SIZE_MASK;
4954 vec = XVECTOR (make_pure_vector (size));
4955 for (i = 0; i < size; i++)
4956 vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]);
4957 if (COMPILEDP (obj))
4959 XSETPVECTYPE (vec, PVEC_COMPILED);
4960 XSETCOMPILED (obj, vec);
4962 else
4963 XSETVECTOR (obj, vec);
4965 else if (MARKERP (obj))
4966 error ("Attempt to copy a marker to pure storage");
4967 else
4968 /* Not purified, don't hash-cons. */
4969 return obj;
4971 if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */
4972 Fputhash (obj, obj, Vpurify_flag);
4974 return obj;
4979 /***********************************************************************
4980 Protection from GC
4981 ***********************************************************************/
4983 /* Put an entry in staticvec, pointing at the variable with address
4984 VARADDRESS. */
4986 void
4987 staticpro (Lisp_Object *varaddress)
4989 staticvec[staticidx++] = varaddress;
4990 if (staticidx >= NSTATICS)
4991 abort ();
4995 /***********************************************************************
4996 Protection from GC
4997 ***********************************************************************/
4999 /* Temporarily prevent garbage collection. */
5002 inhibit_garbage_collection (void)
5004 int count = SPECPDL_INDEX ();
5006 specbind (Qgc_cons_threshold, make_number (MOST_POSITIVE_FIXNUM));
5007 return count;
5011 DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
5012 doc: /* Reclaim storage for Lisp objects no longer needed.
5013 Garbage collection happens automatically if you cons more than
5014 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5015 `garbage-collect' normally returns a list with info on amount of space in use:
5016 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
5017 (USED-MISCS . FREE-MISCS) USED-STRING-CHARS USED-VECTOR-SLOTS
5018 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
5019 (USED-STRINGS . FREE-STRINGS))
5020 However, if there was overflow in pure space, `garbage-collect'
5021 returns nil, because real GC can't be done.
5022 See Info node `(elisp)Garbage Collection'. */)
5023 (void)
5025 register struct specbinding *bind;
5026 char stack_top_variable;
5027 ptrdiff_t i;
5028 int message_p;
5029 Lisp_Object total[8];
5030 int count = SPECPDL_INDEX ();
5031 EMACS_TIME t1, t2, t3;
5033 if (abort_on_gc)
5034 abort ();
5036 /* Can't GC if pure storage overflowed because we can't determine
5037 if something is a pure object or not. */
5038 if (pure_bytes_used_before_overflow)
5039 return Qnil;
5041 CHECK_CONS_LIST ();
5043 /* Don't keep undo information around forever.
5044 Do this early on, so it is no problem if the user quits. */
5046 register struct buffer *nextb = all_buffers;
5048 while (nextb)
5050 /* If a buffer's undo list is Qt, that means that undo is
5051 turned off in that buffer. Calling truncate_undo_list on
5052 Qt tends to return NULL, which effectively turns undo back on.
5053 So don't call truncate_undo_list if undo_list is Qt. */
5054 if (! NILP (nextb->BUFFER_INTERNAL_FIELD (name)) && ! EQ (nextb->BUFFER_INTERNAL_FIELD (undo_list), Qt))
5055 truncate_undo_list (nextb);
5057 /* Shrink buffer gaps, but skip indirect and dead buffers. */
5058 if (nextb->base_buffer == 0 && !NILP (nextb->BUFFER_INTERNAL_FIELD (name))
5059 && ! nextb->text->inhibit_shrinking)
5061 /* If a buffer's gap size is more than 10% of the buffer
5062 size, or larger than 2000 bytes, then shrink it
5063 accordingly. Keep a minimum size of 20 bytes. */
5064 int size = min (2000, max (20, (nextb->text->z_byte / 10)));
5066 if (nextb->text->gap_size > size)
5068 struct buffer *save_current = current_buffer;
5069 current_buffer = nextb;
5070 make_gap (-(nextb->text->gap_size - size));
5071 current_buffer = save_current;
5075 nextb = nextb->header.next.buffer;
5079 EMACS_GET_TIME (t1);
5081 /* In case user calls debug_print during GC,
5082 don't let that cause a recursive GC. */
5083 consing_since_gc = 0;
5085 /* Save what's currently displayed in the echo area. */
5086 message_p = push_message ();
5087 record_unwind_protect (pop_message_unwind, Qnil);
5089 /* Save a copy of the contents of the stack, for debugging. */
5090 #if MAX_SAVE_STACK > 0
5091 if (NILP (Vpurify_flag))
5093 char *stack;
5094 ptrdiff_t stack_size;
5095 if (&stack_top_variable < stack_bottom)
5097 stack = &stack_top_variable;
5098 stack_size = stack_bottom - &stack_top_variable;
5100 else
5102 stack = stack_bottom;
5103 stack_size = &stack_top_variable - stack_bottom;
5105 if (stack_size <= MAX_SAVE_STACK)
5107 if (stack_copy_size < stack_size)
5109 stack_copy = (char *) xrealloc (stack_copy, stack_size);
5110 stack_copy_size = stack_size;
5112 memcpy (stack_copy, stack, stack_size);
5115 #endif /* MAX_SAVE_STACK > 0 */
5117 if (garbage_collection_messages)
5118 message1_nolog ("Garbage collecting...");
5120 BLOCK_INPUT;
5122 shrink_regexp_cache ();
5124 gc_in_progress = 1;
5126 /* clear_marks (); */
5128 /* Mark all the special slots that serve as the roots of accessibility. */
5130 for (i = 0; i < staticidx; i++)
5131 mark_object (*staticvec[i]);
5133 for (bind = specpdl; bind != specpdl_ptr; bind++)
5135 mark_object (bind->symbol);
5136 mark_object (bind->old_value);
5138 mark_terminals ();
5139 mark_kboards ();
5140 mark_ttys ();
5142 #ifdef USE_GTK
5144 extern void xg_mark_data (void);
5145 xg_mark_data ();
5147 #endif
5149 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5150 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5151 mark_stack ();
5152 #else
5154 register struct gcpro *tail;
5155 for (tail = gcprolist; tail; tail = tail->next)
5156 for (i = 0; i < tail->nvars; i++)
5157 mark_object (tail->var[i]);
5159 mark_byte_stack ();
5161 struct catchtag *catch;
5162 struct handler *handler;
5164 for (catch = catchlist; catch; catch = catch->next)
5166 mark_object (catch->tag);
5167 mark_object (catch->val);
5169 for (handler = handlerlist; handler; handler = handler->next)
5171 mark_object (handler->handler);
5172 mark_object (handler->var);
5175 mark_backtrace ();
5176 #endif
5178 #ifdef HAVE_WINDOW_SYSTEM
5179 mark_fringe_data ();
5180 #endif
5182 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5183 mark_stack ();
5184 #endif
5186 /* Everything is now marked, except for the things that require special
5187 finalization, i.e. the undo_list.
5188 Look thru every buffer's undo list
5189 for elements that update markers that were not marked,
5190 and delete them. */
5192 register struct buffer *nextb = all_buffers;
5194 while (nextb)
5196 /* If a buffer's undo list is Qt, that means that undo is
5197 turned off in that buffer. Calling truncate_undo_list on
5198 Qt tends to return NULL, which effectively turns undo back on.
5199 So don't call truncate_undo_list if undo_list is Qt. */
5200 if (! EQ (nextb->BUFFER_INTERNAL_FIELD (undo_list), Qt))
5202 Lisp_Object tail, prev;
5203 tail = nextb->BUFFER_INTERNAL_FIELD (undo_list);
5204 prev = Qnil;
5205 while (CONSP (tail))
5207 if (CONSP (XCAR (tail))
5208 && MARKERP (XCAR (XCAR (tail)))
5209 && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
5211 if (NILP (prev))
5212 nextb->BUFFER_INTERNAL_FIELD (undo_list) = tail = XCDR (tail);
5213 else
5215 tail = XCDR (tail);
5216 XSETCDR (prev, tail);
5219 else
5221 prev = tail;
5222 tail = XCDR (tail);
5226 /* Now that we have stripped the elements that need not be in the
5227 undo_list any more, we can finally mark the list. */
5228 mark_object (nextb->BUFFER_INTERNAL_FIELD (undo_list));
5230 nextb = nextb->header.next.buffer;
5234 gc_sweep ();
5236 /* Clear the mark bits that we set in certain root slots. */
5238 unmark_byte_stack ();
5239 VECTOR_UNMARK (&buffer_defaults);
5240 VECTOR_UNMARK (&buffer_local_symbols);
5242 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5243 dump_zombies ();
5244 #endif
5246 UNBLOCK_INPUT;
5248 CHECK_CONS_LIST ();
5250 /* clear_marks (); */
5251 gc_in_progress = 0;
5253 consing_since_gc = 0;
5254 if (gc_cons_threshold < 10000)
5255 gc_cons_threshold = 10000;
5257 gc_relative_threshold = 0;
5258 if (FLOATP (Vgc_cons_percentage))
5259 { /* Set gc_cons_combined_threshold. */
5260 double tot = 0;
5262 tot += total_conses * sizeof (struct Lisp_Cons);
5263 tot += total_symbols * sizeof (struct Lisp_Symbol);
5264 tot += total_markers * sizeof (union Lisp_Misc);
5265 tot += total_string_size;
5266 tot += total_vector_size * sizeof (Lisp_Object);
5267 tot += total_floats * sizeof (struct Lisp_Float);
5268 tot += total_intervals * sizeof (struct interval);
5269 tot += total_strings * sizeof (struct Lisp_String);
5271 tot *= XFLOAT_DATA (Vgc_cons_percentage);
5272 if (0 < tot)
5274 if (tot < TYPE_MAXIMUM (EMACS_INT))
5275 gc_relative_threshold = tot;
5276 else
5277 gc_relative_threshold = TYPE_MAXIMUM (EMACS_INT);
5281 if (garbage_collection_messages)
5283 if (message_p || minibuf_level > 0)
5284 restore_message ();
5285 else
5286 message1_nolog ("Garbage collecting...done");
5289 unbind_to (count, Qnil);
5291 total[0] = Fcons (make_number (total_conses),
5292 make_number (total_free_conses));
5293 total[1] = Fcons (make_number (total_symbols),
5294 make_number (total_free_symbols));
5295 total[2] = Fcons (make_number (total_markers),
5296 make_number (total_free_markers));
5297 total[3] = make_number (total_string_size);
5298 total[4] = make_number (total_vector_size);
5299 total[5] = Fcons (make_number (total_floats),
5300 make_number (total_free_floats));
5301 total[6] = Fcons (make_number (total_intervals),
5302 make_number (total_free_intervals));
5303 total[7] = Fcons (make_number (total_strings),
5304 make_number (total_free_strings));
5306 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5308 /* Compute average percentage of zombies. */
5309 double nlive = 0;
5311 for (i = 0; i < 7; ++i)
5312 if (CONSP (total[i]))
5313 nlive += XFASTINT (XCAR (total[i]));
5315 avg_live = (avg_live * ngcs + nlive) / (ngcs + 1);
5316 max_live = max (nlive, max_live);
5317 avg_zombies = (avg_zombies * ngcs + nzombies) / (ngcs + 1);
5318 max_zombies = max (nzombies, max_zombies);
5319 ++ngcs;
5321 #endif
5323 if (!NILP (Vpost_gc_hook))
5325 int gc_count = inhibit_garbage_collection ();
5326 safe_run_hooks (Qpost_gc_hook);
5327 unbind_to (gc_count, Qnil);
5330 /* Accumulate statistics. */
5331 EMACS_GET_TIME (t2);
5332 EMACS_SUB_TIME (t3, t2, t1);
5333 if (FLOATP (Vgc_elapsed))
5334 Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed) +
5335 EMACS_SECS (t3) +
5336 EMACS_USECS (t3) * 1.0e-6);
5337 gcs_done++;
5339 return Flist (sizeof total / sizeof *total, total);
5343 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5344 only interesting objects referenced from glyphs are strings. */
5346 static void
5347 mark_glyph_matrix (struct glyph_matrix *matrix)
5349 struct glyph_row *row = matrix->rows;
5350 struct glyph_row *end = row + matrix->nrows;
5352 for (; row < end; ++row)
5353 if (row->enabled_p)
5355 int area;
5356 for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
5358 struct glyph *glyph = row->glyphs[area];
5359 struct glyph *end_glyph = glyph + row->used[area];
5361 for (; glyph < end_glyph; ++glyph)
5362 if (STRINGP (glyph->object)
5363 && !STRING_MARKED_P (XSTRING (glyph->object)))
5364 mark_object (glyph->object);
5370 /* Mark Lisp faces in the face cache C. */
5372 static void
5373 mark_face_cache (struct face_cache *c)
5375 if (c)
5377 int i, j;
5378 for (i = 0; i < c->used; ++i)
5380 struct face *face = FACE_FROM_ID (c->f, i);
5382 if (face)
5384 for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
5385 mark_object (face->lface[j]);
5393 /* Mark reference to a Lisp_Object.
5394 If the object referred to has not been seen yet, recursively mark
5395 all the references contained in it. */
5397 #define LAST_MARKED_SIZE 500
5398 static Lisp_Object last_marked[LAST_MARKED_SIZE];
5399 static int last_marked_index;
5401 /* For debugging--call abort when we cdr down this many
5402 links of a list, in mark_object. In debugging,
5403 the call to abort will hit a breakpoint.
5404 Normally this is zero and the check never goes off. */
5405 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE;
5407 static void
5408 mark_vectorlike (struct Lisp_Vector *ptr)
5410 EMACS_INT size = ptr->header.size;
5411 EMACS_INT i;
5413 eassert (!VECTOR_MARKED_P (ptr));
5414 VECTOR_MARK (ptr); /* Else mark it */
5415 if (size & PSEUDOVECTOR_FLAG)
5416 size &= PSEUDOVECTOR_SIZE_MASK;
5418 /* Note that this size is not the memory-footprint size, but only
5419 the number of Lisp_Object fields that we should trace.
5420 The distinction is used e.g. by Lisp_Process which places extra
5421 non-Lisp_Object fields at the end of the structure. */
5422 for (i = 0; i < size; i++) /* and then mark its elements */
5423 mark_object (ptr->contents[i]);
5426 /* Like mark_vectorlike but optimized for char-tables (and
5427 sub-char-tables) assuming that the contents are mostly integers or
5428 symbols. */
5430 static void
5431 mark_char_table (struct Lisp_Vector *ptr)
5433 int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
5434 int i;
5436 eassert (!VECTOR_MARKED_P (ptr));
5437 VECTOR_MARK (ptr);
5438 for (i = 0; i < size; i++)
5440 Lisp_Object val = ptr->contents[i];
5442 if (INTEGERP (val) || (SYMBOLP (val) && XSYMBOL (val)->gcmarkbit))
5443 continue;
5444 if (SUB_CHAR_TABLE_P (val))
5446 if (! VECTOR_MARKED_P (XVECTOR (val)))
5447 mark_char_table (XVECTOR (val));
5449 else
5450 mark_object (val);
5454 void
5455 mark_object (Lisp_Object arg)
5457 register Lisp_Object obj = arg;
5458 #ifdef GC_CHECK_MARKED_OBJECTS
5459 void *po;
5460 struct mem_node *m;
5461 #endif
5462 ptrdiff_t cdr_count = 0;
5464 loop:
5466 if (PURE_POINTER_P (XPNTR (obj)))
5467 return;
5469 last_marked[last_marked_index++] = obj;
5470 if (last_marked_index == LAST_MARKED_SIZE)
5471 last_marked_index = 0;
5473 /* Perform some sanity checks on the objects marked here. Abort if
5474 we encounter an object we know is bogus. This increases GC time
5475 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5476 #ifdef GC_CHECK_MARKED_OBJECTS
5478 po = (void *) XPNTR (obj);
5480 /* Check that the object pointed to by PO is known to be a Lisp
5481 structure allocated from the heap. */
5482 #define CHECK_ALLOCATED() \
5483 do { \
5484 m = mem_find (po); \
5485 if (m == MEM_NIL) \
5486 abort (); \
5487 } while (0)
5489 /* Check that the object pointed to by PO is live, using predicate
5490 function LIVEP. */
5491 #define CHECK_LIVE(LIVEP) \
5492 do { \
5493 if (!LIVEP (m, po)) \
5494 abort (); \
5495 } while (0)
5497 /* Check both of the above conditions. */
5498 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5499 do { \
5500 CHECK_ALLOCATED (); \
5501 CHECK_LIVE (LIVEP); \
5502 } while (0) \
5504 #else /* not GC_CHECK_MARKED_OBJECTS */
5506 #define CHECK_LIVE(LIVEP) (void) 0
5507 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5509 #endif /* not GC_CHECK_MARKED_OBJECTS */
5511 switch (SWITCH_ENUM_CAST (XTYPE (obj)))
5513 case Lisp_String:
5515 register struct Lisp_String *ptr = XSTRING (obj);
5516 if (STRING_MARKED_P (ptr))
5517 break;
5518 CHECK_ALLOCATED_AND_LIVE (live_string_p);
5519 MARK_INTERVAL_TREE (ptr->intervals);
5520 MARK_STRING (ptr);
5521 #ifdef GC_CHECK_STRING_BYTES
5522 /* Check that the string size recorded in the string is the
5523 same as the one recorded in the sdata structure. */
5524 CHECK_STRING_BYTES (ptr);
5525 #endif /* GC_CHECK_STRING_BYTES */
5527 break;
5529 case Lisp_Vectorlike:
5530 if (VECTOR_MARKED_P (XVECTOR (obj)))
5531 break;
5532 #ifdef GC_CHECK_MARKED_OBJECTS
5533 m = mem_find (po);
5534 if (m == MEM_NIL && !SUBRP (obj)
5535 && po != &buffer_defaults
5536 && po != &buffer_local_symbols)
5537 abort ();
5538 #endif /* GC_CHECK_MARKED_OBJECTS */
5540 if (BUFFERP (obj))
5542 #ifdef GC_CHECK_MARKED_OBJECTS
5543 if (po != &buffer_defaults && po != &buffer_local_symbols)
5545 struct buffer *b;
5546 for (b = all_buffers; b && b != po; b = b->header.next.buffer)
5548 if (b == NULL)
5549 abort ();
5551 #endif /* GC_CHECK_MARKED_OBJECTS */
5552 mark_buffer (obj);
5554 else if (SUBRP (obj))
5555 break;
5556 else if (COMPILEDP (obj))
5557 /* We could treat this just like a vector, but it is better to
5558 save the COMPILED_CONSTANTS element for last and avoid
5559 recursion there. */
5561 register struct Lisp_Vector *ptr = XVECTOR (obj);
5562 int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
5563 int i;
5565 CHECK_LIVE (live_vector_p);
5566 VECTOR_MARK (ptr); /* Else mark it */
5567 for (i = 0; i < size; i++) /* and then mark its elements */
5569 if (i != COMPILED_CONSTANTS)
5570 mark_object (ptr->contents[i]);
5572 obj = ptr->contents[COMPILED_CONSTANTS];
5573 goto loop;
5575 else if (FRAMEP (obj))
5577 register struct frame *ptr = XFRAME (obj);
5578 mark_vectorlike (XVECTOR (obj));
5579 mark_face_cache (ptr->face_cache);
5581 else if (WINDOWP (obj))
5583 register struct Lisp_Vector *ptr = XVECTOR (obj);
5584 struct window *w = XWINDOW (obj);
5585 mark_vectorlike (ptr);
5586 /* Mark glyphs for leaf windows. Marking window matrices is
5587 sufficient because frame matrices use the same glyph
5588 memory. */
5589 if (NILP (w->hchild)
5590 && NILP (w->vchild)
5591 && w->current_matrix)
5593 mark_glyph_matrix (w->current_matrix);
5594 mark_glyph_matrix (w->desired_matrix);
5597 else if (HASH_TABLE_P (obj))
5599 struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
5600 mark_vectorlike ((struct Lisp_Vector *)h);
5601 /* If hash table is not weak, mark all keys and values.
5602 For weak tables, mark only the vector. */
5603 if (NILP (h->weak))
5604 mark_object (h->key_and_value);
5605 else
5606 VECTOR_MARK (XVECTOR (h->key_and_value));
5608 else if (CHAR_TABLE_P (obj))
5609 mark_char_table (XVECTOR (obj));
5610 else
5611 mark_vectorlike (XVECTOR (obj));
5612 break;
5614 case Lisp_Symbol:
5616 register struct Lisp_Symbol *ptr = XSYMBOL (obj);
5617 struct Lisp_Symbol *ptrx;
5619 if (ptr->gcmarkbit)
5620 break;
5621 CHECK_ALLOCATED_AND_LIVE (live_symbol_p);
5622 ptr->gcmarkbit = 1;
5623 mark_object (ptr->function);
5624 mark_object (ptr->plist);
5625 switch (ptr->redirect)
5627 case SYMBOL_PLAINVAL: mark_object (SYMBOL_VAL (ptr)); break;
5628 case SYMBOL_VARALIAS:
5630 Lisp_Object tem;
5631 XSETSYMBOL (tem, SYMBOL_ALIAS (ptr));
5632 mark_object (tem);
5633 break;
5635 case SYMBOL_LOCALIZED:
5637 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
5638 /* If the value is forwarded to a buffer or keyboard field,
5639 these are marked when we see the corresponding object.
5640 And if it's forwarded to a C variable, either it's not
5641 a Lisp_Object var, or it's staticpro'd already. */
5642 mark_object (blv->where);
5643 mark_object (blv->valcell);
5644 mark_object (blv->defcell);
5645 break;
5647 case SYMBOL_FORWARDED:
5648 /* If the value is forwarded to a buffer or keyboard field,
5649 these are marked when we see the corresponding object.
5650 And if it's forwarded to a C variable, either it's not
5651 a Lisp_Object var, or it's staticpro'd already. */
5652 break;
5653 default: abort ();
5655 if (!PURE_POINTER_P (XSTRING (ptr->xname)))
5656 MARK_STRING (XSTRING (ptr->xname));
5657 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname));
5659 ptr = ptr->next;
5660 if (ptr)
5662 ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun */
5663 XSETSYMBOL (obj, ptrx);
5664 goto loop;
5667 break;
5669 case Lisp_Misc:
5670 CHECK_ALLOCATED_AND_LIVE (live_misc_p);
5671 if (XMISCANY (obj)->gcmarkbit)
5672 break;
5673 XMISCANY (obj)->gcmarkbit = 1;
5675 switch (XMISCTYPE (obj))
5678 case Lisp_Misc_Marker:
5679 /* DO NOT mark thru the marker's chain.
5680 The buffer's markers chain does not preserve markers from gc;
5681 instead, markers are removed from the chain when freed by gc. */
5682 break;
5684 case Lisp_Misc_Save_Value:
5685 #if GC_MARK_STACK
5687 register struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj);
5688 /* If DOGC is set, POINTER is the address of a memory
5689 area containing INTEGER potential Lisp_Objects. */
5690 if (ptr->dogc)
5692 Lisp_Object *p = (Lisp_Object *) ptr->pointer;
5693 ptrdiff_t nelt;
5694 for (nelt = ptr->integer; nelt > 0; nelt--, p++)
5695 mark_maybe_object (*p);
5698 #endif
5699 break;
5701 case Lisp_Misc_Overlay:
5703 struct Lisp_Overlay *ptr = XOVERLAY (obj);
5704 mark_object (ptr->start);
5705 mark_object (ptr->end);
5706 mark_object (ptr->plist);
5707 if (ptr->next)
5709 XSETMISC (obj, ptr->next);
5710 goto loop;
5713 break;
5715 default:
5716 abort ();
5718 break;
5720 case Lisp_Cons:
5722 register struct Lisp_Cons *ptr = XCONS (obj);
5723 if (CONS_MARKED_P (ptr))
5724 break;
5725 CHECK_ALLOCATED_AND_LIVE (live_cons_p);
5726 CONS_MARK (ptr);
5727 /* If the cdr is nil, avoid recursion for the car. */
5728 if (EQ (ptr->u.cdr, Qnil))
5730 obj = ptr->car;
5731 cdr_count = 0;
5732 goto loop;
5734 mark_object (ptr->car);
5735 obj = ptr->u.cdr;
5736 cdr_count++;
5737 if (cdr_count == mark_object_loop_halt)
5738 abort ();
5739 goto loop;
5742 case Lisp_Float:
5743 CHECK_ALLOCATED_AND_LIVE (live_float_p);
5744 FLOAT_MARK (XFLOAT (obj));
5745 break;
5747 case_Lisp_Int:
5748 break;
5750 default:
5751 abort ();
5754 #undef CHECK_LIVE
5755 #undef CHECK_ALLOCATED
5756 #undef CHECK_ALLOCATED_AND_LIVE
5759 /* Mark the pointers in a buffer structure. */
5761 static void
5762 mark_buffer (Lisp_Object buf)
5764 register struct buffer *buffer = XBUFFER (buf);
5765 register Lisp_Object *ptr, tmp;
5766 Lisp_Object base_buffer;
5768 eassert (!VECTOR_MARKED_P (buffer));
5769 VECTOR_MARK (buffer);
5771 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
5773 /* For now, we just don't mark the undo_list. It's done later in
5774 a special way just before the sweep phase, and after stripping
5775 some of its elements that are not needed any more. */
5777 if (buffer->overlays_before)
5779 XSETMISC (tmp, buffer->overlays_before);
5780 mark_object (tmp);
5782 if (buffer->overlays_after)
5784 XSETMISC (tmp, buffer->overlays_after);
5785 mark_object (tmp);
5788 /* buffer-local Lisp variables start at `undo_list',
5789 tho only the ones from `name' on are GC'd normally. */
5790 for (ptr = &buffer->BUFFER_INTERNAL_FIELD (name);
5791 ptr <= &PER_BUFFER_VALUE (buffer,
5792 PER_BUFFER_VAR_OFFSET (LAST_FIELD_PER_BUFFER));
5793 ptr++)
5794 mark_object (*ptr);
5796 /* If this is an indirect buffer, mark its base buffer. */
5797 if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
5799 XSETBUFFER (base_buffer, buffer->base_buffer);
5800 mark_buffer (base_buffer);
5804 /* Mark the Lisp pointers in the terminal objects.
5805 Called by the Fgarbage_collector. */
5807 static void
5808 mark_terminals (void)
5810 struct terminal *t;
5811 for (t = terminal_list; t; t = t->next_terminal)
5813 eassert (t->name != NULL);
5814 #ifdef HAVE_WINDOW_SYSTEM
5815 /* If a terminal object is reachable from a stacpro'ed object,
5816 it might have been marked already. Make sure the image cache
5817 gets marked. */
5818 mark_image_cache (t->image_cache);
5819 #endif /* HAVE_WINDOW_SYSTEM */
5820 if (!VECTOR_MARKED_P (t))
5821 mark_vectorlike ((struct Lisp_Vector *)t);
5827 /* Value is non-zero if OBJ will survive the current GC because it's
5828 either marked or does not need to be marked to survive. */
5831 survives_gc_p (Lisp_Object obj)
5833 int survives_p;
5835 switch (XTYPE (obj))
5837 case_Lisp_Int:
5838 survives_p = 1;
5839 break;
5841 case Lisp_Symbol:
5842 survives_p = XSYMBOL (obj)->gcmarkbit;
5843 break;
5845 case Lisp_Misc:
5846 survives_p = XMISCANY (obj)->gcmarkbit;
5847 break;
5849 case Lisp_String:
5850 survives_p = STRING_MARKED_P (XSTRING (obj));
5851 break;
5853 case Lisp_Vectorlike:
5854 survives_p = SUBRP (obj) || VECTOR_MARKED_P (XVECTOR (obj));
5855 break;
5857 case Lisp_Cons:
5858 survives_p = CONS_MARKED_P (XCONS (obj));
5859 break;
5861 case Lisp_Float:
5862 survives_p = FLOAT_MARKED_P (XFLOAT (obj));
5863 break;
5865 default:
5866 abort ();
5869 return survives_p || PURE_POINTER_P ((void *) XPNTR (obj));
5874 /* Sweep: find all structures not marked, and free them. */
5876 static void
5877 gc_sweep (void)
5879 /* Remove or mark entries in weak hash tables.
5880 This must be done before any object is unmarked. */
5881 sweep_weak_hash_tables ();
5883 sweep_strings ();
5884 #ifdef GC_CHECK_STRING_BYTES
5885 if (!noninteractive)
5886 check_string_bytes (1);
5887 #endif
5889 /* Put all unmarked conses on free list */
5891 register struct cons_block *cblk;
5892 struct cons_block **cprev = &cons_block;
5893 register int lim = cons_block_index;
5894 EMACS_INT num_free = 0, num_used = 0;
5896 cons_free_list = 0;
5898 for (cblk = cons_block; cblk; cblk = *cprev)
5900 register int i = 0;
5901 int this_free = 0;
5902 int ilim = (lim + BITS_PER_INT - 1) / BITS_PER_INT;
5904 /* Scan the mark bits an int at a time. */
5905 for (i = 0; i < ilim; i++)
5907 if (cblk->gcmarkbits[i] == -1)
5909 /* Fast path - all cons cells for this int are marked. */
5910 cblk->gcmarkbits[i] = 0;
5911 num_used += BITS_PER_INT;
5913 else
5915 /* Some cons cells for this int are not marked.
5916 Find which ones, and free them. */
5917 int start, pos, stop;
5919 start = i * BITS_PER_INT;
5920 stop = lim - start;
5921 if (stop > BITS_PER_INT)
5922 stop = BITS_PER_INT;
5923 stop += start;
5925 for (pos = start; pos < stop; pos++)
5927 if (!CONS_MARKED_P (&cblk->conses[pos]))
5929 this_free++;
5930 cblk->conses[pos].u.chain = cons_free_list;
5931 cons_free_list = &cblk->conses[pos];
5932 #if GC_MARK_STACK
5933 cons_free_list->car = Vdead;
5934 #endif
5936 else
5938 num_used++;
5939 CONS_UNMARK (&cblk->conses[pos]);
5945 lim = CONS_BLOCK_SIZE;
5946 /* If this block contains only free conses and we have already
5947 seen more than two blocks worth of free conses then deallocate
5948 this block. */
5949 if (this_free == CONS_BLOCK_SIZE && num_free > CONS_BLOCK_SIZE)
5951 *cprev = cblk->next;
5952 /* Unhook from the free list. */
5953 cons_free_list = cblk->conses[0].u.chain;
5954 lisp_align_free (cblk);
5956 else
5958 num_free += this_free;
5959 cprev = &cblk->next;
5962 total_conses = num_used;
5963 total_free_conses = num_free;
5966 /* Put all unmarked floats on free list */
5968 register struct float_block *fblk;
5969 struct float_block **fprev = &float_block;
5970 register int lim = float_block_index;
5971 EMACS_INT num_free = 0, num_used = 0;
5973 float_free_list = 0;
5975 for (fblk = float_block; fblk; fblk = *fprev)
5977 register int i;
5978 int this_free = 0;
5979 for (i = 0; i < lim; i++)
5980 if (!FLOAT_MARKED_P (&fblk->floats[i]))
5982 this_free++;
5983 fblk->floats[i].u.chain = float_free_list;
5984 float_free_list = &fblk->floats[i];
5986 else
5988 num_used++;
5989 FLOAT_UNMARK (&fblk->floats[i]);
5991 lim = FLOAT_BLOCK_SIZE;
5992 /* If this block contains only free floats and we have already
5993 seen more than two blocks worth of free floats then deallocate
5994 this block. */
5995 if (this_free == FLOAT_BLOCK_SIZE && num_free > FLOAT_BLOCK_SIZE)
5997 *fprev = fblk->next;
5998 /* Unhook from the free list. */
5999 float_free_list = fblk->floats[0].u.chain;
6000 lisp_align_free (fblk);
6002 else
6004 num_free += this_free;
6005 fprev = &fblk->next;
6008 total_floats = num_used;
6009 total_free_floats = num_free;
6012 /* Put all unmarked intervals on free list */
6014 register struct interval_block *iblk;
6015 struct interval_block **iprev = &interval_block;
6016 register int lim = interval_block_index;
6017 EMACS_INT num_free = 0, num_used = 0;
6019 interval_free_list = 0;
6021 for (iblk = interval_block; iblk; iblk = *iprev)
6023 register int i;
6024 int this_free = 0;
6026 for (i = 0; i < lim; i++)
6028 if (!iblk->intervals[i].gcmarkbit)
6030 SET_INTERVAL_PARENT (&iblk->intervals[i], interval_free_list);
6031 interval_free_list = &iblk->intervals[i];
6032 this_free++;
6034 else
6036 num_used++;
6037 iblk->intervals[i].gcmarkbit = 0;
6040 lim = INTERVAL_BLOCK_SIZE;
6041 /* If this block contains only free intervals and we have already
6042 seen more than two blocks worth of free intervals then
6043 deallocate this block. */
6044 if (this_free == INTERVAL_BLOCK_SIZE && num_free > INTERVAL_BLOCK_SIZE)
6046 *iprev = iblk->next;
6047 /* Unhook from the free list. */
6048 interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
6049 lisp_free (iblk);
6051 else
6053 num_free += this_free;
6054 iprev = &iblk->next;
6057 total_intervals = num_used;
6058 total_free_intervals = num_free;
6061 /* Put all unmarked symbols on free list */
6063 register struct symbol_block *sblk;
6064 struct symbol_block **sprev = &symbol_block;
6065 register int lim = symbol_block_index;
6066 EMACS_INT num_free = 0, num_used = 0;
6068 symbol_free_list = NULL;
6070 for (sblk = symbol_block; sblk; sblk = *sprev)
6072 int this_free = 0;
6073 struct Lisp_Symbol *sym = sblk->symbols;
6074 struct Lisp_Symbol *end = sym + lim;
6076 for (; sym < end; ++sym)
6078 /* Check if the symbol was created during loadup. In such a case
6079 it might be pointed to by pure bytecode which we don't trace,
6080 so we conservatively assume that it is live. */
6081 int pure_p = PURE_POINTER_P (XSTRING (sym->xname));
6083 if (!sym->gcmarkbit && !pure_p)
6085 if (sym->redirect == SYMBOL_LOCALIZED)
6086 xfree (SYMBOL_BLV (sym));
6087 sym->next = symbol_free_list;
6088 symbol_free_list = sym;
6089 #if GC_MARK_STACK
6090 symbol_free_list->function = Vdead;
6091 #endif
6092 ++this_free;
6094 else
6096 ++num_used;
6097 if (!pure_p)
6098 UNMARK_STRING (XSTRING (sym->xname));
6099 sym->gcmarkbit = 0;
6103 lim = SYMBOL_BLOCK_SIZE;
6104 /* If this block contains only free symbols and we have already
6105 seen more than two blocks worth of free symbols then deallocate
6106 this block. */
6107 if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)
6109 *sprev = sblk->next;
6110 /* Unhook from the free list. */
6111 symbol_free_list = sblk->symbols[0].next;
6112 lisp_free (sblk);
6114 else
6116 num_free += this_free;
6117 sprev = &sblk->next;
6120 total_symbols = num_used;
6121 total_free_symbols = num_free;
6124 /* Put all unmarked misc's on free list.
6125 For a marker, first unchain it from the buffer it points into. */
6127 register struct marker_block *mblk;
6128 struct marker_block **mprev = &marker_block;
6129 register int lim = marker_block_index;
6130 EMACS_INT num_free = 0, num_used = 0;
6132 marker_free_list = 0;
6134 for (mblk = marker_block; mblk; mblk = *mprev)
6136 register int i;
6137 int this_free = 0;
6139 for (i = 0; i < lim; i++)
6141 if (!mblk->markers[i].u_any.gcmarkbit)
6143 if (mblk->markers[i].u_any.type == Lisp_Misc_Marker)
6144 unchain_marker (&mblk->markers[i].u_marker);
6145 /* Set the type of the freed object to Lisp_Misc_Free.
6146 We could leave the type alone, since nobody checks it,
6147 but this might catch bugs faster. */
6148 mblk->markers[i].u_marker.type = Lisp_Misc_Free;
6149 mblk->markers[i].u_free.chain = marker_free_list;
6150 marker_free_list = &mblk->markers[i];
6151 this_free++;
6153 else
6155 num_used++;
6156 mblk->markers[i].u_any.gcmarkbit = 0;
6159 lim = MARKER_BLOCK_SIZE;
6160 /* If this block contains only free markers and we have already
6161 seen more than two blocks worth of free markers then deallocate
6162 this block. */
6163 if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE)
6165 *mprev = mblk->next;
6166 /* Unhook from the free list. */
6167 marker_free_list = mblk->markers[0].u_free.chain;
6168 lisp_free (mblk);
6170 else
6172 num_free += this_free;
6173 mprev = &mblk->next;
6177 total_markers = num_used;
6178 total_free_markers = num_free;
6181 /* Free all unmarked buffers */
6183 register struct buffer *buffer = all_buffers, *prev = 0, *next;
6185 while (buffer)
6186 if (!VECTOR_MARKED_P (buffer))
6188 if (prev)
6189 prev->header.next = buffer->header.next;
6190 else
6191 all_buffers = buffer->header.next.buffer;
6192 next = buffer->header.next.buffer;
6193 lisp_free (buffer);
6194 buffer = next;
6196 else
6198 VECTOR_UNMARK (buffer);
6199 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer));
6200 prev = buffer, buffer = buffer->header.next.buffer;
6204 /* Free all unmarked vectors */
6206 register struct Lisp_Vector *vector = all_vectors, *prev = 0, *next;
6207 total_vector_size = 0;
6209 while (vector)
6210 if (!VECTOR_MARKED_P (vector))
6212 if (prev)
6213 prev->header.next = vector->header.next;
6214 else
6215 all_vectors = vector->header.next.vector;
6216 next = vector->header.next.vector;
6217 lisp_free (vector);
6218 vector = next;
6221 else
6223 VECTOR_UNMARK (vector);
6224 if (vector->header.size & PSEUDOVECTOR_FLAG)
6225 total_vector_size += PSEUDOVECTOR_SIZE_MASK & vector->header.size;
6226 else
6227 total_vector_size += vector->header.size;
6228 prev = vector, vector = vector->header.next.vector;
6232 #ifdef GC_CHECK_STRING_BYTES
6233 if (!noninteractive)
6234 check_string_bytes (1);
6235 #endif
6241 /* Debugging aids. */
6243 DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0,
6244 doc: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6245 This may be helpful in debugging Emacs's memory usage.
6246 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6247 (void)
6249 Lisp_Object end;
6251 XSETINT (end, (intptr_t) (char *) sbrk (0) / 1024);
6253 return end;
6256 DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0,
6257 doc: /* Return a list of counters that measure how much consing there has been.
6258 Each of these counters increments for a certain kind of object.
6259 The counters wrap around from the largest positive integer to zero.
6260 Garbage collection does not decrease them.
6261 The elements of the value are as follows:
6262 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6263 All are in units of 1 = one object consed
6264 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6265 objects consed.
6266 MISCS include overlays, markers, and some internal types.
6267 Frames, windows, buffers, and subprocesses count as vectors
6268 (but the contents of a buffer's text do not count here). */)
6269 (void)
6271 Lisp_Object consed[8];
6273 consed[0] = make_number (min (MOST_POSITIVE_FIXNUM, cons_cells_consed));
6274 consed[1] = make_number (min (MOST_POSITIVE_FIXNUM, floats_consed));
6275 consed[2] = make_number (min (MOST_POSITIVE_FIXNUM, vector_cells_consed));
6276 consed[3] = make_number (min (MOST_POSITIVE_FIXNUM, symbols_consed));
6277 consed[4] = make_number (min (MOST_POSITIVE_FIXNUM, string_chars_consed));
6278 consed[5] = make_number (min (MOST_POSITIVE_FIXNUM, misc_objects_consed));
6279 consed[6] = make_number (min (MOST_POSITIVE_FIXNUM, intervals_consed));
6280 consed[7] = make_number (min (MOST_POSITIVE_FIXNUM, strings_consed));
6282 return Flist (8, consed);
6285 /* Find at most FIND_MAX symbols which have OBJ as their value or
6286 function. This is used in gdbinit's `xwhichsymbols' command. */
6288 Lisp_Object
6289 which_symbols (Lisp_Object obj, EMACS_INT find_max)
6291 struct symbol_block *sblk;
6292 int gc_count = inhibit_garbage_collection ();
6293 Lisp_Object found = Qnil;
6295 if (! DEADP (obj))
6297 for (sblk = symbol_block; sblk; sblk = sblk->next)
6299 struct Lisp_Symbol *sym = sblk->symbols;
6300 int bn;
6302 for (bn = 0; bn < SYMBOL_BLOCK_SIZE; bn++, sym++)
6304 Lisp_Object val;
6305 Lisp_Object tem;
6307 if (sblk == symbol_block && bn >= symbol_block_index)
6308 break;
6310 XSETSYMBOL (tem, sym);
6311 val = find_symbol_value (tem);
6312 if (EQ (val, obj)
6313 || EQ (sym->function, obj)
6314 || (!NILP (sym->function)
6315 && COMPILEDP (sym->function)
6316 && EQ (AREF (sym->function, COMPILED_BYTECODE), obj))
6317 || (!NILP (val)
6318 && COMPILEDP (val)
6319 && EQ (AREF (val, COMPILED_BYTECODE), obj)))
6321 found = Fcons (tem, found);
6322 if (--find_max == 0)
6323 goto out;
6329 out:
6330 unbind_to (gc_count, Qnil);
6331 return found;
6334 #ifdef ENABLE_CHECKING
6335 int suppress_checking;
6337 void
6338 die (const char *msg, const char *file, int line)
6340 fprintf (stderr, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6341 file, line, msg);
6342 abort ();
6344 #endif
6346 /* Initialization */
6348 void
6349 init_alloc_once (void)
6351 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6352 purebeg = PUREBEG;
6353 pure_size = PURESIZE;
6354 pure_bytes_used = 0;
6355 pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
6356 pure_bytes_used_before_overflow = 0;
6358 /* Initialize the list of free aligned blocks. */
6359 free_ablock = NULL;
6361 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6362 mem_init ();
6363 Vdead = make_pure_string ("DEAD", 4, 4, 0);
6364 #endif
6366 all_vectors = 0;
6367 ignore_warnings = 1;
6368 #ifdef DOUG_LEA_MALLOC
6369 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
6370 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
6371 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* max. number of mmap'ed areas */
6372 #endif
6373 init_strings ();
6374 init_cons ();
6375 init_symbol ();
6376 init_marker ();
6377 init_float ();
6378 init_intervals ();
6379 init_weak_hash_tables ();
6381 #ifdef REL_ALLOC
6382 malloc_hysteresis = 32;
6383 #else
6384 malloc_hysteresis = 0;
6385 #endif
6387 refill_memory_reserve ();
6389 ignore_warnings = 0;
6390 gcprolist = 0;
6391 byte_stack_list = 0;
6392 staticidx = 0;
6393 consing_since_gc = 0;
6394 gc_cons_threshold = 100000 * sizeof (Lisp_Object);
6395 gc_relative_threshold = 0;
6398 void
6399 init_alloc (void)
6401 gcprolist = 0;
6402 byte_stack_list = 0;
6403 #if GC_MARK_STACK
6404 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6405 setjmp_tested_p = longjmps_done = 0;
6406 #endif
6407 #endif
6408 Vgc_elapsed = make_float (0.0);
6409 gcs_done = 0;
6412 void
6413 syms_of_alloc (void)
6415 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold,
6416 doc: /* Number of bytes of consing between garbage collections.
6417 Garbage collection can happen automatically once this many bytes have been
6418 allocated since the last garbage collection. All data types count.
6420 Garbage collection happens automatically only when `eval' is called.
6422 By binding this temporarily to a large number, you can effectively
6423 prevent garbage collection during a part of the program.
6424 See also `gc-cons-percentage'. */);
6426 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage,
6427 doc: /* Portion of the heap used for allocation.
6428 Garbage collection can happen automatically once this portion of the heap
6429 has been allocated since the last garbage collection.
6430 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6431 Vgc_cons_percentage = make_float (0.1);
6433 DEFVAR_INT ("pure-bytes-used", pure_bytes_used,
6434 doc: /* Number of bytes of shareable Lisp data allocated so far. */);
6436 DEFVAR_INT ("cons-cells-consed", cons_cells_consed,
6437 doc: /* Number of cons cells that have been consed so far. */);
6439 DEFVAR_INT ("floats-consed", floats_consed,
6440 doc: /* Number of floats that have been consed so far. */);
6442 DEFVAR_INT ("vector-cells-consed", vector_cells_consed,
6443 doc: /* Number of vector cells that have been consed so far. */);
6445 DEFVAR_INT ("symbols-consed", symbols_consed,
6446 doc: /* Number of symbols that have been consed so far. */);
6448 DEFVAR_INT ("string-chars-consed", string_chars_consed,
6449 doc: /* Number of string characters that have been consed so far. */);
6451 DEFVAR_INT ("misc-objects-consed", misc_objects_consed,
6452 doc: /* Number of miscellaneous objects that have been consed so far.
6453 These include markers and overlays, plus certain objects not visible
6454 to users. */);
6456 DEFVAR_INT ("intervals-consed", intervals_consed,
6457 doc: /* Number of intervals that have been consed so far. */);
6459 DEFVAR_INT ("strings-consed", strings_consed,
6460 doc: /* Number of strings that have been consed so far. */);
6462 DEFVAR_LISP ("purify-flag", Vpurify_flag,
6463 doc: /* Non-nil means loading Lisp code in order to dump an executable.
6464 This means that certain objects should be allocated in shared (pure) space.
6465 It can also be set to a hash-table, in which case this table is used to
6466 do hash-consing of the objects allocated to pure space. */);
6468 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages,
6469 doc: /* Non-nil means display messages at start and end of garbage collection. */);
6470 garbage_collection_messages = 0;
6472 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook,
6473 doc: /* Hook run after garbage collection has finished. */);
6474 Vpost_gc_hook = Qnil;
6475 DEFSYM (Qpost_gc_hook, "post-gc-hook");
6477 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data,
6478 doc: /* Precomputed `signal' argument for memory-full error. */);
6479 /* We build this in advance because if we wait until we need it, we might
6480 not be able to allocate the memory to hold it. */
6481 Vmemory_signal_data
6482 = pure_cons (Qerror,
6483 pure_cons (make_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil));
6485 DEFVAR_LISP ("memory-full", Vmemory_full,
6486 doc: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6487 Vmemory_full = Qnil;
6489 DEFSYM (Qgc_cons_threshold, "gc-cons-threshold");
6490 DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots");
6492 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed,
6493 doc: /* Accumulated time elapsed in garbage collections.
6494 The time is in seconds as a floating point value. */);
6495 DEFVAR_INT ("gcs-done", gcs_done,
6496 doc: /* Accumulated number of garbage collections done. */);
6498 defsubr (&Scons);
6499 defsubr (&Slist);
6500 defsubr (&Svector);
6501 defsubr (&Smake_byte_code);
6502 defsubr (&Smake_list);
6503 defsubr (&Smake_vector);
6504 defsubr (&Smake_string);
6505 defsubr (&Smake_bool_vector);
6506 defsubr (&Smake_symbol);
6507 defsubr (&Smake_marker);
6508 defsubr (&Spurecopy);
6509 defsubr (&Sgarbage_collect);
6510 defsubr (&Smemory_limit);
6511 defsubr (&Smemory_use_counts);
6513 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6514 defsubr (&Sgc_status);
6515 #endif