aboutsummaryrefslogtreecommitdiffstats
path: root/src/alloc.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/alloc.c')
-rw-r--r--src/alloc.c2892
1 files changed, 1542 insertions, 1350 deletions
diff --git a/src/alloc.c b/src/alloc.c
index 6f70976c345..28c9b51dab4 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -1,6 +1,7 @@
1/* Storage allocation and gc for GNU Emacs Lisp interpreter. 1/* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2011 2
3 Free Software Foundation, Inc. 3Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2012
4 Free Software Foundation, Inc.
4 5
5This file is part of GNU Emacs. 6This file is part of GNU Emacs.
6 7
@@ -18,52 +19,58 @@ You should have received a copy of the GNU General Public License
18along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ 19along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
19 20
20#include <config.h> 21#include <config.h>
22
23#define LISP_INLINE EXTERN_INLINE
24
21#include <stdio.h> 25#include <stdio.h>
22#include <limits.h> /* For CHAR_BIT. */ 26#include <limits.h> /* For CHAR_BIT. */
23#include <setjmp.h>
24 27
25#include <signal.h> 28#ifdef ENABLE_CHECKING
29#include <signal.h> /* For SIGABRT. */
30#endif
26 31
27#ifdef HAVE_PTHREAD 32#ifdef HAVE_PTHREAD
28#include <pthread.h> 33#include <pthread.h>
29#endif 34#endif
30 35
31/* This file is part of the core Lisp implementation, and thus must
32 deal with the real data structures. If the Lisp implementation is
33 replaced, this file likely will not be used. */
34
35#undef HIDE_LISP_IMPLEMENTATION
36#include "lisp.h" 36#include "lisp.h"
37#include "process.h" 37#include "process.h"
38#include "intervals.h" 38#include "intervals.h"
39#include "puresize.h" 39#include "puresize.h"
40#include "character.h"
40#include "buffer.h" 41#include "buffer.h"
41#include "window.h" 42#include "window.h"
42#include "keyboard.h" 43#include "keyboard.h"
43#include "frame.h" 44#include "frame.h"
44#include "blockinput.h" 45#include "blockinput.h"
45#include "character.h"
46#include "syssignal.h"
47#include "termhooks.h" /* For struct terminal. */ 46#include "termhooks.h" /* For struct terminal. */
48#include <setjmp.h> 47
49#include <verify.h> 48#include <verify.h>
50 49
50/* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
51 Doable only if GC_MARK_STACK. */
52#if ! GC_MARK_STACK
53# undef GC_CHECK_MARKED_OBJECTS
54#endif
55
51/* GC_MALLOC_CHECK defined means perform validity checks of malloc'd 56/* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
52 memory. Can do this only if using gmalloc.c. */ 57 memory. Can do this only if using gmalloc.c and if not checking
58 marked objects. */
53 59
54#if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC 60#if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
61 || defined GC_CHECK_MARKED_OBJECTS)
55#undef GC_MALLOC_CHECK 62#undef GC_MALLOC_CHECK
56#endif 63#endif
57 64
58#include <unistd.h> 65#include <unistd.h>
59#ifndef HAVE_UNISTD_H
60extern POINTER_TYPE *sbrk ();
61#endif
62
63#include <fcntl.h> 66#include <fcntl.h>
64 67
68#ifdef USE_GTK
69# include "gtkutil.h"
70#endif
65#ifdef WINDOWSNT 71#ifdef WINDOWSNT
66#include "w32.h" 72#include "w32.h"
73#include "w32heap.h" /* for sbrk */
67#endif 74#endif
68 75
69#ifdef DOUG_LEA_MALLOC 76#ifdef DOUG_LEA_MALLOC
@@ -75,64 +82,8 @@ extern POINTER_TYPE *sbrk ();
75 82
76#define MMAP_MAX_AREAS 100000000 83#define MMAP_MAX_AREAS 100000000
77 84
78#else /* not DOUG_LEA_MALLOC */
79
80/* The following come from gmalloc.c. */
81
82extern size_t _bytes_used;
83extern size_t __malloc_extra_blocks;
84
85#endif /* not DOUG_LEA_MALLOC */ 85#endif /* not DOUG_LEA_MALLOC */
86 86
87#if ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT
88#ifdef HAVE_PTHREAD
89
90/* When GTK uses the file chooser dialog, different backends can be loaded
91 dynamically. One such a backend is the Gnome VFS backend that gets loaded
92 if you run Gnome. That backend creates several threads and also allocates
93 memory with malloc.
94
95 Also, gconf and gsettings may create several threads.
96
97 If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
98 functions below are called from malloc, there is a chance that one
99 of these threads preempts the Emacs main thread and the hook variables
100 end up in an inconsistent state. So we have a mutex to prevent that (note
101 that the backend handles concurrent access to malloc within its own threads
102 but Emacs code running in the main thread is not included in that control).
103
104 When UNBLOCK_INPUT is called, reinvoke_input_signal may be called. If this
105 happens in one of the backend threads we will have two threads that tries
106 to run Emacs code at once, and the code is not prepared for that.
107 To prevent that, we only call BLOCK/UNBLOCK from the main thread. */
108
109static pthread_mutex_t alloc_mutex;
110
111#define BLOCK_INPUT_ALLOC \
112 do \
113 { \
114 if (pthread_equal (pthread_self (), main_thread)) \
115 BLOCK_INPUT; \
116 pthread_mutex_lock (&alloc_mutex); \
117 } \
118 while (0)
119#define UNBLOCK_INPUT_ALLOC \
120 do \
121 { \
122 pthread_mutex_unlock (&alloc_mutex); \
123 if (pthread_equal (pthread_self (), main_thread)) \
124 UNBLOCK_INPUT; \
125 } \
126 while (0)
127
128#else /* ! defined HAVE_PTHREAD */
129
130#define BLOCK_INPUT_ALLOC BLOCK_INPUT
131#define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
132
133#endif /* ! defined HAVE_PTHREAD */
134#endif /* ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT */
135
136/* Mark, unmark, query mark bit of a Lisp string. S must be a pointer 87/* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
137 to a struct Lisp_String. */ 88 to a struct Lisp_String. */
138 89
@@ -144,11 +95,9 @@ static pthread_mutex_t alloc_mutex;
144#define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG) 95#define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
145#define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0) 96#define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
146 97
147/* Value is the number of bytes of S, a pointer to a struct Lisp_String. 98/* Default value of gc_cons_threshold (see below). */
148 Be careful during GC, because S->size contains the mark bit for
149 strings. */
150 99
151#define GC_STRING_BYTES(S) (STRING_BYTES (S)) 100#define GC_DEFAULT_THRESHOLD (100000 * word_size)
152 101
153/* Global variables. */ 102/* Global variables. */
154struct emacs_globals globals; 103struct emacs_globals globals;
@@ -166,19 +115,19 @@ EMACS_INT gc_relative_threshold;
166 115
167EMACS_INT memory_full_cons_threshold; 116EMACS_INT memory_full_cons_threshold;
168 117
169/* Nonzero during GC. */ 118/* True during GC. */
170 119
171int gc_in_progress; 120bool gc_in_progress;
172 121
173/* Nonzero means abort if try to GC. 122/* True means abort if try to GC.
174 This is for code which is written on the assumption that 123 This is for code which is written on the assumption that
175 no GC will happen, so as to verify that assumption. */ 124 no GC will happen, so as to verify that assumption. */
176 125
177int abort_on_gc; 126bool abort_on_gc;
178 127
179/* Number of live and free conses etc. */ 128/* Number of live and free conses etc. */
180 129
181static EMACS_INT total_conses, total_markers, total_symbols, total_vector_size; 130static EMACS_INT total_conses, total_markers, total_symbols, total_buffers;
182static EMACS_INT total_free_conses, total_free_markers, total_free_symbols; 131static EMACS_INT total_free_conses, total_free_markers, total_free_symbols;
183static EMACS_INT total_free_floats, total_floats; 132static EMACS_INT total_free_floats, total_floats;
184 133
@@ -193,10 +142,6 @@ static char *spare_memory[7];
193 142
194#define SPARE_MEMORY (1 << 14) 143#define SPARE_MEMORY (1 << 14)
195 144
196/* Number of extra blocks malloc should get when it needs more core. */
197
198static int malloc_hysteresis;
199
200/* Initialize it to a nonzero value to force it into data space 145/* Initialize it to a nonzero value to force it into data space
201 (rather than bss space). That way unexec will remap it into text 146 (rather than bss space). That way unexec will remap it into text
202 space (pure), on some systems. We have not implemented the 147 space (pure), on some systems. We have not implemented the
@@ -216,18 +161,18 @@ static ptrdiff_t pure_size;
216 161
217static ptrdiff_t pure_bytes_used_before_overflow; 162static ptrdiff_t pure_bytes_used_before_overflow;
218 163
219/* Value is non-zero if P points into pure space. */ 164/* True if P points into pure space. */
220 165
221#define PURE_POINTER_P(P) \ 166#define PURE_POINTER_P(P) \
222 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size) 167 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
223 168
224/* Index in pure at which next pure Lisp object will be allocated.. */ 169/* Index in pure at which next pure Lisp object will be allocated.. */
225 170
226static EMACS_INT pure_bytes_used_lisp; 171static ptrdiff_t pure_bytes_used_lisp;
227 172
228/* Number of bytes allocated for non-Lisp objects in pure storage. */ 173/* Number of bytes allocated for non-Lisp objects in pure storage. */
229 174
230static EMACS_INT pure_bytes_used_non_lisp; 175static ptrdiff_t pure_bytes_used_non_lisp;
231 176
232/* If nonzero, this is a warning delivered by malloc and not yet 177/* If nonzero, this is a warning delivered by malloc and not yet
233 displayed. */ 178 displayed. */
@@ -247,37 +192,39 @@ static char *stack_copy;
247static ptrdiff_t stack_copy_size; 192static ptrdiff_t stack_copy_size;
248#endif 193#endif
249 194
250/* Non-zero means ignore malloc warnings. Set during initialization. 195static Lisp_Object Qconses;
251 Currently not used. */ 196static Lisp_Object Qsymbols;
252 197static Lisp_Object Qmiscs;
253static int ignore_warnings; 198static Lisp_Object Qstrings;
254 199static Lisp_Object Qvectors;
200static Lisp_Object Qfloats;
201static Lisp_Object Qintervals;
202static Lisp_Object Qbuffers;
203static Lisp_Object Qstring_bytes, Qvector_slots, Qheap;
255static Lisp_Object Qgc_cons_threshold; 204static Lisp_Object Qgc_cons_threshold;
205Lisp_Object Qautomatic_gc;
256Lisp_Object Qchar_table_extra_slots; 206Lisp_Object Qchar_table_extra_slots;
257 207
258/* Hook run after GC has finished. */ 208/* Hook run after GC has finished. */
259 209
260static Lisp_Object Qpost_gc_hook; 210static Lisp_Object Qpost_gc_hook;
261 211
262static void mark_buffer (Lisp_Object);
263static void mark_terminals (void); 212static void mark_terminals (void);
264static void gc_sweep (void); 213static void gc_sweep (void);
265static void mark_glyph_matrix (struct glyph_matrix *); 214static Lisp_Object make_pure_vector (ptrdiff_t);
266static void mark_face_cache (struct face_cache *); 215static void mark_buffer (struct buffer *);
267 216
268#if !defined REL_ALLOC || defined SYSTEM_MALLOC 217#if !defined REL_ALLOC || defined SYSTEM_MALLOC
269static void refill_memory_reserve (void); 218static void refill_memory_reserve (void);
270#endif 219#endif
271static struct Lisp_String *allocate_string (void);
272static void compact_small_strings (void); 220static void compact_small_strings (void);
273static void free_large_strings (void); 221static void free_large_strings (void);
274static void sweep_strings (void);
275static void free_misc (Lisp_Object); 222static void free_misc (Lisp_Object);
276extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE; 223extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
277 224
278/* When scanning the C stack for live Lisp objects, Emacs keeps track 225/* When scanning the C stack for live Lisp objects, Emacs keeps track of
279 of what memory allocated via lisp_malloc is intended for what 226 what memory allocated via lisp_malloc and lisp_align_malloc is intended
280 purpose. This enumeration specifies the type of memory. */ 227 for what purpose. This enumeration specifies the type of memory. */
281 228
282enum mem_type 229enum mem_type
283{ 230{
@@ -288,17 +235,16 @@ enum mem_type
288 MEM_TYPE_MISC, 235 MEM_TYPE_MISC,
289 MEM_TYPE_SYMBOL, 236 MEM_TYPE_SYMBOL,
290 MEM_TYPE_FLOAT, 237 MEM_TYPE_FLOAT,
291 /* We used to keep separate mem_types for subtypes of vectors such as 238 /* Since all non-bool pseudovectors are small enough to be
292 process, hash_table, frame, terminal, and window, but we never made 239 allocated from vector blocks, this memory type denotes
293 use of the distinction, so it only caused source-code complexity 240 large regular vectors and large bool pseudovectors. */
294 and runtime slowdown. Minor but pointless. */ 241 MEM_TYPE_VECTORLIKE,
295 MEM_TYPE_VECTORLIKE 242 /* Special type to denote vector blocks. */
243 MEM_TYPE_VECTOR_BLOCK,
244 /* Special type to denote reserved memory. */
245 MEM_TYPE_SPARE
296}; 246};
297 247
298static POINTER_TYPE *lisp_align_malloc (size_t, enum mem_type);
299static POINTER_TYPE *lisp_malloc (size_t, enum mem_type);
300
301
302#if GC_MARK_STACK || defined GC_MALLOC_CHECK 248#if GC_MARK_STACK || defined GC_MALLOC_CHECK
303 249
304#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES 250#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
@@ -314,7 +260,6 @@ static Lisp_Object Vdead;
314#ifdef GC_MALLOC_CHECK 260#ifdef GC_MALLOC_CHECK
315 261
316enum mem_type allocated_mem_type; 262enum mem_type allocated_mem_type;
317static int dont_register_blocks;
318 263
319#endif /* GC_MALLOC_CHECK */ 264#endif /* GC_MALLOC_CHECK */
320 265
@@ -378,18 +323,19 @@ static void *min_heap_address, *max_heap_address;
378static struct mem_node mem_z; 323static struct mem_node mem_z;
379#define MEM_NIL &mem_z 324#define MEM_NIL &mem_z
380 325
381static struct Lisp_Vector *allocate_vectorlike (EMACS_INT); 326static struct Lisp_Vector *allocate_vectorlike (ptrdiff_t);
382static void lisp_free (POINTER_TYPE *); 327static void lisp_free (void *);
383static void mark_stack (void); 328static void mark_stack (void);
384static int live_vector_p (struct mem_node *, void *); 329static bool live_vector_p (struct mem_node *, void *);
385static int live_buffer_p (struct mem_node *, void *); 330static bool live_buffer_p (struct mem_node *, void *);
386static int live_string_p (struct mem_node *, void *); 331static bool live_string_p (struct mem_node *, void *);
387static int live_cons_p (struct mem_node *, void *); 332static bool live_cons_p (struct mem_node *, void *);
388static int live_symbol_p (struct mem_node *, void *); 333static bool live_symbol_p (struct mem_node *, void *);
389static int live_float_p (struct mem_node *, void *); 334static bool live_float_p (struct mem_node *, void *);
390static int live_misc_p (struct mem_node *, void *); 335static bool live_misc_p (struct mem_node *, void *);
391static void mark_maybe_object (Lisp_Object); 336static void mark_maybe_object (Lisp_Object);
392static void mark_memory (void *, void *); 337static void mark_memory (void *, void *);
338#if GC_MARK_STACK || defined GC_MALLOC_CHECK
393static void mem_init (void); 339static void mem_init (void);
394static struct mem_node *mem_insert (void *, void *, enum mem_type); 340static struct mem_node *mem_insert (void *, void *, enum mem_type);
395static void mem_insert_fixup (struct mem_node *); 341static void mem_insert_fixup (struct mem_node *);
@@ -397,7 +343,8 @@ static void mem_rotate_left (struct mem_node *);
397static void mem_rotate_right (struct mem_node *); 343static void mem_rotate_right (struct mem_node *);
398static void mem_delete (struct mem_node *); 344static void mem_delete (struct mem_node *);
399static void mem_delete_fixup (struct mem_node *); 345static void mem_delete_fixup (struct mem_node *);
400static inline struct mem_node *mem_find (void *); 346static struct mem_node *mem_find (void *);
347#endif
401 348
402 349
403#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS 350#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
@@ -417,22 +364,22 @@ struct gcpro *gcprolist;
417/* Addresses of staticpro'd variables. Initialize it to a nonzero 364/* Addresses of staticpro'd variables. Initialize it to a nonzero
418 value; otherwise some compilers put it into BSS. */ 365 value; otherwise some compilers put it into BSS. */
419 366
420#define NSTATICS 0x640 367#define NSTATICS 0x800
421static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag}; 368static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
422 369
423/* Index of next unused slot in staticvec. */ 370/* Index of next unused slot in staticvec. */
424 371
425static int staticidx = 0; 372static int staticidx;
426 373
427static POINTER_TYPE *pure_alloc (size_t, int); 374static void *pure_alloc (size_t, int);
428 375
429 376
430/* Value is SZ rounded up to the next multiple of ALIGNMENT. 377/* Value is SZ rounded up to the next multiple of ALIGNMENT.
431 ALIGNMENT must be a power of 2. */ 378 ALIGNMENT must be a power of 2. */
432 379
433#define ALIGN(ptr, ALIGNMENT) \ 380#define ALIGN(ptr, ALIGNMENT) \
434 ((POINTER_TYPE *) ((((uintptr_t) (ptr)) + (ALIGNMENT) - 1) \ 381 ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
435 & ~((ALIGNMENT) - 1))) 382 & ~ ((ALIGNMENT) - 1)))
436 383
437 384
438 385
@@ -464,7 +411,7 @@ display_malloc_warning (void)
464/* Called if we can't allocate relocatable space for a buffer. */ 411/* Called if we can't allocate relocatable space for a buffer. */
465 412
466void 413void
467buffer_memory_full (EMACS_INT nbytes) 414buffer_memory_full (ptrdiff_t nbytes)
468{ 415{
469 /* If buffers use the relocating allocator, no need to free 416 /* If buffers use the relocating allocator, no need to free
470 spare_memory, because we may have plenty of malloc space left 417 spare_memory, because we may have plenty of malloc space left
@@ -482,6 +429,11 @@ buffer_memory_full (EMACS_INT nbytes)
482 xsignal (Qnil, Vmemory_signal_data); 429 xsignal (Qnil, Vmemory_signal_data);
483} 430}
484 431
432/* A common multiple of the positive integers A and B. Ideally this
433 would be the least common multiple, but there's no way to do that
434 as a constant expression in C, so do the best that we can easily do. */
435#define COMMON_MULTIPLE(a, b) \
436 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
485 437
486#ifndef XMALLOC_OVERRUN_CHECK 438#ifndef XMALLOC_OVERRUN_CHECK
487#define XMALLOC_OVERRUN_CHECK_OVERHEAD 0 439#define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
@@ -507,20 +459,11 @@ buffer_memory_full (EMACS_INT nbytes)
507 hold a size_t value and (2) the header size is a multiple of the 459 hold a size_t value and (2) the header size is a multiple of the
508 alignment that Emacs needs for C types and for USE_LSB_TAG. */ 460 alignment that Emacs needs for C types and for USE_LSB_TAG. */
509#define XMALLOC_BASE_ALIGNMENT \ 461#define XMALLOC_BASE_ALIGNMENT \
510 offsetof ( \ 462 alignof (union { long double d; intmax_t i; void *p; })
511 struct { \ 463
512 union { long double d; intmax_t i; void *p; } u; \ 464#if USE_LSB_TAG
513 char c; \
514 }, \
515 c)
516#ifdef USE_LSB_TAG
517/* A common multiple of the positive integers A and B. Ideally this
518 would be the least common multiple, but there's no way to do that
519 as a constant expression in C, so do the best that we can easily do. */
520# define COMMON_MULTIPLE(a, b) \
521 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
522# define XMALLOC_HEADER_ALIGNMENT \ 465# define XMALLOC_HEADER_ALIGNMENT \
523 COMMON_MULTIPLE (1 << GCTYPEBITS, XMALLOC_BASE_ALIGNMENT) 466 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
524#else 467#else
525# define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT 468# define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
526#endif 469#endif
@@ -570,39 +513,17 @@ xmalloc_get_size (unsigned char *ptr)
570} 513}
571 514
572 515
573/* The call depth in overrun_check functions. For example, this might happen:
574 xmalloc()
575 overrun_check_malloc()
576 -> malloc -> (via hook)_-> emacs_blocked_malloc
577 -> overrun_check_malloc
578 call malloc (hooks are NULL, so real malloc is called).
579 malloc returns 10000.
580 add overhead, return 10016.
581 <- (back in overrun_check_malloc)
582 add overhead again, return 10032
583 xmalloc returns 10032.
584
585 (time passes).
586
587 xfree(10032)
588 overrun_check_free(10032)
589 decrease overhead
590 free(10016) <- crash, because 10000 is the original pointer. */
591
592static ptrdiff_t check_depth;
593
594/* Like malloc, but wraps allocated block with header and trailer. */ 516/* Like malloc, but wraps allocated block with header and trailer. */
595 517
596static POINTER_TYPE * 518static void *
597overrun_check_malloc (size_t size) 519overrun_check_malloc (size_t size)
598{ 520{
599 register unsigned char *val; 521 register unsigned char *val;
600 int overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD : 0; 522 if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
601 if (SIZE_MAX - overhead < size) 523 emacs_abort ();
602 abort ();
603 524
604 val = (unsigned char *) malloc (size + overhead); 525 val = malloc (size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
605 if (val && check_depth == 1) 526 if (val)
606 { 527 {
607 memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE); 528 memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
608 val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE; 529 val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
@@ -610,24 +531,21 @@ overrun_check_malloc (size_t size)
610 memcpy (val + size, xmalloc_overrun_check_trailer, 531 memcpy (val + size, xmalloc_overrun_check_trailer,
611 XMALLOC_OVERRUN_CHECK_SIZE); 532 XMALLOC_OVERRUN_CHECK_SIZE);
612 } 533 }
613 --check_depth; 534 return val;
614 return (POINTER_TYPE *)val;
615} 535}
616 536
617 537
618/* Like realloc, but checks old block for overrun, and wraps new block 538/* Like realloc, but checks old block for overrun, and wraps new block
619 with header and trailer. */ 539 with header and trailer. */
620 540
621static POINTER_TYPE * 541static void *
622overrun_check_realloc (POINTER_TYPE *block, size_t size) 542overrun_check_realloc (void *block, size_t size)
623{ 543{
624 register unsigned char *val = (unsigned char *) block; 544 register unsigned char *val = (unsigned char *) block;
625 int overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD : 0; 545 if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
626 if (SIZE_MAX - overhead < size) 546 emacs_abort ();
627 abort ();
628 547
629 if (val 548 if (val
630 && check_depth == 1
631 && memcmp (xmalloc_overrun_check_header, 549 && memcmp (xmalloc_overrun_check_header,
632 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE, 550 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
633 XMALLOC_OVERRUN_CHECK_SIZE) == 0) 551 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
@@ -635,15 +553,15 @@ overrun_check_realloc (POINTER_TYPE *block, size_t size)
635 size_t osize = xmalloc_get_size (val); 553 size_t osize = xmalloc_get_size (val);
636 if (memcmp (xmalloc_overrun_check_trailer, val + osize, 554 if (memcmp (xmalloc_overrun_check_trailer, val + osize,
637 XMALLOC_OVERRUN_CHECK_SIZE)) 555 XMALLOC_OVERRUN_CHECK_SIZE))
638 abort (); 556 emacs_abort ();
639 memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE); 557 memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
640 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE; 558 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
641 memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE); 559 memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
642 } 560 }
643 561
644 val = (unsigned char *) realloc ((POINTER_TYPE *)val, size + overhead); 562 val = realloc (val, size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
645 563
646 if (val && check_depth == 1) 564 if (val)
647 { 565 {
648 memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE); 566 memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
649 val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE; 567 val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
@@ -651,20 +569,17 @@ overrun_check_realloc (POINTER_TYPE *block, size_t size)
651 memcpy (val + size, xmalloc_overrun_check_trailer, 569 memcpy (val + size, xmalloc_overrun_check_trailer,
652 XMALLOC_OVERRUN_CHECK_SIZE); 570 XMALLOC_OVERRUN_CHECK_SIZE);
653 } 571 }
654 --check_depth; 572 return val;
655 return (POINTER_TYPE *)val;
656} 573}
657 574
658/* Like free, but checks block for overrun. */ 575/* Like free, but checks block for overrun. */
659 576
660static void 577static void
661overrun_check_free (POINTER_TYPE *block) 578overrun_check_free (void *block)
662{ 579{
663 unsigned char *val = (unsigned char *) block; 580 unsigned char *val = (unsigned char *) block;
664 581
665 ++check_depth;
666 if (val 582 if (val
667 && check_depth == 1
668 && memcmp (xmalloc_overrun_check_header, 583 && memcmp (xmalloc_overrun_check_header,
669 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE, 584 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
670 XMALLOC_OVERRUN_CHECK_SIZE) == 0) 585 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
@@ -672,7 +587,7 @@ overrun_check_free (POINTER_TYPE *block)
672 size_t osize = xmalloc_get_size (val); 587 size_t osize = xmalloc_get_size (val);
673 if (memcmp (xmalloc_overrun_check_trailer, val + osize, 588 if (memcmp (xmalloc_overrun_check_trailer, val + osize,
674 XMALLOC_OVERRUN_CHECK_SIZE)) 589 XMALLOC_OVERRUN_CHECK_SIZE))
675 abort (); 590 emacs_abort ();
676#ifdef XMALLOC_CLEAR_FREE_MEMORY 591#ifdef XMALLOC_CLEAR_FREE_MEMORY
677 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE; 592 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
678 memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_OVERHEAD); 593 memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_OVERHEAD);
@@ -684,7 +599,6 @@ overrun_check_free (POINTER_TYPE *block)
684 } 599 }
685 600
686 free (val); 601 free (val);
687 --check_depth;
688} 602}
689 603
690#undef malloc 604#undef malloc
@@ -695,51 +609,96 @@ overrun_check_free (POINTER_TYPE *block)
695#define free overrun_check_free 609#define free overrun_check_free
696#endif 610#endif
697 611
698#ifdef SYNC_INPUT 612/* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
699/* When using SYNC_INPUT, we don't call malloc from a signal handler, so 613 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
700 there's no need to block input around malloc. */ 614 If that variable is set, block input while in one of Emacs's memory
701#define MALLOC_BLOCK_INPUT ((void)0) 615 allocation functions. There should be no need for this debugging
702#define MALLOC_UNBLOCK_INPUT ((void)0) 616 option, since signal handlers do not allocate memory, but Emacs
617 formerly allocated memory in signal handlers and this compile-time
618 option remains as a way to help debug the issue should it rear its
619 ugly head again. */
620#ifdef XMALLOC_BLOCK_INPUT_CHECK
621bool block_input_in_memory_allocators EXTERNALLY_VISIBLE;
622static void
623malloc_block_input (void)
624{
625 if (block_input_in_memory_allocators)
626 block_input ();
627}
628static void
629malloc_unblock_input (void)
630{
631 if (block_input_in_memory_allocators)
632 unblock_input ();
633}
634# define MALLOC_BLOCK_INPUT malloc_block_input ()
635# define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
703#else 636#else
704#define MALLOC_BLOCK_INPUT BLOCK_INPUT 637# define MALLOC_BLOCK_INPUT ((void) 0)
705#define MALLOC_UNBLOCK_INPUT UNBLOCK_INPUT 638# define MALLOC_UNBLOCK_INPUT ((void) 0)
706#endif 639#endif
707 640
641#define MALLOC_PROBE(size) \
642 do { \
643 if (profiler_memory_running) \
644 malloc_probe (size); \
645 } while (0)
646
647
708/* Like malloc but check for no memory and block interrupt input.. */ 648/* Like malloc but check for no memory and block interrupt input.. */
709 649
710POINTER_TYPE * 650void *
711xmalloc (size_t size) 651xmalloc (size_t size)
712{ 652{
713 register POINTER_TYPE *val; 653 void *val;
714 654
715 MALLOC_BLOCK_INPUT; 655 MALLOC_BLOCK_INPUT;
716 val = (POINTER_TYPE *) malloc (size); 656 val = malloc (size);
717 MALLOC_UNBLOCK_INPUT; 657 MALLOC_UNBLOCK_INPUT;
718 658
719 if (!val && size) 659 if (!val && size)
720 memory_full (size); 660 memory_full (size);
661 MALLOC_PROBE (size);
721 return val; 662 return val;
722} 663}
723 664
665/* Like the above, but zeroes out the memory just allocated. */
666
667void *
668xzalloc (size_t size)
669{
670 void *val;
671
672 MALLOC_BLOCK_INPUT;
673 val = malloc (size);
674 MALLOC_UNBLOCK_INPUT;
675
676 if (!val && size)
677 memory_full (size);
678 memset (val, 0, size);
679 MALLOC_PROBE (size);
680 return val;
681}
724 682
725/* Like realloc but check for no memory and block interrupt input.. */ 683/* Like realloc but check for no memory and block interrupt input.. */
726 684
727POINTER_TYPE * 685void *
728xrealloc (POINTER_TYPE *block, size_t size) 686xrealloc (void *block, size_t size)
729{ 687{
730 register POINTER_TYPE *val; 688 void *val;
731 689
732 MALLOC_BLOCK_INPUT; 690 MALLOC_BLOCK_INPUT;
733 /* We must call malloc explicitly when BLOCK is 0, since some 691 /* We must call malloc explicitly when BLOCK is 0, since some
734 reallocs don't do this. */ 692 reallocs don't do this. */
735 if (! block) 693 if (! block)
736 val = (POINTER_TYPE *) malloc (size); 694 val = malloc (size);
737 else 695 else
738 val = (POINTER_TYPE *) realloc (block, size); 696 val = realloc (block, size);
739 MALLOC_UNBLOCK_INPUT; 697 MALLOC_UNBLOCK_INPUT;
740 698
741 if (!val && size) 699 if (!val && size)
742 memory_full (size); 700 memory_full (size);
701 MALLOC_PROBE (size);
743 return val; 702 return val;
744} 703}
745 704
@@ -747,7 +706,7 @@ xrealloc (POINTER_TYPE *block, size_t size)
747/* Like free but block interrupt input. */ 706/* Like free but block interrupt input. */
748 707
749void 708void
750xfree (POINTER_TYPE *block) 709xfree (void *block)
751{ 710{
752 if (!block) 711 if (!block)
753 return; 712 return;
@@ -755,8 +714,7 @@ xfree (POINTER_TYPE *block)
755 free (block); 714 free (block);
756 MALLOC_UNBLOCK_INPUT; 715 MALLOC_UNBLOCK_INPUT;
757 /* We don't call refill_memory_reserve here 716 /* We don't call refill_memory_reserve here
758 because that duplicates doing so in emacs_blocked_free 717 because in practice the call in r_alloc_free seems to suffice. */
759 and the criterion should go there. */
760} 718}
761 719
762 720
@@ -772,7 +730,7 @@ verify (INT_MAX <= PTRDIFF_MAX);
772void * 730void *
773xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size) 731xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size)
774{ 732{
775 xassert (0 <= nitems && 0 < item_size); 733 eassert (0 <= nitems && 0 < item_size);
776 if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems) 734 if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems)
777 memory_full (SIZE_MAX); 735 memory_full (SIZE_MAX);
778 return xmalloc (nitems * item_size); 736 return xmalloc (nitems * item_size);
@@ -785,7 +743,7 @@ xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size)
785void * 743void *
786xnrealloc (void *pa, ptrdiff_t nitems, ptrdiff_t item_size) 744xnrealloc (void *pa, ptrdiff_t nitems, ptrdiff_t item_size)
787{ 745{
788 xassert (0 <= nitems && 0 < item_size); 746 eassert (0 <= nitems && 0 < item_size);
789 if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems) 747 if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems)
790 memory_full (SIZE_MAX); 748 memory_full (SIZE_MAX);
791 return xrealloc (pa, nitems * item_size); 749 return xrealloc (pa, nitems * item_size);
@@ -835,7 +793,7 @@ xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
835 ptrdiff_t nitems_incr_max = n_max - n; 793 ptrdiff_t nitems_incr_max = n_max - n;
836 ptrdiff_t incr = max (nitems_incr_min, min (incr_estimate, nitems_incr_max)); 794 ptrdiff_t incr = max (nitems_incr_min, min (incr_estimate, nitems_incr_max));
837 795
838 xassert (0 < item_size && 0 < nitems_incr_min && 0 <= n && -1 <= nitems_max); 796 eassert (0 < item_size && 0 < nitems_incr_min && 0 <= n && -1 <= nitems_max);
839 if (! pa) 797 if (! pa)
840 *nitems = 0; 798 *nitems = 0;
841 if (nitems_incr_max < incr) 799 if (nitems_incr_max < incr)
@@ -853,7 +811,7 @@ char *
853xstrdup (const char *s) 811xstrdup (const char *s)
854{ 812{
855 size_t len = strlen (s) + 1; 813 size_t len = strlen (s) + 1;
856 char *p = (char *) xmalloc (len); 814 char *p = xmalloc (len);
857 memcpy (p, s, len); 815 memcpy (p, s, len);
858 return p; 816 return p;
859} 817}
@@ -873,16 +831,26 @@ safe_alloca_unwind (Lisp_Object arg)
873 return Qnil; 831 return Qnil;
874} 832}
875 833
834/* Return a newly allocated memory block of SIZE bytes, remembering
835 to free it when unwinding. */
836void *
837record_xmalloc (size_t size)
838{
839 void *p = xmalloc (size);
840 record_unwind_protect (safe_alloca_unwind, make_save_value (p, 0));
841 return p;
842}
843
876 844
877/* Like malloc but used for allocating Lisp data. NBYTES is the 845/* Like malloc but used for allocating Lisp data. NBYTES is the
878 number of bytes to allocate, TYPE describes the intended use of the 846 number of bytes to allocate, TYPE describes the intended use of the
879 allocated memory block (for strings, for conses, ...). */ 847 allocated memory block (for strings, for conses, ...). */
880 848
881#ifndef USE_LSB_TAG 849#if ! USE_LSB_TAG
882static void *lisp_malloc_loser; 850void *lisp_malloc_loser EXTERNALLY_VISIBLE;
883#endif 851#endif
884 852
885static POINTER_TYPE * 853static void *
886lisp_malloc (size_t nbytes, enum mem_type type) 854lisp_malloc (size_t nbytes, enum mem_type type)
887{ 855{
888 register void *val; 856 register void *val;
@@ -893,9 +861,9 @@ lisp_malloc (size_t nbytes, enum mem_type type)
893 allocated_mem_type = type; 861 allocated_mem_type = type;
894#endif 862#endif
895 863
896 val = (void *) malloc (nbytes); 864 val = malloc (nbytes);
897 865
898#ifndef USE_LSB_TAG 866#if ! USE_LSB_TAG
899 /* If the memory just allocated cannot be addressed thru a Lisp 867 /* If the memory just allocated cannot be addressed thru a Lisp
900 object's pointer, and it needs to be, 868 object's pointer, and it needs to be,
901 that's equivalent to running out of memory. */ 869 that's equivalent to running out of memory. */
@@ -920,6 +888,7 @@ lisp_malloc (size_t nbytes, enum mem_type type)
920 MALLOC_UNBLOCK_INPUT; 888 MALLOC_UNBLOCK_INPUT;
921 if (!val && nbytes) 889 if (!val && nbytes)
922 memory_full (nbytes); 890 memory_full (nbytes);
891 MALLOC_PROBE (nbytes);
923 return val; 892 return val;
924} 893}
925 894
@@ -927,7 +896,7 @@ lisp_malloc (size_t nbytes, enum mem_type type)
927 call to lisp_malloc. */ 896 call to lisp_malloc. */
928 897
929static void 898static void
930lisp_free (POINTER_TYPE *block) 899lisp_free (void *block)
931{ 900{
932 MALLOC_BLOCK_INPUT; 901 MALLOC_BLOCK_INPUT;
933 free (block); 902 free (block);
@@ -937,13 +906,11 @@ lisp_free (POINTER_TYPE *block)
937 MALLOC_UNBLOCK_INPUT; 906 MALLOC_UNBLOCK_INPUT;
938} 907}
939 908
940/* Allocation of aligned blocks of memory to store Lisp data. */ 909/***** Allocation of aligned blocks of memory to store Lisp data. *****/
941/* The entry point is lisp_align_malloc which returns blocks of at most */ 910
942/* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */ 911/* The entry point is lisp_align_malloc which returns blocks of at most
912 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
943 913
944/* Use posix_memalloc if the system has it and we're using the system's
945 malloc (because our gmalloc.c routines don't have posix_memalign although
946 its memalloc could be used). */
947#if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC) 914#if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
948#define USE_POSIX_MEMALIGN 1 915#define USE_POSIX_MEMALIGN 1
949#endif 916#endif
@@ -1000,7 +967,7 @@ struct ablocks
1000 struct ablock blocks[ABLOCKS_SIZE]; 967 struct ablock blocks[ABLOCKS_SIZE];
1001}; 968};
1002 969
1003/* Size of the block requested from malloc or memalign. */ 970/* Size of the block requested from malloc or posix_memalign. */
1004#define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING) 971#define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
1005 972
1006#define ABLOCK_ABASE(block) \ 973#define ABLOCK_ABASE(block) \
@@ -1025,7 +992,7 @@ static struct ablock *free_ablock;
1025/* Allocate an aligned block of nbytes. 992/* Allocate an aligned block of nbytes.
1026 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be 993 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
1027 smaller or equal to BLOCK_BYTES. */ 994 smaller or equal to BLOCK_BYTES. */
1028static POINTER_TYPE * 995static void *
1029lisp_align_malloc (size_t nbytes, enum mem_type type) 996lisp_align_malloc (size_t nbytes, enum mem_type type)
1030{ 997{
1031 void *base, *val; 998 void *base, *val;
@@ -1078,7 +1045,7 @@ lisp_align_malloc (size_t nbytes, enum mem_type type)
1078 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); 1045 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
1079#endif 1046#endif
1080 1047
1081#ifndef USE_LSB_TAG 1048#if ! USE_LSB_TAG
1082 /* If the memory just allocated cannot be addressed thru a Lisp 1049 /* If the memory just allocated cannot be addressed thru a Lisp
1083 object's pointer, and it needs to be, that's equivalent to 1050 object's pointer, and it needs to be, that's equivalent to
1084 running out of memory. */ 1051 running out of memory. */
@@ -1098,7 +1065,7 @@ lisp_align_malloc (size_t nbytes, enum mem_type type)
1098#endif 1065#endif
1099 1066
1100 /* Initialize the blocks and put them on the free list. 1067 /* Initialize the blocks and put them on the free list.
1101 Is `base' was not properly aligned, we can't use the last block. */ 1068 If `base' was not properly aligned, we can't use the last block. */
1102 for (i = 0; i < (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1); i++) 1069 for (i = 0; i < (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1); i++)
1103 { 1070 {
1104 abase->blocks[i].abase = abase; 1071 abase->blocks[i].abase = abase;
@@ -1127,12 +1094,14 @@ lisp_align_malloc (size_t nbytes, enum mem_type type)
1127 1094
1128 MALLOC_UNBLOCK_INPUT; 1095 MALLOC_UNBLOCK_INPUT;
1129 1096
1097 MALLOC_PROBE (nbytes);
1098
1130 eassert (0 == ((uintptr_t) val) % BLOCK_ALIGN); 1099 eassert (0 == ((uintptr_t) val) % BLOCK_ALIGN);
1131 return val; 1100 return val;
1132} 1101}
1133 1102
1134static void 1103static void
1135lisp_align_free (POINTER_TYPE *block) 1104lisp_align_free (void *block)
1136{ 1105{
1137 struct ablock *ablock = block; 1106 struct ablock *ablock = block;
1138 struct ablocks *abase = ABLOCK_ABASE (ablock); 1107 struct ablocks *abase = ABLOCK_ABASE (ablock);
@@ -1145,8 +1114,8 @@ lisp_align_free (POINTER_TYPE *block)
1145 ablock->x.next_free = free_ablock; 1114 ablock->x.next_free = free_ablock;
1146 free_ablock = ablock; 1115 free_ablock = ablock;
1147 /* Update busy count. */ 1116 /* Update busy count. */
1148 ABLOCKS_BUSY (abase) = 1117 ABLOCKS_BUSY (abase)
1149 (struct ablocks *) (-2 + (intptr_t) ABLOCKS_BUSY (abase)); 1118 = (struct ablocks *) (-2 + (intptr_t) ABLOCKS_BUSY (abase));
1150 1119
1151 if (2 > (intptr_t) ABLOCKS_BUSY (abase)) 1120 if (2 > (intptr_t) ABLOCKS_BUSY (abase))
1152 { /* All the blocks are free. */ 1121 { /* All the blocks are free. */
@@ -1174,267 +1143,6 @@ lisp_align_free (POINTER_TYPE *block)
1174 MALLOC_UNBLOCK_INPUT; 1143 MALLOC_UNBLOCK_INPUT;
1175} 1144}
1176 1145
1177/* Return a new buffer structure allocated from the heap with
1178 a call to lisp_malloc. */
1179
1180struct buffer *
1181allocate_buffer (void)
1182{
1183 struct buffer *b
1184 = (struct buffer *) lisp_malloc (sizeof (struct buffer),
1185 MEM_TYPE_BUFFER);
1186 XSETPVECTYPESIZE (b, PVEC_BUFFER,
1187 ((sizeof (struct buffer) + sizeof (EMACS_INT) - 1)
1188 / sizeof (EMACS_INT)));
1189 return b;
1190}
1191
1192
1193#ifndef SYSTEM_MALLOC
1194
1195/* Arranging to disable input signals while we're in malloc.
1196
1197 This only works with GNU malloc. To help out systems which can't
1198 use GNU malloc, all the calls to malloc, realloc, and free
1199 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
1200 pair; unfortunately, we have no idea what C library functions
1201 might call malloc, so we can't really protect them unless you're
1202 using GNU malloc. Fortunately, most of the major operating systems
1203 can use GNU malloc. */
1204
1205#ifndef SYNC_INPUT
1206/* When using SYNC_INPUT, we don't call malloc from a signal handler, so
1207 there's no need to block input around malloc. */
1208
1209#ifndef DOUG_LEA_MALLOC
1210extern void * (*__malloc_hook) (size_t, const void *);
1211extern void * (*__realloc_hook) (void *, size_t, const void *);
1212extern void (*__free_hook) (void *, const void *);
1213/* Else declared in malloc.h, perhaps with an extra arg. */
1214#endif /* DOUG_LEA_MALLOC */
1215static void * (*old_malloc_hook) (size_t, const void *);
1216static void * (*old_realloc_hook) (void *, size_t, const void*);
1217static void (*old_free_hook) (void*, const void*);
1218
1219#ifdef DOUG_LEA_MALLOC
1220# define BYTES_USED (mallinfo ().uordblks)
1221#else
1222# define BYTES_USED _bytes_used
1223#endif
1224
1225static size_t bytes_used_when_reconsidered;
1226
1227/* Value of _bytes_used, when spare_memory was freed. */
1228
1229static size_t bytes_used_when_full;
1230
1231/* This function is used as the hook for free to call. */
1232
1233static void
1234emacs_blocked_free (void *ptr, const void *ptr2)
1235{
1236 BLOCK_INPUT_ALLOC;
1237
1238#ifdef GC_MALLOC_CHECK
1239 if (ptr)
1240 {
1241 struct mem_node *m;
1242
1243 m = mem_find (ptr);
1244 if (m == MEM_NIL || m->start != ptr)
1245 {
1246 fprintf (stderr,
1247 "Freeing `%p' which wasn't allocated with malloc\n", ptr);
1248 abort ();
1249 }
1250 else
1251 {
1252 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
1253 mem_delete (m);
1254 }
1255 }
1256#endif /* GC_MALLOC_CHECK */
1257
1258 __free_hook = old_free_hook;
1259 free (ptr);
1260
1261 /* If we released our reserve (due to running out of memory),
1262 and we have a fair amount free once again,
1263 try to set aside another reserve in case we run out once more. */
1264 if (! NILP (Vmemory_full)
1265 /* Verify there is enough space that even with the malloc
1266 hysteresis this call won't run out again.
1267 The code here is correct as long as SPARE_MEMORY
1268 is substantially larger than the block size malloc uses. */
1269 && (bytes_used_when_full
1270 > ((bytes_used_when_reconsidered = BYTES_USED)
1271 + max (malloc_hysteresis, 4) * SPARE_MEMORY)))
1272 refill_memory_reserve ();
1273
1274 __free_hook = emacs_blocked_free;
1275 UNBLOCK_INPUT_ALLOC;
1276}
1277
1278
1279/* This function is the malloc hook that Emacs uses. */
1280
1281static void *
1282emacs_blocked_malloc (size_t size, const void *ptr)
1283{
1284 void *value;
1285
1286 BLOCK_INPUT_ALLOC;
1287 __malloc_hook = old_malloc_hook;
1288#ifdef DOUG_LEA_MALLOC
1289 /* Segfaults on my system. --lorentey */
1290 /* mallopt (M_TOP_PAD, malloc_hysteresis * 4096); */
1291#else
1292 __malloc_extra_blocks = malloc_hysteresis;
1293#endif
1294
1295 value = (void *) malloc (size);
1296
1297#ifdef GC_MALLOC_CHECK
1298 {
1299 struct mem_node *m = mem_find (value);
1300 if (m != MEM_NIL)
1301 {
1302 fprintf (stderr, "Malloc returned %p which is already in use\n",
1303 value);
1304 fprintf (stderr, "Region in use is %p...%p, %u bytes, type %d\n",
1305 m->start, m->end, (char *) m->end - (char *) m->start,
1306 m->type);
1307 abort ();
1308 }
1309
1310 if (!dont_register_blocks)
1311 {
1312 mem_insert (value, (char *) value + max (1, size), allocated_mem_type);
1313 allocated_mem_type = MEM_TYPE_NON_LISP;
1314 }
1315 }
1316#endif /* GC_MALLOC_CHECK */
1317
1318 __malloc_hook = emacs_blocked_malloc;
1319 UNBLOCK_INPUT_ALLOC;
1320
1321 /* fprintf (stderr, "%p malloc\n", value); */
1322 return value;
1323}
1324
1325
1326/* This function is the realloc hook that Emacs uses. */
1327
1328static void *
1329emacs_blocked_realloc (void *ptr, size_t size, const void *ptr2)
1330{
1331 void *value;
1332
1333 BLOCK_INPUT_ALLOC;
1334 __realloc_hook = old_realloc_hook;
1335
1336#ifdef GC_MALLOC_CHECK
1337 if (ptr)
1338 {
1339 struct mem_node *m = mem_find (ptr);
1340 if (m == MEM_NIL || m->start != ptr)
1341 {
1342 fprintf (stderr,
1343 "Realloc of %p which wasn't allocated with malloc\n",
1344 ptr);
1345 abort ();
1346 }
1347
1348 mem_delete (m);
1349 }
1350
1351 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1352
1353 /* Prevent malloc from registering blocks. */
1354 dont_register_blocks = 1;
1355#endif /* GC_MALLOC_CHECK */
1356
1357 value = (void *) realloc (ptr, size);
1358
1359#ifdef GC_MALLOC_CHECK
1360 dont_register_blocks = 0;
1361
1362 {
1363 struct mem_node *m = mem_find (value);
1364 if (m != MEM_NIL)
1365 {
1366 fprintf (stderr, "Realloc returns memory that is already in use\n");
1367 abort ();
1368 }
1369
1370 /* Can't handle zero size regions in the red-black tree. */
1371 mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP);
1372 }
1373
1374 /* fprintf (stderr, "%p <- realloc\n", value); */
1375#endif /* GC_MALLOC_CHECK */
1376
1377 __realloc_hook = emacs_blocked_realloc;
1378 UNBLOCK_INPUT_ALLOC;
1379
1380 return value;
1381}
1382
1383
1384#ifdef HAVE_PTHREAD
1385/* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
1386 normal malloc. Some thread implementations need this as they call
1387 malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
1388 calls malloc because it is the first call, and we have an endless loop. */
1389
1390void
1391reset_malloc_hooks (void)
1392{
1393 __free_hook = old_free_hook;
1394 __malloc_hook = old_malloc_hook;
1395 __realloc_hook = old_realloc_hook;
1396}
1397#endif /* HAVE_PTHREAD */
1398
1399
1400/* Called from main to set up malloc to use our hooks. */
1401
1402void
1403uninterrupt_malloc (void)
1404{
1405#ifdef HAVE_PTHREAD
1406#ifdef DOUG_LEA_MALLOC
1407 pthread_mutexattr_t attr;
1408
1409 /* GLIBC has a faster way to do this, but let's keep it portable.
1410 This is according to the Single UNIX Specification. */
1411 pthread_mutexattr_init (&attr);
1412 pthread_mutexattr_settype (&attr, PTHREAD_MUTEX_RECURSIVE);
1413 pthread_mutex_init (&alloc_mutex, &attr);
1414#else /* !DOUG_LEA_MALLOC */
1415 /* Some systems such as Solaris 2.6 don't have a recursive mutex,
1416 and the bundled gmalloc.c doesn't require it. */
1417 pthread_mutex_init (&alloc_mutex, NULL);
1418#endif /* !DOUG_LEA_MALLOC */
1419#endif /* HAVE_PTHREAD */
1420
1421 if (__free_hook != emacs_blocked_free)
1422 old_free_hook = __free_hook;
1423 __free_hook = emacs_blocked_free;
1424
1425 if (__malloc_hook != emacs_blocked_malloc)
1426 old_malloc_hook = __malloc_hook;
1427 __malloc_hook = emacs_blocked_malloc;
1428
1429 if (__realloc_hook != emacs_blocked_realloc)
1430 old_realloc_hook = __realloc_hook;
1431 __realloc_hook = emacs_blocked_realloc;
1432}
1433
1434#endif /* not SYNC_INPUT */
1435#endif /* not SYSTEM_MALLOC */
1436
1437
1438 1146
1439/*********************************************************************** 1147/***********************************************************************
1440 Interval Allocation 1148 Interval Allocation
@@ -1464,7 +1172,7 @@ static struct interval_block *interval_block;
1464/* Index in interval_block above of the next unused interval 1172/* Index in interval_block above of the next unused interval
1465 structure. */ 1173 structure. */
1466 1174
1467static int interval_block_index; 1175static int interval_block_index = INTERVAL_BLOCK_SIZE;
1468 1176
1469/* Number of free and live intervals. */ 1177/* Number of free and live intervals. */
1470 1178
@@ -1474,18 +1182,6 @@ static EMACS_INT total_free_intervals, total_intervals;
1474 1182
1475static INTERVAL interval_free_list; 1183static INTERVAL interval_free_list;
1476 1184
1477
1478/* Initialize interval allocation. */
1479
1480static void
1481init_intervals (void)
1482{
1483 interval_block = NULL;
1484 interval_block_index = INTERVAL_BLOCK_SIZE;
1485 interval_free_list = 0;
1486}
1487
1488
1489/* Return a new interval. */ 1185/* Return a new interval. */
1490 1186
1491INTERVAL 1187INTERVAL
@@ -1493,8 +1189,6 @@ make_interval (void)
1493{ 1189{
1494 INTERVAL val; 1190 INTERVAL val;
1495 1191
1496 /* eassert (!handling_signal); */
1497
1498 MALLOC_BLOCK_INPUT; 1192 MALLOC_BLOCK_INPUT;
1499 1193
1500 if (interval_free_list) 1194 if (interval_free_list)
@@ -1506,14 +1200,13 @@ make_interval (void)
1506 { 1200 {
1507 if (interval_block_index == INTERVAL_BLOCK_SIZE) 1201 if (interval_block_index == INTERVAL_BLOCK_SIZE)
1508 { 1202 {
1509 register struct interval_block *newi; 1203 struct interval_block *newi
1510 1204 = lisp_malloc (sizeof *newi, MEM_TYPE_NON_LISP);
1511 newi = (struct interval_block *) lisp_malloc (sizeof *newi,
1512 MEM_TYPE_NON_LISP);
1513 1205
1514 newi->next = interval_block; 1206 newi->next = interval_block;
1515 interval_block = newi; 1207 interval_block = newi;
1516 interval_block_index = 0; 1208 interval_block_index = 0;
1209 total_free_intervals += INTERVAL_BLOCK_SIZE;
1517 } 1210 }
1518 val = &interval_block->intervals[interval_block_index++]; 1211 val = &interval_block->intervals[interval_block_index++];
1519 } 1212 }
@@ -1522,66 +1215,33 @@ make_interval (void)
1522 1215
1523 consing_since_gc += sizeof (struct interval); 1216 consing_since_gc += sizeof (struct interval);
1524 intervals_consed++; 1217 intervals_consed++;
1218 total_free_intervals--;
1525 RESET_INTERVAL (val); 1219 RESET_INTERVAL (val);
1526 val->gcmarkbit = 0; 1220 val->gcmarkbit = 0;
1527 return val; 1221 return val;
1528} 1222}
1529 1223
1530 1224
1531/* Mark Lisp objects in interval I. */ 1225/* Mark Lisp objects in interval I. */
1532 1226
1533static void 1227static void
1534mark_interval (register INTERVAL i, Lisp_Object dummy) 1228mark_interval (register INTERVAL i, Lisp_Object dummy)
1535{ 1229{
1536 eassert (!i->gcmarkbit); /* Intervals are never shared. */ 1230 /* Intervals should never be shared. So, if extra internal checking is
1231 enabled, GC aborts if it seems to have visited an interval twice. */
1232 eassert (!i->gcmarkbit);
1537 i->gcmarkbit = 1; 1233 i->gcmarkbit = 1;
1538 mark_object (i->plist); 1234 mark_object (i->plist);
1539} 1235}
1540 1236
1541
1542/* Mark the interval tree rooted in TREE. Don't call this directly;
1543 use the macro MARK_INTERVAL_TREE instead. */
1544
1545static void
1546mark_interval_tree (register INTERVAL tree)
1547{
1548 /* No need to test if this tree has been marked already; this
1549 function is always called through the MARK_INTERVAL_TREE macro,
1550 which takes care of that. */
1551
1552 traverse_intervals_noorder (tree, mark_interval, Qnil);
1553}
1554
1555
1556/* Mark the interval tree rooted in I. */ 1237/* Mark the interval tree rooted in I. */
1557 1238
1558#define MARK_INTERVAL_TREE(i) \ 1239#define MARK_INTERVAL_TREE(i) \
1559 do { \ 1240 do { \
1560 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \ 1241 if (i && !i->gcmarkbit) \
1561 mark_interval_tree (i); \ 1242 traverse_intervals_noorder (i, mark_interval, Qnil); \
1562 } while (0) 1243 } while (0)
1563 1244
1564
1565#define UNMARK_BALANCE_INTERVALS(i) \
1566 do { \
1567 if (! NULL_INTERVAL_P (i)) \
1568 (i) = balance_intervals (i); \
1569 } while (0)
1570
1571
1572/* Number support. If USE_LISP_UNION_TYPE is in effect, we
1573 can't create number objects in macros. */
1574#ifndef make_number
1575Lisp_Object
1576make_number (EMACS_INT n)
1577{
1578 Lisp_Object obj;
1579 obj.s.val = n;
1580 obj.s.type = Lisp_Int;
1581 return obj;
1582}
1583#endif
1584
1585/*********************************************************************** 1245/***********************************************************************
1586 String Allocation 1246 String Allocation
1587 ***********************************************************************/ 1247 ***********************************************************************/
@@ -1634,7 +1294,7 @@ struct sdata
1634 1294
1635#ifdef GC_CHECK_STRING_BYTES 1295#ifdef GC_CHECK_STRING_BYTES
1636 1296
1637 EMACS_INT nbytes; 1297 ptrdiff_t nbytes;
1638 unsigned char data[1]; 1298 unsigned char data[1];
1639 1299
1640#define SDATA_NBYTES(S) (S)->nbytes 1300#define SDATA_NBYTES(S) (S)->nbytes
@@ -1649,7 +1309,7 @@ struct sdata
1649 unsigned char data[1]; 1309 unsigned char data[1];
1650 1310
1651 /* When STRING is null. */ 1311 /* When STRING is null. */
1652 EMACS_INT nbytes; 1312 ptrdiff_t nbytes;
1653 } u; 1313 } u;
1654 1314
1655#define SDATA_NBYTES(S) (S)->u.nbytes 1315#define SDATA_NBYTES(S) (S)->u.nbytes
@@ -1720,7 +1380,7 @@ static EMACS_INT total_strings, total_free_strings;
1720 1380
1721/* Number of bytes used by live strings. */ 1381/* Number of bytes used by live strings. */
1722 1382
1723static EMACS_INT total_string_size; 1383static EMACS_INT total_string_bytes;
1724 1384
1725/* Given a pointer to a Lisp_String S which is on the free-list 1385/* Given a pointer to a Lisp_String S which is on the free-list
1726 string_free_list, return a pointer to its successor in the 1386 string_free_list, return a pointer to its successor in the
@@ -1759,24 +1419,24 @@ static char const string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
1759#define SDATA_SIZE(NBYTES) \ 1419#define SDATA_SIZE(NBYTES) \
1760 ((SDATA_DATA_OFFSET \ 1420 ((SDATA_DATA_OFFSET \
1761 + (NBYTES) + 1 \ 1421 + (NBYTES) + 1 \
1762 + sizeof (EMACS_INT) - 1) \ 1422 + sizeof (ptrdiff_t) - 1) \
1763 & ~(sizeof (EMACS_INT) - 1)) 1423 & ~(sizeof (ptrdiff_t) - 1))
1764 1424
1765#else /* not GC_CHECK_STRING_BYTES */ 1425#else /* not GC_CHECK_STRING_BYTES */
1766 1426
1767/* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is 1427/* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1768 less than the size of that member. The 'max' is not needed when 1428 less than the size of that member. The 'max' is not needed when
1769 SDATA_DATA_OFFSET is a multiple of sizeof (EMACS_INT), because then the 1429 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1770 alignment code reserves enough space. */ 1430 alignment code reserves enough space. */
1771 1431
1772#define SDATA_SIZE(NBYTES) \ 1432#define SDATA_SIZE(NBYTES) \
1773 ((SDATA_DATA_OFFSET \ 1433 ((SDATA_DATA_OFFSET \
1774 + (SDATA_DATA_OFFSET % sizeof (EMACS_INT) == 0 \ 1434 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1775 ? NBYTES \ 1435 ? NBYTES \
1776 : max (NBYTES, sizeof (EMACS_INT) - 1)) \ 1436 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1777 + 1 \ 1437 + 1 \
1778 + sizeof (EMACS_INT) - 1) \ 1438 + sizeof (ptrdiff_t) - 1) \
1779 & ~(sizeof (EMACS_INT) - 1)) 1439 & ~(sizeof (ptrdiff_t) - 1))
1780 1440
1781#endif /* not GC_CHECK_STRING_BYTES */ 1441#endif /* not GC_CHECK_STRING_BYTES */
1782 1442
@@ -1789,23 +1449,19 @@ static char const string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
1789 STRING_BYTES_BOUND, nor can it be so long that the size_t 1449 STRING_BYTES_BOUND, nor can it be so long that the size_t
1790 arithmetic in allocate_string_data would overflow while it is 1450 arithmetic in allocate_string_data would overflow while it is
1791 calculating a value to be passed to malloc. */ 1451 calculating a value to be passed to malloc. */
1792#define STRING_BYTES_MAX \ 1452static ptrdiff_t const STRING_BYTES_MAX =
1793 min (STRING_BYTES_BOUND, \ 1453 min (STRING_BYTES_BOUND,
1794 ((SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD \ 1454 ((SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD
1795 - GC_STRING_EXTRA \ 1455 - GC_STRING_EXTRA
1796 - offsetof (struct sblock, first_data) \ 1456 - offsetof (struct sblock, first_data)
1797 - SDATA_DATA_OFFSET) \ 1457 - SDATA_DATA_OFFSET)
1798 & ~(sizeof (EMACS_INT) - 1))) 1458 & ~(sizeof (EMACS_INT) - 1)));
1799 1459
1800/* Initialize string allocation. Called from init_alloc_once. */ 1460/* Initialize string allocation. Called from init_alloc_once. */
1801 1461
1802static void 1462static void
1803init_strings (void) 1463init_strings (void)
1804{ 1464{
1805 total_strings = total_free_strings = total_string_size = 0;
1806 oldest_sblock = current_sblock = large_sblocks = NULL;
1807 string_blocks = NULL;
1808 string_free_list = NULL;
1809 empty_unibyte_string = make_pure_string ("", 0, 0, 0); 1465 empty_unibyte_string = make_pure_string ("", 0, 0, 0);
1810 empty_multibyte_string = make_pure_string ("", 0, 0, 1); 1466 empty_multibyte_string = make_pure_string ("", 0, 0, 1);
1811} 1467}
@@ -1815,21 +1471,19 @@ init_strings (void)
1815 1471
1816static int check_string_bytes_count; 1472static int check_string_bytes_count;
1817 1473
1818#define CHECK_STRING_BYTES(S) STRING_BYTES (S) 1474/* Like STRING_BYTES, but with debugging check. Can be
1819 1475 called during GC, so pay attention to the mark bit. */
1820
1821/* Like GC_STRING_BYTES, but with debugging check. */
1822 1476
1823EMACS_INT 1477ptrdiff_t
1824string_bytes (struct Lisp_String *s) 1478string_bytes (struct Lisp_String *s)
1825{ 1479{
1826 EMACS_INT nbytes = 1480 ptrdiff_t nbytes =
1827 (s->size_byte < 0 ? s->size & ~ARRAY_MARK_FLAG : s->size_byte); 1481 (s->size_byte < 0 ? s->size & ~ARRAY_MARK_FLAG : s->size_byte);
1828 1482
1829 if (!PURE_POINTER_P (s) 1483 if (!PURE_POINTER_P (s)
1830 && s->data 1484 && s->data
1831 && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s))) 1485 && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
1832 abort (); 1486 emacs_abort ();
1833 return nbytes; 1487 return nbytes;
1834} 1488}
1835 1489
@@ -1846,30 +1500,23 @@ check_sblock (struct sblock *b)
1846 { 1500 {
1847 /* Compute the next FROM here because copying below may 1501 /* Compute the next FROM here because copying below may
1848 overwrite data we need to compute it. */ 1502 overwrite data we need to compute it. */
1849 EMACS_INT nbytes; 1503 ptrdiff_t nbytes;
1850 1504
1851 /* Check that the string size recorded in the string is the 1505 /* Check that the string size recorded in the string is the
1852 same as the one recorded in the sdata structure. */ 1506 same as the one recorded in the sdata structure. */
1853 if (from->string) 1507 nbytes = SDATA_SIZE (from->string ? string_bytes (from->string)
1854 CHECK_STRING_BYTES (from->string); 1508 : SDATA_NBYTES (from));
1855
1856 if (from->string)
1857 nbytes = GC_STRING_BYTES (from->string);
1858 else
1859 nbytes = SDATA_NBYTES (from);
1860
1861 nbytes = SDATA_SIZE (nbytes);
1862 from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA); 1509 from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
1863 } 1510 }
1864} 1511}
1865 1512
1866 1513
1867/* Check validity of Lisp strings' string_bytes member. ALL_P 1514/* Check validity of Lisp strings' string_bytes member. ALL_P
1868 non-zero means check all strings, otherwise check only most 1515 means check all strings, otherwise check only most
1869 recently allocated strings. Used for hunting a bug. */ 1516 recently allocated strings. Used for hunting a bug. */
1870 1517
1871static void 1518static void
1872check_string_bytes (int all_p) 1519check_string_bytes (bool all_p)
1873{ 1520{
1874 if (all_p) 1521 if (all_p)
1875 { 1522 {
@@ -1879,16 +1526,20 @@ check_string_bytes (int all_p)
1879 { 1526 {
1880 struct Lisp_String *s = b->first_data.string; 1527 struct Lisp_String *s = b->first_data.string;
1881 if (s) 1528 if (s)
1882 CHECK_STRING_BYTES (s); 1529 string_bytes (s);
1883 } 1530 }
1884 1531
1885 for (b = oldest_sblock; b; b = b->next) 1532 for (b = oldest_sblock; b; b = b->next)
1886 check_sblock (b); 1533 check_sblock (b);
1887 } 1534 }
1888 else 1535 else if (current_sblock)
1889 check_sblock (current_sblock); 1536 check_sblock (current_sblock);
1890} 1537}
1891 1538
1539#else /* not GC_CHECK_STRING_BYTES */
1540
1541#define check_string_bytes(all) ((void) 0)
1542
1892#endif /* GC_CHECK_STRING_BYTES */ 1543#endif /* GC_CHECK_STRING_BYTES */
1893 1544
1894#ifdef GC_CHECK_STRING_FREE_LIST 1545#ifdef GC_CHECK_STRING_FREE_LIST
@@ -1906,7 +1557,7 @@ check_string_free_list (void)
1906 while (s != NULL) 1557 while (s != NULL)
1907 { 1558 {
1908 if ((uintptr_t) s < 1024) 1559 if ((uintptr_t) s < 1024)
1909 abort (); 1560 emacs_abort ();
1910 s = NEXT_FREE_LISP_STRING (s); 1561 s = NEXT_FREE_LISP_STRING (s);
1911 } 1562 }
1912} 1563}
@@ -1921,25 +1572,23 @@ allocate_string (void)
1921{ 1572{
1922 struct Lisp_String *s; 1573 struct Lisp_String *s;
1923 1574
1924 /* eassert (!handling_signal); */
1925
1926 MALLOC_BLOCK_INPUT; 1575 MALLOC_BLOCK_INPUT;
1927 1576
1928 /* If the free-list is empty, allocate a new string_block, and 1577 /* If the free-list is empty, allocate a new string_block, and
1929 add all the Lisp_Strings in it to the free-list. */ 1578 add all the Lisp_Strings in it to the free-list. */
1930 if (string_free_list == NULL) 1579 if (string_free_list == NULL)
1931 { 1580 {
1932 struct string_block *b; 1581 struct string_block *b = lisp_malloc (sizeof *b, MEM_TYPE_STRING);
1933 int i; 1582 int i;
1934 1583
1935 b = (struct string_block *) lisp_malloc (sizeof *b, MEM_TYPE_STRING);
1936 memset (b, 0, sizeof *b);
1937 b->next = string_blocks; 1584 b->next = string_blocks;
1938 string_blocks = b; 1585 string_blocks = b;
1939 1586
1940 for (i = STRING_BLOCK_SIZE - 1; i >= 0; --i) 1587 for (i = STRING_BLOCK_SIZE - 1; i >= 0; --i)
1941 { 1588 {
1942 s = b->strings + i; 1589 s = b->strings + i;
1590 /* Every string on a free list should have NULL data pointer. */
1591 s->data = NULL;
1943 NEXT_FREE_LISP_STRING (s) = string_free_list; 1592 NEXT_FREE_LISP_STRING (s) = string_free_list;
1944 string_free_list = s; 1593 string_free_list = s;
1945 } 1594 }
@@ -1955,9 +1604,6 @@ allocate_string (void)
1955 1604
1956 MALLOC_UNBLOCK_INPUT; 1605 MALLOC_UNBLOCK_INPUT;
1957 1606
1958 /* Probably not strictly necessary, but play it safe. */
1959 memset (s, 0, sizeof *s);
1960
1961 --total_free_strings; 1607 --total_free_strings;
1962 ++total_strings; 1608 ++total_strings;
1963 ++strings_consed; 1609 ++strings_consed;
@@ -1992,7 +1638,7 @@ allocate_string_data (struct Lisp_String *s,
1992{ 1638{
1993 struct sdata *data, *old_data; 1639 struct sdata *data, *old_data;
1994 struct sblock *b; 1640 struct sblock *b;
1995 EMACS_INT needed, old_nbytes; 1641 ptrdiff_t needed, old_nbytes;
1996 1642
1997 if (STRING_BYTES_MAX < nbytes) 1643 if (STRING_BYTES_MAX < nbytes)
1998 string_overflow (); 1644 string_overflow ();
@@ -2000,8 +1646,13 @@ allocate_string_data (struct Lisp_String *s,
2000 /* Determine the number of bytes needed to store NBYTES bytes 1646 /* Determine the number of bytes needed to store NBYTES bytes
2001 of string data. */ 1647 of string data. */
2002 needed = SDATA_SIZE (nbytes); 1648 needed = SDATA_SIZE (nbytes);
2003 old_data = s->data ? SDATA_OF_STRING (s) : NULL; 1649 if (s->data)
2004 old_nbytes = GC_STRING_BYTES (s); 1650 {
1651 old_data = SDATA_OF_STRING (s);
1652 old_nbytes = STRING_BYTES (s);
1653 }
1654 else
1655 old_data = NULL;
2005 1656
2006 MALLOC_BLOCK_INPUT; 1657 MALLOC_BLOCK_INPUT;
2007 1658
@@ -2022,7 +1673,7 @@ allocate_string_data (struct Lisp_String *s,
2022 mallopt (M_MMAP_MAX, 0); 1673 mallopt (M_MMAP_MAX, 0);
2023#endif 1674#endif
2024 1675
2025 b = (struct sblock *) lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP); 1676 b = lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP);
2026 1677
2027#ifdef DOUG_LEA_MALLOC 1678#ifdef DOUG_LEA_MALLOC
2028 /* Back to a reasonable maximum of mmap'ed areas. */ 1679 /* Back to a reasonable maximum of mmap'ed areas. */
@@ -2040,7 +1691,7 @@ allocate_string_data (struct Lisp_String *s,
2040 < (needed + GC_STRING_EXTRA))) 1691 < (needed + GC_STRING_EXTRA)))
2041 { 1692 {
2042 /* Not enough room in the current sblock. */ 1693 /* Not enough room in the current sblock. */
2043 b = (struct sblock *) lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP); 1694 b = lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
2044 b->next_free = &b->first_data; 1695 b->next_free = &b->first_data;
2045 b->first_data.string = NULL; 1696 b->first_data.string = NULL;
2046 b->next = NULL; 1697 b->next = NULL;
@@ -2072,9 +1723,9 @@ allocate_string_data (struct Lisp_String *s,
2072 GC_STRING_OVERRUN_COOKIE_SIZE); 1723 GC_STRING_OVERRUN_COOKIE_SIZE);
2073#endif 1724#endif
2074 1725
2075 /* If S had already data assigned, mark that as free by setting its 1726 /* Note that Faset may call to this function when S has already data
2076 string back-pointer to null, and recording the size of the data 1727 assigned. In this case, mark data as free by setting it's string
2077 in it. */ 1728 back-pointer to null, and record the size of the data in it. */
2078 if (old_data) 1729 if (old_data)
2079 { 1730 {
2080 SDATA_NBYTES (old_data) = old_nbytes; 1731 SDATA_NBYTES (old_data) = old_nbytes;
@@ -2095,7 +1746,7 @@ sweep_strings (void)
2095 1746
2096 string_free_list = NULL; 1747 string_free_list = NULL;
2097 total_strings = total_free_strings = 0; 1748 total_strings = total_free_strings = 0;
2098 total_string_size = 0; 1749 total_string_bytes = 0;
2099 1750
2100 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */ 1751 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2101 for (b = string_blocks; b; b = next) 1752 for (b = string_blocks; b; b = next)
@@ -2117,11 +1768,11 @@ sweep_strings (void)
2117 /* String is live; unmark it and its intervals. */ 1768 /* String is live; unmark it and its intervals. */
2118 UNMARK_STRING (s); 1769 UNMARK_STRING (s);
2119 1770
2120 if (!NULL_INTERVAL_P (s->intervals)) 1771 /* Do not use string_(set|get)_intervals here. */
2121 UNMARK_BALANCE_INTERVALS (s->intervals); 1772 s->intervals = balance_intervals (s->intervals);
2122 1773
2123 ++total_strings; 1774 ++total_strings;
2124 total_string_size += STRING_BYTES (s); 1775 total_string_bytes += STRING_BYTES (s);
2125 } 1776 }
2126 else 1777 else
2127 { 1778 {
@@ -2132,10 +1783,10 @@ sweep_strings (void)
2132 how large that is. Reset the sdata's string 1783 how large that is. Reset the sdata's string
2133 back-pointer so that we know it's free. */ 1784 back-pointer so that we know it's free. */
2134#ifdef GC_CHECK_STRING_BYTES 1785#ifdef GC_CHECK_STRING_BYTES
2135 if (GC_STRING_BYTES (s) != SDATA_NBYTES (data)) 1786 if (string_bytes (s) != SDATA_NBYTES (data))
2136 abort (); 1787 emacs_abort ();
2137#else 1788#else
2138 data->u.nbytes = GC_STRING_BYTES (s); 1789 data->u.nbytes = STRING_BYTES (s);
2139#endif 1790#endif
2140 data->string = NULL; 1791 data->string = NULL;
2141 1792
@@ -2231,29 +1882,24 @@ compact_small_strings (void)
2231 for (b = oldest_sblock; b; b = b->next) 1882 for (b = oldest_sblock; b; b = b->next)
2232 { 1883 {
2233 end = b->next_free; 1884 end = b->next_free;
2234 xassert ((char *) end <= (char *) b + SBLOCK_SIZE); 1885 eassert ((char *) end <= (char *) b + SBLOCK_SIZE);
2235 1886
2236 for (from = &b->first_data; from < end; from = from_end) 1887 for (from = &b->first_data; from < end; from = from_end)
2237 { 1888 {
2238 /* Compute the next FROM here because copying below may 1889 /* Compute the next FROM here because copying below may
2239 overwrite data we need to compute it. */ 1890 overwrite data we need to compute it. */
2240 EMACS_INT nbytes; 1891 ptrdiff_t nbytes;
1892 struct Lisp_String *s = from->string;
2241 1893
2242#ifdef GC_CHECK_STRING_BYTES 1894#ifdef GC_CHECK_STRING_BYTES
2243 /* Check that the string size recorded in the string is the 1895 /* Check that the string size recorded in the string is the
2244 same as the one recorded in the sdata structure. */ 1896 same as the one recorded in the sdata structure. */
2245 if (from->string 1897 if (s && string_bytes (s) != SDATA_NBYTES (from))
2246 && GC_STRING_BYTES (from->string) != SDATA_NBYTES (from)) 1898 emacs_abort ();
2247 abort ();
2248#endif /* GC_CHECK_STRING_BYTES */ 1899#endif /* GC_CHECK_STRING_BYTES */
2249 1900
2250 if (from->string) 1901 nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from);
2251 nbytes = GC_STRING_BYTES (from->string); 1902 eassert (nbytes <= LARGE_STRING_BYTES);
2252 else
2253 nbytes = SDATA_NBYTES (from);
2254
2255 if (nbytes > LARGE_STRING_BYTES)
2256 abort ();
2257 1903
2258 nbytes = SDATA_SIZE (nbytes); 1904 nbytes = SDATA_SIZE (nbytes);
2259 from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA); 1905 from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
@@ -2262,11 +1908,11 @@ compact_small_strings (void)
2262 if (memcmp (string_overrun_cookie, 1908 if (memcmp (string_overrun_cookie,
2263 (char *) from_end - GC_STRING_OVERRUN_COOKIE_SIZE, 1909 (char *) from_end - GC_STRING_OVERRUN_COOKIE_SIZE,
2264 GC_STRING_OVERRUN_COOKIE_SIZE)) 1910 GC_STRING_OVERRUN_COOKIE_SIZE))
2265 abort (); 1911 emacs_abort ();
2266#endif 1912#endif
2267 1913
2268 /* FROM->string non-null means it's alive. Copy its data. */ 1914 /* Non-NULL S means it's alive. Copy its data. */
2269 if (from->string) 1915 if (s)
2270 { 1916 {
2271 /* If TB is full, proceed with the next sblock. */ 1917 /* If TB is full, proceed with the next sblock. */
2272 to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA); 1918 to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
@@ -2282,7 +1928,7 @@ compact_small_strings (void)
2282 /* Copy, and update the string's `data' pointer. */ 1928 /* Copy, and update the string's `data' pointer. */
2283 if (from != to) 1929 if (from != to)
2284 { 1930 {
2285 xassert (tb != b || to < from); 1931 eassert (tb != b || to < from);
2286 memmove (to, from, nbytes + GC_STRING_EXTRA); 1932 memmove (to, from, nbytes + GC_STRING_EXTRA);
2287 to->string->data = SDATA_DATA (to); 1933 to->string->data = SDATA_DATA (to);
2288 } 1934 }
@@ -2367,34 +2013,35 @@ LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2367{ 2013{
2368 register Lisp_Object val; 2014 register Lisp_Object val;
2369 struct Lisp_Bool_Vector *p; 2015 struct Lisp_Bool_Vector *p;
2370 EMACS_INT length_in_chars, length_in_elts; 2016 ptrdiff_t length_in_chars;
2017 EMACS_INT length_in_elts;
2371 int bits_per_value; 2018 int bits_per_value;
2019 int extra_bool_elts = ((bool_header_size - header_size + word_size - 1)
2020 / word_size);
2372 2021
2373 CHECK_NATNUM (length); 2022 CHECK_NATNUM (length);
2374 2023
2375 bits_per_value = sizeof (EMACS_INT) * BOOL_VECTOR_BITS_PER_CHAR; 2024 bits_per_value = sizeof (EMACS_INT) * BOOL_VECTOR_BITS_PER_CHAR;
2376 2025
2377 length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value; 2026 length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
2378 length_in_chars = ((XFASTINT (length) + BOOL_VECTOR_BITS_PER_CHAR - 1)
2379 / BOOL_VECTOR_BITS_PER_CHAR);
2380 2027
2381 /* We must allocate one more elements than LENGTH_IN_ELTS for the 2028 val = Fmake_vector (make_number (length_in_elts + extra_bool_elts), Qnil);
2382 slot `size' of the struct Lisp_Bool_Vector. */
2383 val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
2384 2029
2385 /* No Lisp_Object to trace in there. */ 2030 /* No Lisp_Object to trace in there. */
2386 XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0); 2031 XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0, 0);
2387 2032
2388 p = XBOOL_VECTOR (val); 2033 p = XBOOL_VECTOR (val);
2389 p->size = XFASTINT (length); 2034 p->size = XFASTINT (length);
2390 2035
2036 length_in_chars = ((XFASTINT (length) + BOOL_VECTOR_BITS_PER_CHAR - 1)
2037 / BOOL_VECTOR_BITS_PER_CHAR);
2391 if (length_in_chars) 2038 if (length_in_chars)
2392 { 2039 {
2393 memset (p->data, ! NILP (init) ? -1 : 0, length_in_chars); 2040 memset (p->data, ! NILP (init) ? -1 : 0, length_in_chars);
2394 2041
2395 /* Clear any extraneous bits in the last byte. */ 2042 /* Clear any extraneous bits in the last byte. */
2396 p->data[length_in_chars - 1] 2043 p->data[length_in_chars - 1]
2397 &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1; 2044 &= (1 << ((XFASTINT (length) - 1) % BOOL_VECTOR_BITS_PER_CHAR + 1)) - 1;
2398 } 2045 }
2399 2046
2400 return val; 2047 return val;
@@ -2406,10 +2053,10 @@ LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2406 multibyte, depending on the contents. */ 2053 multibyte, depending on the contents. */
2407 2054
2408Lisp_Object 2055Lisp_Object
2409make_string (const char *contents, EMACS_INT nbytes) 2056make_string (const char *contents, ptrdiff_t nbytes)
2410{ 2057{
2411 register Lisp_Object val; 2058 register Lisp_Object val;
2412 EMACS_INT nchars, multibyte_nbytes; 2059 ptrdiff_t nchars, multibyte_nbytes;
2413 2060
2414 parse_str_as_multibyte ((const unsigned char *) contents, nbytes, 2061 parse_str_as_multibyte ((const unsigned char *) contents, nbytes,
2415 &nchars, &multibyte_nbytes); 2062 &nchars, &multibyte_nbytes);
@@ -2426,7 +2073,7 @@ make_string (const char *contents, EMACS_INT nbytes)
2426/* Make an unibyte string from LENGTH bytes at CONTENTS. */ 2073/* Make an unibyte string from LENGTH bytes at CONTENTS. */
2427 2074
2428Lisp_Object 2075Lisp_Object
2429make_unibyte_string (const char *contents, EMACS_INT length) 2076make_unibyte_string (const char *contents, ptrdiff_t length)
2430{ 2077{
2431 register Lisp_Object val; 2078 register Lisp_Object val;
2432 val = make_uninit_string (length); 2079 val = make_uninit_string (length);
@@ -2440,7 +2087,7 @@ make_unibyte_string (const char *contents, EMACS_INT length)
2440 2087
2441Lisp_Object 2088Lisp_Object
2442make_multibyte_string (const char *contents, 2089make_multibyte_string (const char *contents,
2443 EMACS_INT nchars, EMACS_INT nbytes) 2090 ptrdiff_t nchars, ptrdiff_t nbytes)
2444{ 2091{
2445 register Lisp_Object val; 2092 register Lisp_Object val;
2446 val = make_uninit_multibyte_string (nchars, nbytes); 2093 val = make_uninit_multibyte_string (nchars, nbytes);
@@ -2454,7 +2101,7 @@ make_multibyte_string (const char *contents,
2454 2101
2455Lisp_Object 2102Lisp_Object
2456make_string_from_bytes (const char *contents, 2103make_string_from_bytes (const char *contents,
2457 EMACS_INT nchars, EMACS_INT nbytes) 2104 ptrdiff_t nchars, ptrdiff_t nbytes)
2458{ 2105{
2459 register Lisp_Object val; 2106 register Lisp_Object val;
2460 val = make_uninit_multibyte_string (nchars, nbytes); 2107 val = make_uninit_multibyte_string (nchars, nbytes);
@@ -2472,9 +2119,9 @@ make_string_from_bytes (const char *contents,
2472 2119
2473Lisp_Object 2120Lisp_Object
2474make_specified_string (const char *contents, 2121make_specified_string (const char *contents,
2475 EMACS_INT nchars, EMACS_INT nbytes, int multibyte) 2122 ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte)
2476{ 2123{
2477 register Lisp_Object val; 2124 Lisp_Object val;
2478 2125
2479 if (nchars < 0) 2126 if (nchars < 0)
2480 { 2127 {
@@ -2492,16 +2139,6 @@ make_specified_string (const char *contents,
2492} 2139}
2493 2140
2494 2141
2495/* Make a string from the data at STR, treating it as multibyte if the
2496 data warrants. */
2497
2498Lisp_Object
2499build_string (const char *str)
2500{
2501 return make_string (str, strlen (str));
2502}
2503
2504
2505/* Return an unibyte Lisp_String set up to hold LENGTH characters 2142/* Return an unibyte Lisp_String set up to hold LENGTH characters
2506 occupying LENGTH bytes. */ 2143 occupying LENGTH bytes. */
2507 2144
@@ -2528,17 +2165,32 @@ make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes)
2528 struct Lisp_String *s; 2165 struct Lisp_String *s;
2529 2166
2530 if (nchars < 0) 2167 if (nchars < 0)
2531 abort (); 2168 emacs_abort ();
2532 if (!nbytes) 2169 if (!nbytes)
2533 return empty_multibyte_string; 2170 return empty_multibyte_string;
2534 2171
2535 s = allocate_string (); 2172 s = allocate_string ();
2173 s->intervals = NULL;
2536 allocate_string_data (s, nchars, nbytes); 2174 allocate_string_data (s, nchars, nbytes);
2537 XSETSTRING (string, s); 2175 XSETSTRING (string, s);
2538 string_chars_consed += nbytes; 2176 string_chars_consed += nbytes;
2539 return string; 2177 return string;
2540} 2178}
2541 2179
2180/* Print arguments to BUF according to a FORMAT, then return
2181 a Lisp_String initialized with the data from BUF. */
2182
2183Lisp_Object
2184make_formatted_string (char *buf, const char *format, ...)
2185{
2186 va_list ap;
2187 int length;
2188
2189 va_start (ap, format);
2190 length = vsprintf (buf, format, ap);
2191 va_end (ap);
2192 return make_string (buf, length);
2193}
2542 2194
2543 2195
2544/*********************************************************************** 2196/***********************************************************************
@@ -2598,24 +2250,12 @@ static struct float_block *float_block;
2598 2250
2599/* Index of first unused Lisp_Float in the current float_block. */ 2251/* Index of first unused Lisp_Float in the current float_block. */
2600 2252
2601static int float_block_index; 2253static int float_block_index = FLOAT_BLOCK_SIZE;
2602 2254
2603/* Free-list of Lisp_Floats. */ 2255/* Free-list of Lisp_Floats. */
2604 2256
2605static struct Lisp_Float *float_free_list; 2257static struct Lisp_Float *float_free_list;
2606 2258
2607
2608/* Initialize float allocation. */
2609
2610static void
2611init_float (void)
2612{
2613 float_block = NULL;
2614 float_block_index = FLOAT_BLOCK_SIZE; /* Force alloc of new float_block. */
2615 float_free_list = 0;
2616}
2617
2618
2619/* Return a new float object with value FLOAT_VALUE. */ 2259/* Return a new float object with value FLOAT_VALUE. */
2620 2260
2621Lisp_Object 2261Lisp_Object
@@ -2623,8 +2263,6 @@ make_float (double float_value)
2623{ 2263{
2624 register Lisp_Object val; 2264 register Lisp_Object val;
2625 2265
2626 /* eassert (!handling_signal); */
2627
2628 MALLOC_BLOCK_INPUT; 2266 MALLOC_BLOCK_INPUT;
2629 2267
2630 if (float_free_list) 2268 if (float_free_list)
@@ -2638,14 +2276,13 @@ make_float (double float_value)
2638 { 2276 {
2639 if (float_block_index == FLOAT_BLOCK_SIZE) 2277 if (float_block_index == FLOAT_BLOCK_SIZE)
2640 { 2278 {
2641 register struct float_block *new; 2279 struct float_block *new
2642 2280 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT);
2643 new = (struct float_block *) lisp_align_malloc (sizeof *new,
2644 MEM_TYPE_FLOAT);
2645 new->next = float_block; 2281 new->next = float_block;
2646 memset (new->gcmarkbits, 0, sizeof new->gcmarkbits); 2282 memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
2647 float_block = new; 2283 float_block = new;
2648 float_block_index = 0; 2284 float_block_index = 0;
2285 total_free_floats += FLOAT_BLOCK_SIZE;
2649 } 2286 }
2650 XSETFLOAT (val, &float_block->floats[float_block_index]); 2287 XSETFLOAT (val, &float_block->floats[float_block_index]);
2651 float_block_index++; 2288 float_block_index++;
@@ -2657,6 +2294,7 @@ make_float (double float_value)
2657 eassert (!FLOAT_MARKED_P (XFLOAT (val))); 2294 eassert (!FLOAT_MARKED_P (XFLOAT (val)));
2658 consing_since_gc += sizeof (struct Lisp_Float); 2295 consing_since_gc += sizeof (struct Lisp_Float);
2659 floats_consed++; 2296 floats_consed++;
2297 total_free_floats--;
2660 return val; 2298 return val;
2661} 2299}
2662 2300
@@ -2671,8 +2309,10 @@ make_float (double float_value)
2671 GC are put on a free list to be reallocated before allocating 2309 GC are put on a free list to be reallocated before allocating
2672 any new cons cells from the latest cons_block. */ 2310 any new cons cells from the latest cons_block. */
2673 2311
2674#define CONS_BLOCK_SIZE \ 2312#define CONS_BLOCK_SIZE \
2675 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \ 2313 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2314 /* The compiler might add padding at the end. */ \
2315 - (sizeof (struct Lisp_Cons) - sizeof (int))) * CHAR_BIT) \
2676 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1)) 2316 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2677 2317
2678#define CONS_BLOCK(fptr) \ 2318#define CONS_BLOCK(fptr) \
@@ -2704,24 +2344,12 @@ static struct cons_block *cons_block;
2704 2344
2705/* Index of first unused Lisp_Cons in the current block. */ 2345/* Index of first unused Lisp_Cons in the current block. */
2706 2346
2707static int cons_block_index; 2347static int cons_block_index = CONS_BLOCK_SIZE;
2708 2348
2709/* Free-list of Lisp_Cons structures. */ 2349/* Free-list of Lisp_Cons structures. */
2710 2350
2711static struct Lisp_Cons *cons_free_list; 2351static struct Lisp_Cons *cons_free_list;
2712 2352
2713
2714/* Initialize cons allocation. */
2715
2716static void
2717init_cons (void)
2718{
2719 cons_block = NULL;
2720 cons_block_index = CONS_BLOCK_SIZE; /* Force alloc of new cons_block. */
2721 cons_free_list = 0;
2722}
2723
2724
2725/* Explicitly free a cons cell by putting it on the free-list. */ 2353/* Explicitly free a cons cell by putting it on the free-list. */
2726 2354
2727void 2355void
@@ -2732,6 +2360,8 @@ free_cons (struct Lisp_Cons *ptr)
2732 ptr->car = Vdead; 2360 ptr->car = Vdead;
2733#endif 2361#endif
2734 cons_free_list = ptr; 2362 cons_free_list = ptr;
2363 consing_since_gc -= sizeof *ptr;
2364 total_free_conses++;
2735} 2365}
2736 2366
2737DEFUN ("cons", Fcons, Scons, 2, 2, 0, 2367DEFUN ("cons", Fcons, Scons, 2, 2, 0,
@@ -2740,8 +2370,6 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
2740{ 2370{
2741 register Lisp_Object val; 2371 register Lisp_Object val;
2742 2372
2743 /* eassert (!handling_signal); */
2744
2745 MALLOC_BLOCK_INPUT; 2373 MALLOC_BLOCK_INPUT;
2746 2374
2747 if (cons_free_list) 2375 if (cons_free_list)
@@ -2755,13 +2383,13 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
2755 { 2383 {
2756 if (cons_block_index == CONS_BLOCK_SIZE) 2384 if (cons_block_index == CONS_BLOCK_SIZE)
2757 { 2385 {
2758 register struct cons_block *new; 2386 struct cons_block *new
2759 new = (struct cons_block *) lisp_align_malloc (sizeof *new, 2387 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS);
2760 MEM_TYPE_CONS);
2761 memset (new->gcmarkbits, 0, sizeof new->gcmarkbits); 2388 memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
2762 new->next = cons_block; 2389 new->next = cons_block;
2763 cons_block = new; 2390 cons_block = new;
2764 cons_block_index = 0; 2391 cons_block_index = 0;
2392 total_free_conses += CONS_BLOCK_SIZE;
2765 } 2393 }
2766 XSETCONS (val, &cons_block->conses[cons_block_index]); 2394 XSETCONS (val, &cons_block->conses[cons_block_index]);
2767 cons_block_index++; 2395 cons_block_index++;
@@ -2773,6 +2401,7 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
2773 XSETCDR (val, cdr); 2401 XSETCDR (val, cdr);
2774 eassert (!CONS_MARKED_P (XCONS (val))); 2402 eassert (!CONS_MARKED_P (XCONS (val)));
2775 consing_since_gc += sizeof (struct Lisp_Cons); 2403 consing_since_gc += sizeof (struct Lisp_Cons);
2404 total_free_conses--;
2776 cons_cells_consed++; 2405 cons_cells_consed++;
2777 return val; 2406 return val;
2778} 2407}
@@ -2825,6 +2454,38 @@ list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, L
2825 Fcons (arg5, Qnil))))); 2454 Fcons (arg5, Qnil)))));
2826} 2455}
2827 2456
2457/* Make a list of COUNT Lisp_Objects, where ARG is the
2458 first one. Allocate conses from pure space if TYPE
2459 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2460
2461Lisp_Object
2462listn (enum constype type, ptrdiff_t count, Lisp_Object arg, ...)
2463{
2464 va_list ap;
2465 ptrdiff_t i;
2466 Lisp_Object val, *objp;
2467
2468 /* Change to SAFE_ALLOCA if you hit this eassert. */
2469 eassert (count <= MAX_ALLOCA / word_size);
2470
2471 objp = alloca (count * word_size);
2472 objp[0] = arg;
2473 va_start (ap, arg);
2474 for (i = 1; i < count; i++)
2475 objp[i] = va_arg (ap, Lisp_Object);
2476 va_end (ap);
2477
2478 for (val = Qnil, i = count - 1; i >= 0; i--)
2479 {
2480 if (type == CONSTYPE_PURE)
2481 val = pure_cons (objp[i], val);
2482 else if (type == CONSTYPE_HEAP)
2483 val = Fcons (objp[i], val);
2484 else
2485 emacs_abort ();
2486 }
2487 return val;
2488}
2828 2489
2829DEFUN ("list", Flist, Slist, 0, MANY, 0, 2490DEFUN ("list", Flist, Slist, 0, MANY, 0,
2830 doc: /* Return a newly created list with specified arguments as elements. 2491 doc: /* Return a newly created list with specified arguments as elements.
@@ -2896,51 +2557,407 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
2896 Vector Allocation 2557 Vector Allocation
2897 ***********************************************************************/ 2558 ***********************************************************************/
2898 2559
2899/* Singly-linked list of all vectors. */ 2560/* This value is balanced well enough to avoid too much internal overhead
2561 for the most common cases; it's not required to be a power of two, but
2562 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2900 2563
2901static struct Lisp_Vector *all_vectors; 2564#define VECTOR_BLOCK_SIZE 4096
2902 2565
2903/* Handy constants for vectorlike objects. */ 2566/* Align allocation request sizes to be a multiple of ROUNDUP_SIZE. */
2904enum 2567enum
2905 { 2568 {
2906 header_size = offsetof (struct Lisp_Vector, contents), 2569 roundup_size = COMMON_MULTIPLE (word_size, USE_LSB_TAG ? GCALIGNMENT : 1)
2907 word_size = sizeof (Lisp_Object)
2908 }; 2570 };
2909 2571
2572/* ROUNDUP_SIZE must be a power of 2. */
2573verify ((roundup_size & (roundup_size - 1)) == 0);
2574
2575/* Verify assumptions described above. */
2576verify ((VECTOR_BLOCK_SIZE % roundup_size) == 0);
2577verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS));
2578
2579/* Round up X to nearest mult-of-ROUNDUP_SIZE. */
2580
2581#define vroundup(x) (((x) + (roundup_size - 1)) & ~(roundup_size - 1))
2582
2583/* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2584
2585#define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup (sizeof (void *)))
2586
2587/* Size of the minimal vector allocated from block. */
2588
2589#define VBLOCK_BYTES_MIN vroundup (sizeof (struct Lisp_Vector))
2590
2591/* Size of the largest vector allocated from block. */
2592
2593#define VBLOCK_BYTES_MAX \
2594 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2595
2596/* We maintain one free list for each possible block-allocated
2597 vector size, and this is the number of free lists we have. */
2598
2599#define VECTOR_MAX_FREE_LIST_INDEX \
2600 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2601
2602/* Common shortcut to advance vector pointer over a block data. */
2603
2604#define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2605
2606/* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2607
2608#define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2609
2610/* Get and set the next field in block-allocated vectorlike objects on
2611 the free list. Doing it this way respects C's aliasing rules.
2612 We could instead make 'contents' a union, but that would mean
2613 changes everywhere that the code uses 'contents'. */
2614static struct Lisp_Vector *
2615next_in_free_list (struct Lisp_Vector *v)
2616{
2617 intptr_t i = XLI (v->contents[0]);
2618 return (struct Lisp_Vector *) i;
2619}
2620static void
2621set_next_in_free_list (struct Lisp_Vector *v, struct Lisp_Vector *next)
2622{
2623 v->contents[0] = XIL ((intptr_t) next);
2624}
2625
2626/* Common shortcut to setup vector on a free list. */
2627
2628#define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2629 do { \
2630 (tmp) = ((nbytes - header_size) / word_size); \
2631 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2632 eassert ((nbytes) % roundup_size == 0); \
2633 (tmp) = VINDEX (nbytes); \
2634 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2635 set_next_in_free_list (v, vector_free_lists[tmp]); \
2636 vector_free_lists[tmp] = (v); \
2637 total_free_vector_slots += (nbytes) / word_size; \
2638 } while (0)
2639
2640/* This internal type is used to maintain the list of large vectors
2641 which are allocated at their own, e.g. outside of vector blocks. */
2642
2643struct large_vector
2644{
2645 union {
2646 struct large_vector *vector;
2647#if USE_LSB_TAG
2648 /* We need to maintain ROUNDUP_SIZE alignment for the vector member. */
2649 unsigned char c[vroundup (sizeof (struct large_vector *))];
2650#endif
2651 } next;
2652 struct Lisp_Vector v;
2653};
2654
2655/* This internal type is used to maintain an underlying storage
2656 for small vectors. */
2657
2658struct vector_block
2659{
2660 char data[VECTOR_BLOCK_BYTES];
2661 struct vector_block *next;
2662};
2663
2664/* Chain of vector blocks. */
2665
2666static struct vector_block *vector_blocks;
2667
2668/* Vector free lists, where NTH item points to a chain of free
2669 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2670
2671static struct Lisp_Vector *vector_free_lists[VECTOR_MAX_FREE_LIST_INDEX];
2672
2673/* Singly-linked list of large vectors. */
2674
2675static struct large_vector *large_vectors;
2676
2677/* The only vector with 0 slots, allocated from pure space. */
2678
2679Lisp_Object zero_vector;
2680
2681/* Number of live vectors. */
2682
2683static EMACS_INT total_vectors;
2684
2685/* Total size of live and free vectors, in Lisp_Object units. */
2686
2687static EMACS_INT total_vector_slots, total_free_vector_slots;
2688
2689/* Get a new vector block. */
2690
2691static struct vector_block *
2692allocate_vector_block (void)
2693{
2694 struct vector_block *block = xmalloc (sizeof *block);
2695
2696#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2697 mem_insert (block->data, block->data + VECTOR_BLOCK_BYTES,
2698 MEM_TYPE_VECTOR_BLOCK);
2699#endif
2700
2701 block->next = vector_blocks;
2702 vector_blocks = block;
2703 return block;
2704}
2705
2706/* Called once to initialize vector allocation. */
2707
2708static void
2709init_vectors (void)
2710{
2711 zero_vector = make_pure_vector (0);
2712}
2713
2714/* Allocate vector from a vector block. */
2715
2716static struct Lisp_Vector *
2717allocate_vector_from_block (size_t nbytes)
2718{
2719 struct Lisp_Vector *vector;
2720 struct vector_block *block;
2721 size_t index, restbytes;
2722
2723 eassert (VBLOCK_BYTES_MIN <= nbytes && nbytes <= VBLOCK_BYTES_MAX);
2724 eassert (nbytes % roundup_size == 0);
2725
2726 /* First, try to allocate from a free list
2727 containing vectors of the requested size. */
2728 index = VINDEX (nbytes);
2729 if (vector_free_lists[index])
2730 {
2731 vector = vector_free_lists[index];
2732 vector_free_lists[index] = next_in_free_list (vector);
2733 total_free_vector_slots -= nbytes / word_size;
2734 return vector;
2735 }
2736
2737 /* Next, check free lists containing larger vectors. Since
2738 we will split the result, we should have remaining space
2739 large enough to use for one-slot vector at least. */
2740 for (index = VINDEX (nbytes + VBLOCK_BYTES_MIN);
2741 index < VECTOR_MAX_FREE_LIST_INDEX; index++)
2742 if (vector_free_lists[index])
2743 {
2744 /* This vector is larger than requested. */
2745 vector = vector_free_lists[index];
2746 vector_free_lists[index] = next_in_free_list (vector);
2747 total_free_vector_slots -= nbytes / word_size;
2748
2749 /* Excess bytes are used for the smaller vector,
2750 which should be set on an appropriate free list. */
2751 restbytes = index * roundup_size + VBLOCK_BYTES_MIN - nbytes;
2752 eassert (restbytes % roundup_size == 0);
2753 SETUP_ON_FREE_LIST (ADVANCE (vector, nbytes), restbytes, index);
2754 return vector;
2755 }
2756
2757 /* Finally, need a new vector block. */
2758 block = allocate_vector_block ();
2759
2760 /* New vector will be at the beginning of this block. */
2761 vector = (struct Lisp_Vector *) block->data;
2762
2763 /* If the rest of space from this block is large enough
2764 for one-slot vector at least, set up it on a free list. */
2765 restbytes = VECTOR_BLOCK_BYTES - nbytes;
2766 if (restbytes >= VBLOCK_BYTES_MIN)
2767 {
2768 eassert (restbytes % roundup_size == 0);
2769 SETUP_ON_FREE_LIST (ADVANCE (vector, nbytes), restbytes, index);
2770 }
2771 return vector;
2772}
2773
2774/* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
2775
2776#define VECTOR_IN_BLOCK(vector, block) \
2777 ((char *) (vector) <= (block)->data \
2778 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
2779
2780/* Return the memory footprint of V in bytes. */
2781
2782static ptrdiff_t
2783vector_nbytes (struct Lisp_Vector *v)
2784{
2785 ptrdiff_t size = v->header.size & ~ARRAY_MARK_FLAG;
2786
2787 if (size & PSEUDOVECTOR_FLAG)
2788 {
2789 if (PSEUDOVECTOR_TYPEP (&v->header, PVEC_BOOL_VECTOR))
2790 size = (bool_header_size
2791 + (((struct Lisp_Bool_Vector *) v)->size
2792 + BOOL_VECTOR_BITS_PER_CHAR - 1)
2793 / BOOL_VECTOR_BITS_PER_CHAR);
2794 else
2795 size = (header_size
2796 + ((size & PSEUDOVECTOR_SIZE_MASK)
2797 + ((size & PSEUDOVECTOR_REST_MASK)
2798 >> PSEUDOVECTOR_SIZE_BITS)) * word_size);
2799 }
2800 else
2801 size = header_size + size * word_size;
2802 return vroundup (size);
2803}
2804
2805/* Reclaim space used by unmarked vectors. */
2806
2807static void
2808sweep_vectors (void)
2809{
2810 struct vector_block *block = vector_blocks, **bprev = &vector_blocks;
2811 struct large_vector *lv, **lvprev = &large_vectors;
2812 struct Lisp_Vector *vector, *next;
2813
2814 total_vectors = total_vector_slots = total_free_vector_slots = 0;
2815 memset (vector_free_lists, 0, sizeof (vector_free_lists));
2816
2817 /* Looking through vector blocks. */
2818
2819 for (block = vector_blocks; block; block = *bprev)
2820 {
2821 bool free_this_block = 0;
2822 ptrdiff_t nbytes;
2823
2824 for (vector = (struct Lisp_Vector *) block->data;
2825 VECTOR_IN_BLOCK (vector, block); vector = next)
2826 {
2827 if (VECTOR_MARKED_P (vector))
2828 {
2829 VECTOR_UNMARK (vector);
2830 total_vectors++;
2831 nbytes = vector_nbytes (vector);
2832 total_vector_slots += nbytes / word_size;
2833 next = ADVANCE (vector, nbytes);
2834 }
2835 else
2836 {
2837 ptrdiff_t total_bytes;
2838
2839 nbytes = vector_nbytes (vector);
2840 total_bytes = nbytes;
2841 next = ADVANCE (vector, nbytes);
2842
2843 /* While NEXT is not marked, try to coalesce with VECTOR,
2844 thus making VECTOR of the largest possible size. */
2845
2846 while (VECTOR_IN_BLOCK (next, block))
2847 {
2848 if (VECTOR_MARKED_P (next))
2849 break;
2850 nbytes = vector_nbytes (next);
2851 total_bytes += nbytes;
2852 next = ADVANCE (next, nbytes);
2853 }
2854
2855 eassert (total_bytes % roundup_size == 0);
2856
2857 if (vector == (struct Lisp_Vector *) block->data
2858 && !VECTOR_IN_BLOCK (next, block))
2859 /* This block should be freed because all of it's
2860 space was coalesced into the only free vector. */
2861 free_this_block = 1;
2862 else
2863 {
2864 int tmp;
2865 SETUP_ON_FREE_LIST (vector, total_bytes, tmp);
2866 }
2867 }
2868 }
2869
2870 if (free_this_block)
2871 {
2872 *bprev = block->next;
2873#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2874 mem_delete (mem_find (block->data));
2875#endif
2876 xfree (block);
2877 }
2878 else
2879 bprev = &block->next;
2880 }
2881
2882 /* Sweep large vectors. */
2883
2884 for (lv = large_vectors; lv; lv = *lvprev)
2885 {
2886 vector = &lv->v;
2887 if (VECTOR_MARKED_P (vector))
2888 {
2889 VECTOR_UNMARK (vector);
2890 total_vectors++;
2891 if (vector->header.size & PSEUDOVECTOR_FLAG)
2892 {
2893 struct Lisp_Bool_Vector *b = (struct Lisp_Bool_Vector *) vector;
2894
2895 /* All non-bool pseudovectors are small enough to be allocated
2896 from vector blocks. This code should be redesigned if some
2897 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
2898 eassert (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_BOOL_VECTOR));
2899
2900 total_vector_slots
2901 += (bool_header_size
2902 + ((b->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
2903 / BOOL_VECTOR_BITS_PER_CHAR)) / word_size;
2904 }
2905 else
2906 total_vector_slots
2907 += header_size / word_size + vector->header.size;
2908 lvprev = &lv->next.vector;
2909 }
2910 else
2911 {
2912 *lvprev = lv->next.vector;
2913 lisp_free (lv);
2914 }
2915 }
2916}
2917
2910/* Value is a pointer to a newly allocated Lisp_Vector structure 2918/* Value is a pointer to a newly allocated Lisp_Vector structure
2911 with room for LEN Lisp_Objects. */ 2919 with room for LEN Lisp_Objects. */
2912 2920
2913static struct Lisp_Vector * 2921static struct Lisp_Vector *
2914allocate_vectorlike (EMACS_INT len) 2922allocate_vectorlike (ptrdiff_t len)
2915{ 2923{
2916 struct Lisp_Vector *p; 2924 struct Lisp_Vector *p;
2917 size_t nbytes;
2918 2925
2919 MALLOC_BLOCK_INPUT; 2926 MALLOC_BLOCK_INPUT;
2920 2927
2928 if (len == 0)
2929 p = XVECTOR (zero_vector);
2930 else
2931 {
2932 size_t nbytes = header_size + len * word_size;
2933
2921#ifdef DOUG_LEA_MALLOC 2934#ifdef DOUG_LEA_MALLOC
2922 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed 2935 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2923 because mapped region contents are not preserved in 2936 because mapped region contents are not preserved in
2924 a dumped Emacs. */ 2937 a dumped Emacs. */
2925 mallopt (M_MMAP_MAX, 0); 2938 mallopt (M_MMAP_MAX, 0);
2926#endif 2939#endif
2927 2940
2928 /* This gets triggered by code which I haven't bothered to fix. --Stef */ 2941 if (nbytes <= VBLOCK_BYTES_MAX)
2929 /* eassert (!handling_signal); */ 2942 p = allocate_vector_from_block (vroundup (nbytes));
2930 2943 else
2931 nbytes = header_size + len * word_size; 2944 {
2932 p = (struct Lisp_Vector *) lisp_malloc (nbytes, MEM_TYPE_VECTORLIKE); 2945 struct large_vector *lv
2946 = lisp_malloc (sizeof (*lv) + (len - 1) * word_size,
2947 MEM_TYPE_VECTORLIKE);
2948 lv->next.vector = large_vectors;
2949 large_vectors = lv;
2950 p = &lv->v;
2951 }
2933 2952
2934#ifdef DOUG_LEA_MALLOC 2953#ifdef DOUG_LEA_MALLOC
2935 /* Back to a reasonable maximum of mmap'ed areas. */ 2954 /* Back to a reasonable maximum of mmap'ed areas. */
2936 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); 2955 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
2937#endif 2956#endif
2938 2957
2939 consing_since_gc += nbytes; 2958 consing_since_gc += nbytes;
2940 vector_cells_consed += len; 2959 vector_cells_consed += len;
2941 2960 }
2942 p->header.next.vector = all_vectors;
2943 all_vectors = p;
2944 2961
2945 MALLOC_UNBLOCK_INPUT; 2962 MALLOC_UNBLOCK_INPUT;
2946 2963
@@ -2967,63 +2984,90 @@ allocate_vector (EMACS_INT len)
2967/* Allocate other vector-like structures. */ 2984/* Allocate other vector-like structures. */
2968 2985
2969struct Lisp_Vector * 2986struct Lisp_Vector *
2970allocate_pseudovector (int memlen, int lisplen, EMACS_INT tag) 2987allocate_pseudovector (int memlen, int lisplen, enum pvec_type tag)
2971{ 2988{
2972 struct Lisp_Vector *v = allocate_vectorlike (memlen); 2989 struct Lisp_Vector *v = allocate_vectorlike (memlen);
2973 int i; 2990 int i;
2974 2991
2992 /* Catch bogus values. */
2993 eassert (tag <= PVEC_FONT);
2994 eassert (memlen - lisplen <= (1 << PSEUDOVECTOR_REST_BITS) - 1);
2995 eassert (lisplen <= (1 << PSEUDOVECTOR_SIZE_BITS) - 1);
2996
2975 /* Only the first lisplen slots will be traced normally by the GC. */ 2997 /* Only the first lisplen slots will be traced normally by the GC. */
2976 for (i = 0; i < lisplen; ++i) 2998 for (i = 0; i < lisplen; ++i)
2977 v->contents[i] = Qnil; 2999 v->contents[i] = Qnil;
2978 3000
2979 XSETPVECTYPESIZE (v, tag, lisplen); 3001 XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen);
2980 return v; 3002 return v;
2981} 3003}
2982 3004
3005struct buffer *
3006allocate_buffer (void)
3007{
3008 struct buffer *b = lisp_malloc (sizeof *b, MEM_TYPE_BUFFER);
3009
3010 BUFFER_PVEC_INIT (b);
3011 /* Put B on the chain of all buffers including killed ones. */
3012 b->next = all_buffers;
3013 all_buffers = b;
3014 /* Note that the rest fields of B are not initialized. */
3015 return b;
3016}
3017
2983struct Lisp_Hash_Table * 3018struct Lisp_Hash_Table *
2984allocate_hash_table (void) 3019allocate_hash_table (void)
2985{ 3020{
2986 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table, count, PVEC_HASH_TABLE); 3021 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table, count, PVEC_HASH_TABLE);
2987} 3022}
2988 3023
2989
2990struct window * 3024struct window *
2991allocate_window (void) 3025allocate_window (void)
2992{ 3026{
2993 return ALLOCATE_PSEUDOVECTOR (struct window, current_matrix, PVEC_WINDOW); 3027 struct window *w;
2994}
2995 3028
3029 w = ALLOCATE_PSEUDOVECTOR (struct window, current_matrix, PVEC_WINDOW);
3030 /* Users assumes that non-Lisp data is zeroed. */
3031 memset (&w->current_matrix, 0,
3032 sizeof (*w) - offsetof (struct window, current_matrix));
3033 return w;
3034}
2996 3035
2997struct terminal * 3036struct terminal *
2998allocate_terminal (void) 3037allocate_terminal (void)
2999{ 3038{
3000 struct terminal *t = ALLOCATE_PSEUDOVECTOR (struct terminal, 3039 struct terminal *t;
3001 next_terminal, PVEC_TERMINAL);
3002 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
3003 memset (&t->next_terminal, 0,
3004 (char*) (t + 1) - (char*) &t->next_terminal);
3005 3040
3041 t = ALLOCATE_PSEUDOVECTOR (struct terminal, next_terminal, PVEC_TERMINAL);
3042 /* Users assumes that non-Lisp data is zeroed. */
3043 memset (&t->next_terminal, 0,
3044 sizeof (*t) - offsetof (struct terminal, next_terminal));
3006 return t; 3045 return t;
3007} 3046}
3008 3047
3009struct frame * 3048struct frame *
3010allocate_frame (void) 3049allocate_frame (void)
3011{ 3050{
3012 struct frame *f = ALLOCATE_PSEUDOVECTOR (struct frame, 3051 struct frame *f;
3013 face_cache, PVEC_FRAME); 3052
3014 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */ 3053 f = ALLOCATE_PSEUDOVECTOR (struct frame, face_cache, PVEC_FRAME);
3054 /* Users assumes that non-Lisp data is zeroed. */
3015 memset (&f->face_cache, 0, 3055 memset (&f->face_cache, 0,
3016 (char *) (f + 1) - (char *) &f->face_cache); 3056 sizeof (*f) - offsetof (struct frame, face_cache));
3017 return f; 3057 return f;
3018} 3058}
3019 3059
3020
3021struct Lisp_Process * 3060struct Lisp_Process *
3022allocate_process (void) 3061allocate_process (void)
3023{ 3062{
3024 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS); 3063 struct Lisp_Process *p;
3025}
3026 3064
3065 p = ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS);
3066 /* Users assumes that non-Lisp data is zeroed. */
3067 memset (&p->pid, 0,
3068 sizeof (*p) - offsetof (struct Lisp_Process, pid));
3069 return p;
3070}
3027 3071
3028DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0, 3072DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
3029 doc: /* Return a newly created vector of length LENGTH, with each element being INIT. 3073 doc: /* Return a newly created vector of length LENGTH, with each element being INIT.
@@ -3031,14 +3075,14 @@ See also the function `vector'. */)
3031 (register Lisp_Object length, Lisp_Object init) 3075 (register Lisp_Object length, Lisp_Object init)
3032{ 3076{
3033 Lisp_Object vector; 3077 Lisp_Object vector;
3034 register EMACS_INT sizei; 3078 register ptrdiff_t sizei;
3035 register EMACS_INT i; 3079 register ptrdiff_t i;
3036 register struct Lisp_Vector *p; 3080 register struct Lisp_Vector *p;
3037 3081
3038 CHECK_NATNUM (length); 3082 CHECK_NATNUM (length);
3039 sizei = XFASTINT (length);
3040 3083
3041 p = allocate_vector (sizei); 3084 p = allocate_vector (XFASTINT (length));
3085 sizei = XFASTINT (length);
3042 for (i = 0; i < sizei; i++) 3086 for (i = 0; i < sizei; i++)
3043 p->contents[i] = init; 3087 p->contents[i] = init;
3044 3088
@@ -3065,6 +3109,19 @@ usage: (vector &rest OBJECTS) */)
3065 return val; 3109 return val;
3066} 3110}
3067 3111
3112void
3113make_byte_code (struct Lisp_Vector *v)
3114{
3115 if (v->header.size > 1 && STRINGP (v->contents[1])
3116 && STRING_MULTIBYTE (v->contents[1]))
3117 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3118 earlier because they produced a raw 8-bit string for byte-code
3119 and now such a byte-code string is loaded as multibyte while
3120 raw 8-bit characters converted to multibyte form. Thus, now we
3121 must convert them back to the original unibyte form. */
3122 v->contents[1] = Fstring_as_unibyte (v->contents[1]);
3123 XSETPVECTYPE (v, PVEC_COMPILED);
3124}
3068 3125
3069DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, 3126DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
3070 doc: /* Create a byte-code object with specified arguments as elements. 3127 doc: /* Create a byte-code object with specified arguments as elements.
@@ -3088,28 +3145,21 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT
3088 ptrdiff_t i; 3145 ptrdiff_t i;
3089 register struct Lisp_Vector *p; 3146 register struct Lisp_Vector *p;
3090 3147
3091 XSETFASTINT (len, nargs); 3148 /* We used to purecopy everything here, if purify-flag was set. This worked
3092 if (!NILP (Vpurify_flag)) 3149 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3093 val = make_pure_vector (nargs); 3150 dangerous, since make-byte-code is used during execution to build
3094 else 3151 closures, so any closure built during the preload phase would end up
3095 val = Fmake_vector (len, Qnil); 3152 copied into pure space, including its free variables, which is sometimes
3153 just wasteful and other times plainly wrong (e.g. those free vars may want
3154 to be setcar'd). */
3096 3155
3097 if (nargs > 1 && STRINGP (args[1]) && STRING_MULTIBYTE (args[1])) 3156 XSETFASTINT (len, nargs);
3098 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the 3157 val = Fmake_vector (len, Qnil);
3099 earlier because they produced a raw 8-bit string for byte-code
3100 and now such a byte-code string is loaded as multibyte while
3101 raw 8-bit characters converted to multibyte form. Thus, now we
3102 must convert them back to the original unibyte form. */
3103 args[1] = Fstring_as_unibyte (args[1]);
3104 3158
3105 p = XVECTOR (val); 3159 p = XVECTOR (val);
3106 for (i = 0; i < nargs; i++) 3160 for (i = 0; i < nargs; i++)
3107 { 3161 p->contents[i] = args[i];
3108 if (!NILP (Vpurify_flag)) 3162 make_byte_code (p);
3109 args[i] = Fpurecopy (args[i]);
3110 p->contents[i] = args[i];
3111 }
3112 XSETPVECTYPE (p, PVEC_COMPILED);
3113 XSETCOMPILED (val, p); 3163 XSETCOMPILED (val, p);
3114 return val; 3164 return val;
3115} 3165}
@@ -3120,17 +3170,29 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT
3120 Symbol Allocation 3170 Symbol Allocation
3121 ***********************************************************************/ 3171 ***********************************************************************/
3122 3172
3173/* Like struct Lisp_Symbol, but padded so that the size is a multiple
3174 of the required alignment if LSB tags are used. */
3175
3176union aligned_Lisp_Symbol
3177{
3178 struct Lisp_Symbol s;
3179#if USE_LSB_TAG
3180 unsigned char c[(sizeof (struct Lisp_Symbol) + GCALIGNMENT - 1)
3181 & -GCALIGNMENT];
3182#endif
3183};
3184
3123/* Each symbol_block is just under 1020 bytes long, since malloc 3185/* Each symbol_block is just under 1020 bytes long, since malloc
3124 really allocates in units of powers of two and uses 4 bytes for its 3186 really allocates in units of powers of two and uses 4 bytes for its
3125 own overhead. */ 3187 own overhead. */
3126 3188
3127#define SYMBOL_BLOCK_SIZE \ 3189#define SYMBOL_BLOCK_SIZE \
3128 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol)) 3190 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3129 3191
3130struct symbol_block 3192struct symbol_block
3131{ 3193{
3132 /* Place `symbols' first, to preserve alignment. */ 3194 /* Place `symbols' first, to preserve alignment. */
3133 struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE]; 3195 union aligned_Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
3134 struct symbol_block *next; 3196 struct symbol_block *next;
3135}; 3197};
3136 3198
@@ -3138,27 +3200,15 @@ struct symbol_block
3138 structure in it. */ 3200 structure in it. */
3139 3201
3140static struct symbol_block *symbol_block; 3202static struct symbol_block *symbol_block;
3141static int symbol_block_index; 3203static int symbol_block_index = SYMBOL_BLOCK_SIZE;
3142 3204
3143/* List of free symbols. */ 3205/* List of free symbols. */
3144 3206
3145static struct Lisp_Symbol *symbol_free_list; 3207static struct Lisp_Symbol *symbol_free_list;
3146 3208
3147
3148/* Initialize symbol allocation. */
3149
3150static void
3151init_symbol (void)
3152{
3153 symbol_block = NULL;
3154 symbol_block_index = SYMBOL_BLOCK_SIZE;
3155 symbol_free_list = 0;
3156}
3157
3158
3159DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, 3209DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
3160 doc: /* Return a newly allocated uninterned symbol whose name is NAME. 3210 doc: /* Return a newly allocated uninterned symbol whose name is NAME.
3161Its value and function definition are void, and its property list is nil. */) 3211Its value is void, and its function definition and property list are nil. */)
3162 (Lisp_Object name) 3212 (Lisp_Object name)
3163{ 3213{
3164 register Lisp_Object val; 3214 register Lisp_Object val;
@@ -3166,8 +3216,6 @@ Its value and function definition are void, and its property list is nil. */)
3166 3216
3167 CHECK_STRING (name); 3217 CHECK_STRING (name);
3168 3218
3169 /* eassert (!handling_signal); */
3170
3171 MALLOC_BLOCK_INPUT; 3219 MALLOC_BLOCK_INPUT;
3172 3220
3173 if (symbol_free_list) 3221 if (symbol_free_list)
@@ -3179,32 +3227,33 @@ Its value and function definition are void, and its property list is nil. */)
3179 { 3227 {
3180 if (symbol_block_index == SYMBOL_BLOCK_SIZE) 3228 if (symbol_block_index == SYMBOL_BLOCK_SIZE)
3181 { 3229 {
3182 struct symbol_block *new; 3230 struct symbol_block *new
3183 new = (struct symbol_block *) lisp_malloc (sizeof *new, 3231 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL);
3184 MEM_TYPE_SYMBOL);
3185 new->next = symbol_block; 3232 new->next = symbol_block;
3186 symbol_block = new; 3233 symbol_block = new;
3187 symbol_block_index = 0; 3234 symbol_block_index = 0;
3235 total_free_symbols += SYMBOL_BLOCK_SIZE;
3188 } 3236 }
3189 XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]); 3237 XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index].s);
3190 symbol_block_index++; 3238 symbol_block_index++;
3191 } 3239 }
3192 3240
3193 MALLOC_UNBLOCK_INPUT; 3241 MALLOC_UNBLOCK_INPUT;
3194 3242
3195 p = XSYMBOL (val); 3243 p = XSYMBOL (val);
3196 p->xname = name; 3244 set_symbol_name (val, name);
3197 p->plist = Qnil; 3245 set_symbol_plist (val, Qnil);
3198 p->redirect = SYMBOL_PLAINVAL; 3246 p->redirect = SYMBOL_PLAINVAL;
3199 SET_SYMBOL_VAL (p, Qunbound); 3247 SET_SYMBOL_VAL (p, Qunbound);
3200 p->function = Qunbound; 3248 set_symbol_function (val, Qnil);
3201 p->next = NULL; 3249 set_symbol_next (val, NULL);
3202 p->gcmarkbit = 0; 3250 p->gcmarkbit = 0;
3203 p->interned = SYMBOL_UNINTERNED; 3251 p->interned = SYMBOL_UNINTERNED;
3204 p->constant = 0; 3252 p->constant = 0;
3205 p->declared_special = 0; 3253 p->declared_special = 0;
3206 consing_since_gc += sizeof (struct Lisp_Symbol); 3254 consing_since_gc += sizeof (struct Lisp_Symbol);
3207 symbols_consed++; 3255 symbols_consed++;
3256 total_free_symbols--;
3208 return val; 3257 return val;
3209} 3258}
3210 3259
@@ -3214,41 +3263,43 @@ Its value and function definition are void, and its property list is nil. */)
3214 Marker (Misc) Allocation 3263 Marker (Misc) Allocation
3215 ***********************************************************************/ 3264 ***********************************************************************/
3216 3265
3266/* Like union Lisp_Misc, but padded so that its size is a multiple of
3267 the required alignment when LSB tags are used. */
3268
3269union aligned_Lisp_Misc
3270{
3271 union Lisp_Misc m;
3272#if USE_LSB_TAG
3273 unsigned char c[(sizeof (union Lisp_Misc) + GCALIGNMENT - 1)
3274 & -GCALIGNMENT];
3275#endif
3276};
3277
3217/* Allocation of markers and other objects that share that structure. 3278/* Allocation of markers and other objects that share that structure.
3218 Works like allocation of conses. */ 3279 Works like allocation of conses. */
3219 3280
3220#define MARKER_BLOCK_SIZE \ 3281#define MARKER_BLOCK_SIZE \
3221 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc)) 3282 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3222 3283
3223struct marker_block 3284struct marker_block
3224{ 3285{
3225 /* Place `markers' first, to preserve alignment. */ 3286 /* Place `markers' first, to preserve alignment. */
3226 union Lisp_Misc markers[MARKER_BLOCK_SIZE]; 3287 union aligned_Lisp_Misc markers[MARKER_BLOCK_SIZE];
3227 struct marker_block *next; 3288 struct marker_block *next;
3228}; 3289};
3229 3290
3230static struct marker_block *marker_block; 3291static struct marker_block *marker_block;
3231static int marker_block_index; 3292static int marker_block_index = MARKER_BLOCK_SIZE;
3232 3293
3233static union Lisp_Misc *marker_free_list; 3294static union Lisp_Misc *marker_free_list;
3234 3295
3235static void 3296/* Return a newly allocated Lisp_Misc object of specified TYPE. */
3236init_marker (void)
3237{
3238 marker_block = NULL;
3239 marker_block_index = MARKER_BLOCK_SIZE;
3240 marker_free_list = 0;
3241}
3242 3297
3243/* Return a newly allocated Lisp_Misc object, with no substructure. */ 3298static Lisp_Object
3244 3299allocate_misc (enum Lisp_Misc_Type type)
3245Lisp_Object
3246allocate_misc (void)
3247{ 3300{
3248 Lisp_Object val; 3301 Lisp_Object val;
3249 3302
3250 /* eassert (!handling_signal); */
3251
3252 MALLOC_BLOCK_INPUT; 3303 MALLOC_BLOCK_INPUT;
3253 3304
3254 if (marker_free_list) 3305 if (marker_free_list)
@@ -3260,15 +3311,13 @@ allocate_misc (void)
3260 { 3311 {
3261 if (marker_block_index == MARKER_BLOCK_SIZE) 3312 if (marker_block_index == MARKER_BLOCK_SIZE)
3262 { 3313 {
3263 struct marker_block *new; 3314 struct marker_block *new = lisp_malloc (sizeof *new, MEM_TYPE_MISC);
3264 new = (struct marker_block *) lisp_malloc (sizeof *new,
3265 MEM_TYPE_MISC);
3266 new->next = marker_block; 3315 new->next = marker_block;
3267 marker_block = new; 3316 marker_block = new;
3268 marker_block_index = 0; 3317 marker_block_index = 0;
3269 total_free_markers += MARKER_BLOCK_SIZE; 3318 total_free_markers += MARKER_BLOCK_SIZE;
3270 } 3319 }
3271 XSETMISC (val, &marker_block->markers[marker_block_index]); 3320 XSETMISC (val, &marker_block->markers[marker_block_index].m);
3272 marker_block_index++; 3321 marker_block_index++;
3273 } 3322 }
3274 3323
@@ -3277,6 +3326,7 @@ allocate_misc (void)
3277 --total_free_markers; 3326 --total_free_markers;
3278 consing_since_gc += sizeof (union Lisp_Misc); 3327 consing_since_gc += sizeof (union Lisp_Misc);
3279 misc_objects_consed++; 3328 misc_objects_consed++;
3329 XMISCTYPE (val) = type;
3280 XMISCANY (val)->gcmarkbit = 0; 3330 XMISCANY (val)->gcmarkbit = 0;
3281 return val; 3331 return val;
3282} 3332}
@@ -3289,7 +3339,7 @@ free_misc (Lisp_Object misc)
3289 XMISCTYPE (misc) = Lisp_Misc_Free; 3339 XMISCTYPE (misc) = Lisp_Misc_Free;
3290 XMISC (misc)->u_free.chain = marker_free_list; 3340 XMISC (misc)->u_free.chain = marker_free_list;
3291 marker_free_list = XMISC (misc); 3341 marker_free_list = XMISC (misc);
3292 3342 consing_since_gc -= sizeof (union Lisp_Misc);
3293 total_free_markers++; 3343 total_free_markers++;
3294} 3344}
3295 3345
@@ -3303,8 +3353,7 @@ make_save_value (void *pointer, ptrdiff_t integer)
3303 register Lisp_Object val; 3353 register Lisp_Object val;
3304 register struct Lisp_Save_Value *p; 3354 register struct Lisp_Save_Value *p;
3305 3355
3306 val = allocate_misc (); 3356 val = allocate_misc (Lisp_Misc_Save_Value);
3307 XMISCTYPE (val) = Lisp_Misc_Save_Value;
3308 p = XSAVE_VALUE (val); 3357 p = XSAVE_VALUE (val);
3309 p->pointer = pointer; 3358 p->pointer = pointer;
3310 p->integer = integer; 3359 p->integer = integer;
@@ -3312,6 +3361,21 @@ make_save_value (void *pointer, ptrdiff_t integer)
3312 return val; 3361 return val;
3313} 3362}
3314 3363
3364/* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3365
3366Lisp_Object
3367build_overlay (Lisp_Object start, Lisp_Object end, Lisp_Object plist)
3368{
3369 register Lisp_Object overlay;
3370
3371 overlay = allocate_misc (Lisp_Misc_Overlay);
3372 OVERLAY_START (overlay) = start;
3373 OVERLAY_END (overlay) = end;
3374 set_overlay_plist (overlay, plist);
3375 XOVERLAY (overlay)->next = NULL;
3376 return overlay;
3377}
3378
3315DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, 3379DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
3316 doc: /* Return a newly allocated marker which does not point at any place. */) 3380 doc: /* Return a newly allocated marker which does not point at any place. */)
3317 (void) 3381 (void)
@@ -3319,8 +3383,7 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
3319 register Lisp_Object val; 3383 register Lisp_Object val;
3320 register struct Lisp_Marker *p; 3384 register struct Lisp_Marker *p;
3321 3385
3322 val = allocate_misc (); 3386 val = allocate_misc (Lisp_Misc_Marker);
3323 XMISCTYPE (val) = Lisp_Misc_Marker;
3324 p = XMARKER (val); 3387 p = XMARKER (val);
3325 p->buffer = 0; 3388 p->buffer = 0;
3326 p->bytepos = 0; 3389 p->bytepos = 0;
@@ -3330,6 +3393,32 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
3330 return val; 3393 return val;
3331} 3394}
3332 3395
3396/* Return a newly allocated marker which points into BUF
3397 at character position CHARPOS and byte position BYTEPOS. */
3398
3399Lisp_Object
3400build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos)
3401{
3402 Lisp_Object obj;
3403 struct Lisp_Marker *m;
3404
3405 /* No dead buffers here. */
3406 eassert (BUFFER_LIVE_P (buf));
3407
3408 /* Every character is at least one byte. */
3409 eassert (charpos <= bytepos);
3410
3411 obj = allocate_misc (Lisp_Misc_Marker);
3412 m = XMARKER (obj);
3413 m->buffer = buf;
3414 m->charpos = charpos;
3415 m->bytepos = bytepos;
3416 m->insertion_type = 0;
3417 m->next = BUF_MARKERS (buf);
3418 BUF_MARKERS (buf) = m;
3419 return obj;
3420}
3421
3333/* Put MARKER back on the free list after using it temporarily. */ 3422/* Put MARKER back on the free list after using it temporarily. */
3334 3423
3335void 3424void
@@ -3395,7 +3484,7 @@ void
3395memory_full (size_t nbytes) 3484memory_full (size_t nbytes)
3396{ 3485{
3397 /* Do not go into hysterics merely because a large request failed. */ 3486 /* Do not go into hysterics merely because a large request failed. */
3398 int enough_free_memory = 0; 3487 bool enough_free_memory = 0;
3399 if (SPARE_MEMORY < nbytes) 3488 if (SPARE_MEMORY < nbytes)
3400 { 3489 {
3401 void *p; 3490 void *p;
@@ -3430,12 +3519,6 @@ memory_full (size_t nbytes)
3430 lisp_free (spare_memory[i]); 3519 lisp_free (spare_memory[i]);
3431 spare_memory[i] = 0; 3520 spare_memory[i] = 0;
3432 } 3521 }
3433
3434 /* Record the space now used. When it decreases substantially,
3435 we can refill the memory reserve. */
3436#if !defined SYSTEM_MALLOC && !defined SYNC_INPUT
3437 bytes_used_when_full = BYTES_USED;
3438#endif
3439 } 3522 }
3440 3523
3441 /* This used to call error, but if we've run out of memory, we could 3524 /* This used to call error, but if we've run out of memory, we could
@@ -3455,25 +3538,25 @@ refill_memory_reserve (void)
3455{ 3538{
3456#ifndef SYSTEM_MALLOC 3539#ifndef SYSTEM_MALLOC
3457 if (spare_memory[0] == 0) 3540 if (spare_memory[0] == 0)
3458 spare_memory[0] = (char *) malloc (SPARE_MEMORY); 3541 spare_memory[0] = malloc (SPARE_MEMORY);
3459 if (spare_memory[1] == 0) 3542 if (spare_memory[1] == 0)
3460 spare_memory[1] = (char *) lisp_align_malloc (sizeof (struct cons_block), 3543 spare_memory[1] = lisp_align_malloc (sizeof (struct cons_block),
3461 MEM_TYPE_CONS); 3544 MEM_TYPE_SPARE);
3462 if (spare_memory[2] == 0) 3545 if (spare_memory[2] == 0)
3463 spare_memory[2] = (char *) lisp_align_malloc (sizeof (struct cons_block), 3546 spare_memory[2] = lisp_align_malloc (sizeof (struct cons_block),
3464 MEM_TYPE_CONS); 3547 MEM_TYPE_SPARE);
3465 if (spare_memory[3] == 0) 3548 if (spare_memory[3] == 0)
3466 spare_memory[3] = (char *) lisp_align_malloc (sizeof (struct cons_block), 3549 spare_memory[3] = lisp_align_malloc (sizeof (struct cons_block),
3467 MEM_TYPE_CONS); 3550 MEM_TYPE_SPARE);
3468 if (spare_memory[4] == 0) 3551 if (spare_memory[4] == 0)
3469 spare_memory[4] = (char *) lisp_align_malloc (sizeof (struct cons_block), 3552 spare_memory[4] = lisp_align_malloc (sizeof (struct cons_block),
3470 MEM_TYPE_CONS); 3553 MEM_TYPE_SPARE);
3471 if (spare_memory[5] == 0) 3554 if (spare_memory[5] == 0)
3472 spare_memory[5] = (char *) lisp_malloc (sizeof (struct string_block), 3555 spare_memory[5] = lisp_malloc (sizeof (struct string_block),
3473 MEM_TYPE_STRING); 3556 MEM_TYPE_SPARE);
3474 if (spare_memory[6] == 0) 3557 if (spare_memory[6] == 0)
3475 spare_memory[6] = (char *) lisp_malloc (sizeof (struct string_block), 3558 spare_memory[6] = lisp_malloc (sizeof (struct string_block),
3476 MEM_TYPE_STRING); 3559 MEM_TYPE_SPARE);
3477 if (spare_memory[0] && spare_memory[1] && spare_memory[5]) 3560 if (spare_memory[0] && spare_memory[1] && spare_memory[5])
3478 Vmemory_full = Qnil; 3561 Vmemory_full = Qnil;
3479#endif 3562#endif
@@ -3512,7 +3595,7 @@ mem_init (void)
3512/* Value is a pointer to the mem_node containing START. Value is 3595/* Value is a pointer to the mem_node containing START. Value is
3513 MEM_NIL if there is no node in the tree containing START. */ 3596 MEM_NIL if there is no node in the tree containing START. */
3514 3597
3515static inline struct mem_node * 3598static struct mem_node *
3516mem_find (void *start) 3599mem_find (void *start)
3517{ 3600{
3518 struct mem_node *p; 3601 struct mem_node *p;
@@ -3556,7 +3639,7 @@ mem_insert (void *start, void *end, enum mem_type type)
3556 while (c != MEM_NIL) 3639 while (c != MEM_NIL)
3557 { 3640 {
3558 if (start >= c->start && start < c->end) 3641 if (start >= c->start && start < c->end)
3559 abort (); 3642 emacs_abort ();
3560 parent = c; 3643 parent = c;
3561 c = start < c->start ? c->left : c->right; 3644 c = start < c->start ? c->left : c->right;
3562 } 3645 }
@@ -3573,11 +3656,11 @@ mem_insert (void *start, void *end, enum mem_type type)
3573 3656
3574 /* Create a new node. */ 3657 /* Create a new node. */
3575#ifdef GC_MALLOC_CHECK 3658#ifdef GC_MALLOC_CHECK
3576 x = (struct mem_node *) _malloc_internal (sizeof *x); 3659 x = malloc (sizeof *x);
3577 if (x == NULL) 3660 if (x == NULL)
3578 abort (); 3661 emacs_abort ();
3579#else 3662#else
3580 x = (struct mem_node *) xmalloc (sizeof *x); 3663 x = xmalloc (sizeof *x);
3581#endif 3664#endif
3582 x->start = start; 3665 x->start = start;
3583 x->end = end; 3666 x->end = end;
@@ -3797,7 +3880,7 @@ mem_delete (struct mem_node *z)
3797 mem_delete_fixup (x); 3880 mem_delete_fixup (x);
3798 3881
3799#ifdef GC_MALLOC_CHECK 3882#ifdef GC_MALLOC_CHECK
3800 _free_internal (y); 3883 free (y);
3801#else 3884#else
3802 xfree (y); 3885 xfree (y);
3803#endif 3886#endif
@@ -3888,7 +3971,7 @@ mem_delete_fixup (struct mem_node *x)
3888/* Value is non-zero if P is a pointer to a live Lisp string on 3971/* Value is non-zero if P is a pointer to a live Lisp string on
3889 the heap. M is a pointer to the mem_block for P. */ 3972 the heap. M is a pointer to the mem_block for P. */
3890 3973
3891static inline int 3974static bool
3892live_string_p (struct mem_node *m, void *p) 3975live_string_p (struct mem_node *m, void *p)
3893{ 3976{
3894 if (m->type == MEM_TYPE_STRING) 3977 if (m->type == MEM_TYPE_STRING)
@@ -3911,7 +3994,7 @@ live_string_p (struct mem_node *m, void *p)
3911/* Value is non-zero if P is a pointer to a live Lisp cons on 3994/* Value is non-zero if P is a pointer to a live Lisp cons on
3912 the heap. M is a pointer to the mem_block for P. */ 3995 the heap. M is a pointer to the mem_block for P. */
3913 3996
3914static inline int 3997static bool
3915live_cons_p (struct mem_node *m, void *p) 3998live_cons_p (struct mem_node *m, void *p)
3916{ 3999{
3917 if (m->type == MEM_TYPE_CONS) 4000 if (m->type == MEM_TYPE_CONS)
@@ -3937,7 +4020,7 @@ live_cons_p (struct mem_node *m, void *p)
3937/* Value is non-zero if P is a pointer to a live Lisp symbol on 4020/* Value is non-zero if P is a pointer to a live Lisp symbol on
3938 the heap. M is a pointer to the mem_block for P. */ 4021 the heap. M is a pointer to the mem_block for P. */
3939 4022
3940static inline int 4023static bool
3941live_symbol_p (struct mem_node *m, void *p) 4024live_symbol_p (struct mem_node *m, void *p)
3942{ 4025{
3943 if (m->type == MEM_TYPE_SYMBOL) 4026 if (m->type == MEM_TYPE_SYMBOL)
@@ -3953,7 +4036,7 @@ live_symbol_p (struct mem_node *m, void *p)
3953 && offset < (SYMBOL_BLOCK_SIZE * sizeof b->symbols[0]) 4036 && offset < (SYMBOL_BLOCK_SIZE * sizeof b->symbols[0])
3954 && (b != symbol_block 4037 && (b != symbol_block
3955 || offset / sizeof b->symbols[0] < symbol_block_index) 4038 || offset / sizeof b->symbols[0] < symbol_block_index)
3956 && !EQ (((struct Lisp_Symbol *) p)->function, Vdead)); 4039 && !EQ (((struct Lisp_Symbol *)p)->function, Vdead));
3957 } 4040 }
3958 else 4041 else
3959 return 0; 4042 return 0;
@@ -3963,7 +4046,7 @@ live_symbol_p (struct mem_node *m, void *p)
3963/* Value is non-zero if P is a pointer to a live Lisp float on 4046/* Value is non-zero if P is a pointer to a live Lisp float on
3964 the heap. M is a pointer to the mem_block for P. */ 4047 the heap. M is a pointer to the mem_block for P. */
3965 4048
3966static inline int 4049static bool
3967live_float_p (struct mem_node *m, void *p) 4050live_float_p (struct mem_node *m, void *p)
3968{ 4051{
3969 if (m->type == MEM_TYPE_FLOAT) 4052 if (m->type == MEM_TYPE_FLOAT)
@@ -3987,7 +4070,7 @@ live_float_p (struct mem_node *m, void *p)
3987/* Value is non-zero if P is a pointer to a live Lisp Misc on 4070/* Value is non-zero if P is a pointer to a live Lisp Misc on
3988 the heap. M is a pointer to the mem_block for P. */ 4071 the heap. M is a pointer to the mem_block for P. */
3989 4072
3990static inline int 4073static bool
3991live_misc_p (struct mem_node *m, void *p) 4074live_misc_p (struct mem_node *m, void *p)
3992{ 4075{
3993 if (m->type == MEM_TYPE_MISC) 4076 if (m->type == MEM_TYPE_MISC)
@@ -4013,24 +4096,49 @@ live_misc_p (struct mem_node *m, void *p)
4013/* Value is non-zero if P is a pointer to a live vector-like object. 4096/* Value is non-zero if P is a pointer to a live vector-like object.
4014 M is a pointer to the mem_block for P. */ 4097 M is a pointer to the mem_block for P. */
4015 4098
4016static inline int 4099static bool
4017live_vector_p (struct mem_node *m, void *p) 4100live_vector_p (struct mem_node *m, void *p)
4018{ 4101{
4019 return (p == m->start && m->type == MEM_TYPE_VECTORLIKE); 4102 if (m->type == MEM_TYPE_VECTOR_BLOCK)
4103 {
4104 /* This memory node corresponds to a vector block. */
4105 struct vector_block *block = (struct vector_block *) m->start;
4106 struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data;
4107
4108 /* P is in the block's allocation range. Scan the block
4109 up to P and see whether P points to the start of some
4110 vector which is not on a free list. FIXME: check whether
4111 some allocation patterns (probably a lot of short vectors)
4112 may cause a substantial overhead of this loop. */
4113 while (VECTOR_IN_BLOCK (vector, block)
4114 && vector <= (struct Lisp_Vector *) p)
4115 {
4116 if (!PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE) && vector == p)
4117 return 1;
4118 else
4119 vector = ADVANCE (vector, vector_nbytes (vector));
4120 }
4121 }
4122 else if (m->type == MEM_TYPE_VECTORLIKE
4123 && (char *) p == ((char *) m->start
4124 + offsetof (struct large_vector, v)))
4125 /* This memory node corresponds to a large vector. */
4126 return 1;
4127 return 0;
4020} 4128}
4021 4129
4022 4130
4023/* Value is non-zero if P is a pointer to a live buffer. M is a 4131/* Value is non-zero if P is a pointer to a live buffer. M is a
4024 pointer to the mem_block for P. */ 4132 pointer to the mem_block for P. */
4025 4133
4026static inline int 4134static bool
4027live_buffer_p (struct mem_node *m, void *p) 4135live_buffer_p (struct mem_node *m, void *p)
4028{ 4136{
4029 /* P must point to the start of the block, and the buffer 4137 /* P must point to the start of the block, and the buffer
4030 must not have been killed. */ 4138 must not have been killed. */
4031 return (m->type == MEM_TYPE_BUFFER 4139 return (m->type == MEM_TYPE_BUFFER
4032 && p == m->start 4140 && p == m->start
4033 && !NILP (((struct buffer *) p)->BUFFER_INTERNAL_FIELD (name))); 4141 && !NILP (((struct buffer *) p)->INTERNAL_FIELD (name)));
4034} 4142}
4035 4143
4036#endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */ 4144#endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
@@ -4089,7 +4197,7 @@ DEFUN ("gc-status", Fgc_status, Sgc_status, 0, 0, "",
4089 4197
4090/* Mark OBJ if we can prove it's a Lisp_Object. */ 4198/* Mark OBJ if we can prove it's a Lisp_Object. */
4091 4199
4092static inline void 4200static void
4093mark_maybe_object (Lisp_Object obj) 4201mark_maybe_object (Lisp_Object obj)
4094{ 4202{
4095 void *po; 4203 void *po;
@@ -4103,7 +4211,7 @@ mark_maybe_object (Lisp_Object obj)
4103 4211
4104 if (m != MEM_NIL) 4212 if (m != MEM_NIL)
4105 { 4213 {
4106 int mark_p = 0; 4214 bool mark_p = 0;
4107 4215
4108 switch (XTYPE (obj)) 4216 switch (XTYPE (obj))
4109 { 4217 {
@@ -4158,19 +4266,15 @@ mark_maybe_object (Lisp_Object obj)
4158/* If P points to Lisp data, mark that as live if it isn't already 4266/* If P points to Lisp data, mark that as live if it isn't already
4159 marked. */ 4267 marked. */
4160 4268
4161static inline void 4269static void
4162mark_maybe_pointer (void *p) 4270mark_maybe_pointer (void *p)
4163{ 4271{
4164 struct mem_node *m; 4272 struct mem_node *m;
4165 4273
4166 /* Quickly rule out some values which can't point to Lisp data. */ 4274 /* Quickly rule out some values which can't point to Lisp data.
4167 if ((intptr_t) p % 4275 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4168#ifdef USE_LSB_TAG 4276 Otherwise, assume that Lisp data is aligned on even addresses. */
4169 8 /* USE_LSB_TAG needs Lisp data to be aligned on multiples of 8. */ 4277 if ((intptr_t) p % (USE_LSB_TAG ? GCALIGNMENT : 2))
4170#else
4171 2 /* We assume that Lisp data is aligned on even addresses. */
4172#endif
4173 )
4174 return; 4278 return;
4175 4279
4176 m = mem_find (p); 4280 m = mem_find (p);
@@ -4181,6 +4285,7 @@ mark_maybe_pointer (void *p)
4181 switch (m->type) 4285 switch (m->type)
4182 { 4286 {
4183 case MEM_TYPE_NON_LISP: 4287 case MEM_TYPE_NON_LISP:
4288 case MEM_TYPE_SPARE:
4184 /* Nothing to do; not a pointer to Lisp memory. */ 4289 /* Nothing to do; not a pointer to Lisp memory. */
4185 break; 4290 break;
4186 4291
@@ -4216,6 +4321,7 @@ mark_maybe_pointer (void *p)
4216 break; 4321 break;
4217 4322
4218 case MEM_TYPE_VECTORLIKE: 4323 case MEM_TYPE_VECTORLIKE:
4324 case MEM_TYPE_VECTOR_BLOCK:
4219 if (live_vector_p (m, p)) 4325 if (live_vector_p (m, p))
4220 { 4326 {
4221 Lisp_Object tem; 4327 Lisp_Object tem;
@@ -4226,7 +4332,7 @@ mark_maybe_pointer (void *p)
4226 break; 4332 break;
4227 4333
4228 default: 4334 default:
4229 abort (); 4335 emacs_abort ();
4230 } 4336 }
4231 4337
4232 if (!NILP (obj)) 4338 if (!NILP (obj))
@@ -4235,23 +4341,46 @@ mark_maybe_pointer (void *p)
4235} 4341}
4236 4342
4237 4343
4238/* Alignment of Lisp_Object and pointer values. Use offsetof, as it 4344/* Alignment of pointer values. Use alignof, as it sometimes returns
4239 sometimes returns a smaller alignment than GCC's __alignof__ and 4345 a smaller alignment than GCC's __alignof__ and mark_memory might
4240 mark_memory might miss objects if __alignof__ were used. For 4346 miss objects if __alignof__ were used. */
4241 example, on x86 with WIDE_EMACS_INT, __alignof__ (Lisp_Object) is 8 4347#define GC_POINTER_ALIGNMENT alignof (void *)
4242 but GC_LISP_OBJECT_ALIGNMENT should be 4. */ 4348
4243#ifndef GC_LISP_OBJECT_ALIGNMENT 4349/* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4244# define GC_LISP_OBJECT_ALIGNMENT offsetof (struct {char a; Lisp_Object b;}, b) 4350 not suffice, which is the typical case. A host where a Lisp_Object is
4351 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4352 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4353 suffice to widen it to to a Lisp_Object and check it that way. */
4354#if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4355# if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4356 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4357 nor mark_maybe_object can follow the pointers. This should not occur on
4358 any practical porting target. */
4359# error "MSB type bits straddle pointer-word boundaries"
4360# endif
4361 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4362 pointer words that hold pointers ORed with type bits. */
4363# define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4364#else
4365 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4366 words that hold unmodified pointers. */
4367# define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4245#endif 4368#endif
4246#define GC_POINTER_ALIGNMENT offsetof (struct {char a; void *b;}, b)
4247 4369
4248/* Mark Lisp objects referenced from the address range START+OFFSET..END 4370/* Mark Lisp objects referenced from the address range START+OFFSET..END
4249 or END+OFFSET..START. */ 4371 or END+OFFSET..START. */
4250 4372
4251static void 4373static void
4252mark_memory (void *start, void *end) 4374mark_memory (void *start, void *end)
4375#if defined (__clang__) && defined (__has_feature)
4376#if __has_feature(address_sanitizer)
4377 /* Do not allow -faddress-sanitizer to check this function, since it
4378 crosses the function stack boundary, and thus would yield many
4379 false positives. */
4380 __attribute__((no_address_safety_analysis))
4381#endif
4382#endif
4253{ 4383{
4254 Lisp_Object *p;
4255 void **pp; 4384 void **pp;
4256 int i; 4385 int i;
4257 4386
@@ -4268,11 +4397,6 @@ mark_memory (void *start, void *end)
4268 end = tem; 4397 end = tem;
4269 } 4398 }
4270 4399
4271 /* Mark Lisp_Objects. */
4272 for (p = start; (void *) p < end; p++)
4273 for (i = 0; i < sizeof *p; i += GC_LISP_OBJECT_ALIGNMENT)
4274 mark_maybe_object (*(Lisp_Object *) ((char *) p + i));
4275
4276 /* Mark Lisp data pointed to. This is necessary because, in some 4400 /* Mark Lisp data pointed to. This is necessary because, in some
4277 situations, the C compiler optimizes Lisp objects away, so that 4401 situations, the C compiler optimizes Lisp objects away, so that
4278 only a pointer to them remains. Example: 4402 only a pointer to them remains. Example:
@@ -4293,7 +4417,12 @@ mark_memory (void *start, void *end)
4293 4417
4294 for (pp = start; (void *) pp < end; pp++) 4418 for (pp = start; (void *) pp < end; pp++)
4295 for (i = 0; i < sizeof *pp; i += GC_POINTER_ALIGNMENT) 4419 for (i = 0; i < sizeof *pp; i += GC_POINTER_ALIGNMENT)
4296 mark_maybe_pointer (*(void **) ((char *) pp + i)); 4420 {
4421 void *p = *(void **) ((char *) pp + i);
4422 mark_maybe_pointer (p);
4423 if (POINTERS_MIGHT_HIDE_IN_OBJECTS)
4424 mark_maybe_object (XIL ((intptr_t) p));
4425 }
4297} 4426}
4298 4427
4299/* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in 4428/* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
@@ -4303,7 +4432,8 @@ mark_memory (void *start, void *end)
4303 4432
4304#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS 4433#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4305 4434
4306static int setjmp_tested_p, longjmps_done; 4435static bool setjmp_tested_p;
4436static int longjmps_done;
4307 4437
4308#define SETJMP_WILL_LIKELY_WORK "\ 4438#define SETJMP_WILL_LIKELY_WORK "\
4309\n\ 4439\n\
@@ -4346,15 +4476,14 @@ test_setjmp (void)
4346{ 4476{
4347 char buf[10]; 4477 char buf[10];
4348 register int x; 4478 register int x;
4349 jmp_buf jbuf; 4479 sys_jmp_buf jbuf;
4350 int result = 0;
4351 4480
4352 /* Arrange for X to be put in a register. */ 4481 /* Arrange for X to be put in a register. */
4353 sprintf (buf, "1"); 4482 sprintf (buf, "1");
4354 x = strlen (buf); 4483 x = strlen (buf);
4355 x = 2 * x - 1; 4484 x = 2 * x - 1;
4356 4485
4357 setjmp (jbuf); 4486 sys_setjmp (jbuf);
4358 if (longjmps_done == 1) 4487 if (longjmps_done == 1)
4359 { 4488 {
4360 /* Came here after the longjmp at the end of the function. 4489 /* Came here after the longjmp at the end of the function.
@@ -4379,7 +4508,7 @@ test_setjmp (void)
4379 ++longjmps_done; 4508 ++longjmps_done;
4380 x = 2; 4509 x = 2;
4381 if (longjmps_done == 1) 4510 if (longjmps_done == 1)
4382 longjmp (jbuf, 1); 4511 sys_longjmp (jbuf, 1);
4383} 4512}
4384 4513
4385#endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */ 4514#endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
@@ -4400,7 +4529,7 @@ check_gcpros (void)
4400 if (!survives_gc_p (p->var[i])) 4529 if (!survives_gc_p (p->var[i]))
4401 /* FIXME: It's not necessarily a bug. It might just be that the 4530 /* FIXME: It's not necessarily a bug. It might just be that the
4402 GCPRO is unnecessary or should release the object sooner. */ 4531 GCPRO is unnecessary or should release the object sooner. */
4403 abort (); 4532 emacs_abort ();
4404} 4533}
4405 4534
4406#elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES 4535#elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
@@ -4485,9 +4614,9 @@ mark_stack (void)
4485 /* jmp_buf may not be aligned enough on darwin-ppc64 */ 4614 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4486 union aligned_jmpbuf { 4615 union aligned_jmpbuf {
4487 Lisp_Object o; 4616 Lisp_Object o;
4488 jmp_buf j; 4617 sys_jmp_buf j;
4489 } j; 4618 } j;
4490 volatile int stack_grows_down_p = (char *) &j > (char *) stack_base; 4619 volatile bool stack_grows_down_p = (char *) &j > (char *) stack_base;
4491#endif 4620#endif
4492 /* This trick flushes the register windows so that all the state of 4621 /* This trick flushes the register windows so that all the state of
4493 the process is contained in the stack. */ 4622 the process is contained in the stack. */
@@ -4521,7 +4650,7 @@ mark_stack (void)
4521 } 4650 }
4522#endif /* GC_SETJMP_WORKS */ 4651#endif /* GC_SETJMP_WORKS */
4523 4652
4524 setjmp (j.j); 4653 sys_setjmp (j.j);
4525 end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j; 4654 end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
4526#endif /* not GC_SAVE_REGISTERS_ON_STACK */ 4655#endif /* not GC_SAVE_REGISTERS_ON_STACK */
4527#endif /* not HAVE___BUILTIN_UNWIND_INIT */ 4656#endif /* not HAVE___BUILTIN_UNWIND_INIT */
@@ -4561,7 +4690,7 @@ valid_pointer_p (void *p)
4561 4690
4562 if (pipe (fd) == 0) 4691 if (pipe (fd) == 0)
4563 { 4692 {
4564 int valid = (emacs_write (fd[1], (char *) p, 16) == 16); 4693 bool valid = emacs_write (fd[1], (char *) p, 16) == 16;
4565 emacs_close (fd[1]); 4694 emacs_close (fd[1]);
4566 emacs_close (fd[0]); 4695 emacs_close (fd[0]);
4567 return valid; 4696 return valid;
@@ -4571,7 +4700,8 @@ valid_pointer_p (void *p)
4571#endif 4700#endif
4572} 4701}
4573 4702
4574/* Return 1 if OBJ is a valid lisp object. 4703/* Return 2 if OBJ is a killed or special buffer object.
4704 Return 1 if OBJ is a valid lisp object.
4575 Return 0 if OBJ is NOT a valid lisp object. 4705 Return 0 if OBJ is NOT a valid lisp object.
4576 Return -1 if we cannot validate OBJ. 4706 Return -1 if we cannot validate OBJ.
4577 This function can be quite slow, 4707 This function can be quite slow,
@@ -4592,6 +4722,9 @@ valid_lisp_object_p (Lisp_Object obj)
4592 if (PURE_POINTER_P (p)) 4722 if (PURE_POINTER_P (p))
4593 return 1; 4723 return 1;
4594 4724
4725 if (p == &buffer_defaults || p == &buffer_local_symbols)
4726 return 2;
4727
4595#if !GC_MARK_STACK 4728#if !GC_MARK_STACK
4596 return valid_pointer_p (p); 4729 return valid_pointer_p (p);
4597#else 4730#else
@@ -4613,10 +4746,11 @@ valid_lisp_object_p (Lisp_Object obj)
4613 switch (m->type) 4746 switch (m->type)
4614 { 4747 {
4615 case MEM_TYPE_NON_LISP: 4748 case MEM_TYPE_NON_LISP:
4749 case MEM_TYPE_SPARE:
4616 return 0; 4750 return 0;
4617 4751
4618 case MEM_TYPE_BUFFER: 4752 case MEM_TYPE_BUFFER:
4619 return live_buffer_p (m, p); 4753 return live_buffer_p (m, p) ? 1 : 2;
4620 4754
4621 case MEM_TYPE_CONS: 4755 case MEM_TYPE_CONS:
4622 return live_cons_p (m, p); 4756 return live_cons_p (m, p);
@@ -4634,6 +4768,7 @@ valid_lisp_object_p (Lisp_Object obj)
4634 return live_float_p (m, p); 4768 return live_float_p (m, p);
4635 4769
4636 case MEM_TYPE_VECTORLIKE: 4770 case MEM_TYPE_VECTORLIKE:
4771 case MEM_TYPE_VECTOR_BLOCK:
4637 return live_vector_p (m, p); 4772 return live_vector_p (m, p);
4638 4773
4639 default: 4774 default:
@@ -4655,24 +4790,18 @@ valid_lisp_object_p (Lisp_Object obj)
4655 pointer to it. TYPE is the Lisp type for which the memory is 4790 pointer to it. TYPE is the Lisp type for which the memory is
4656 allocated. TYPE < 0 means it's not used for a Lisp object. */ 4791 allocated. TYPE < 0 means it's not used for a Lisp object. */
4657 4792
4658static POINTER_TYPE * 4793static void *
4659pure_alloc (size_t size, int type) 4794pure_alloc (size_t size, int type)
4660{ 4795{
4661 POINTER_TYPE *result; 4796 void *result;
4662#ifdef USE_LSB_TAG 4797#if USE_LSB_TAG
4663 size_t alignment = (1 << GCTYPEBITS); 4798 size_t alignment = GCALIGNMENT;
4664#else 4799#else
4665 size_t alignment = sizeof (EMACS_INT); 4800 size_t alignment = alignof (EMACS_INT);
4666 4801
4667 /* Give Lisp_Floats an extra alignment. */ 4802 /* Give Lisp_Floats an extra alignment. */
4668 if (type == Lisp_Float) 4803 if (type == Lisp_Float)
4669 { 4804 alignment = alignof (struct Lisp_Float);
4670#if defined __GNUC__ && __GNUC__ >= 2
4671 alignment = __alignof (struct Lisp_Float);
4672#else
4673 alignment = sizeof (struct Lisp_Float);
4674#endif
4675 }
4676#endif 4805#endif
4677 4806
4678 again: 4807 again:
@@ -4698,7 +4827,7 @@ pure_alloc (size_t size, int type)
4698 /* Don't allocate a large amount here, 4827 /* Don't allocate a large amount here,
4699 because it might get mmap'd and then its address 4828 because it might get mmap'd and then its address
4700 might not be usable. */ 4829 might not be usable. */
4701 purebeg = (char *) xmalloc (10000); 4830 purebeg = xmalloc (10000);
4702 pure_size = 10000; 4831 pure_size = 10000;
4703 pure_bytes_used_before_overflow += pure_bytes_used - size; 4832 pure_bytes_used_before_overflow += pure_bytes_used - size;
4704 pure_bytes_used = 0; 4833 pure_bytes_used = 0;
@@ -4724,14 +4853,14 @@ check_pure_size (void)
4724 address. Return NULL if not found. */ 4853 address. Return NULL if not found. */
4725 4854
4726static char * 4855static char *
4727find_string_data_in_pure (const char *data, EMACS_INT nbytes) 4856find_string_data_in_pure (const char *data, ptrdiff_t nbytes)
4728{ 4857{
4729 int i; 4858 int i;
4730 EMACS_INT skip, bm_skip[256], last_char_skip, infinity, start, start_max; 4859 ptrdiff_t skip, bm_skip[256], last_char_skip, infinity, start, start_max;
4731 const unsigned char *p; 4860 const unsigned char *p;
4732 char *non_lisp_beg; 4861 char *non_lisp_beg;
4733 4862
4734 if (pure_bytes_used_non_lisp < nbytes + 1) 4863 if (pure_bytes_used_non_lisp <= nbytes)
4735 return NULL; 4864 return NULL;
4736 4865
4737 /* Set up the Boyer-Moore table. */ 4866 /* Set up the Boyer-Moore table. */
@@ -4787,7 +4916,7 @@ find_string_data_in_pure (const char *data, EMACS_INT nbytes)
4787 4916
4788/* Return a string allocated in pure space. DATA is a buffer holding 4917/* Return a string allocated in pure space. DATA is a buffer holding
4789 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE 4918 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4790 non-zero means make the result string multibyte. 4919 means make the result string multibyte.
4791 4920
4792 Must get an error if pure storage is full, since if it cannot hold 4921 Must get an error if pure storage is full, since if it cannot hold
4793 a large string it may be able to hold conses that point to that 4922 a large string it may be able to hold conses that point to that
@@ -4795,41 +4924,36 @@ find_string_data_in_pure (const char *data, EMACS_INT nbytes)
4795 4924
4796Lisp_Object 4925Lisp_Object
4797make_pure_string (const char *data, 4926make_pure_string (const char *data,
4798 EMACS_INT nchars, EMACS_INT nbytes, int multibyte) 4927 ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte)
4799{ 4928{
4800 Lisp_Object string; 4929 Lisp_Object string;
4801 struct Lisp_String *s; 4930 struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String);
4802
4803 s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
4804 s->data = (unsigned char *) find_string_data_in_pure (data, nbytes); 4931 s->data = (unsigned char *) find_string_data_in_pure (data, nbytes);
4805 if (s->data == NULL) 4932 if (s->data == NULL)
4806 { 4933 {
4807 s->data = (unsigned char *) pure_alloc (nbytes + 1, -1); 4934 s->data = pure_alloc (nbytes + 1, -1);
4808 memcpy (s->data, data, nbytes); 4935 memcpy (s->data, data, nbytes);
4809 s->data[nbytes] = '\0'; 4936 s->data[nbytes] = '\0';
4810 } 4937 }
4811 s->size = nchars; 4938 s->size = nchars;
4812 s->size_byte = multibyte ? nbytes : -1; 4939 s->size_byte = multibyte ? nbytes : -1;
4813 s->intervals = NULL_INTERVAL; 4940 s->intervals = NULL;
4814 XSETSTRING (string, s); 4941 XSETSTRING (string, s);
4815 return string; 4942 return string;
4816} 4943}
4817 4944
4818/* Return a string a string allocated in pure space. Do not allocate 4945/* Return a string allocated in pure space. Do not
4819 the string data, just point to DATA. */ 4946 allocate the string data, just point to DATA. */
4820 4947
4821Lisp_Object 4948Lisp_Object
4822make_pure_c_string (const char *data) 4949make_pure_c_string (const char *data, ptrdiff_t nchars)
4823{ 4950{
4824 Lisp_Object string; 4951 Lisp_Object string;
4825 struct Lisp_String *s; 4952 struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String);
4826 EMACS_INT nchars = strlen (data);
4827
4828 s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
4829 s->size = nchars; 4953 s->size = nchars;
4830 s->size_byte = -1; 4954 s->size_byte = -1;
4831 s->data = (unsigned char *) data; 4955 s->data = (unsigned char *) data;
4832 s->intervals = NULL_INTERVAL; 4956 s->intervals = NULL;
4833 XSETSTRING (string, s); 4957 XSETSTRING (string, s);
4834 return string; 4958 return string;
4835} 4959}
@@ -4840,10 +4964,8 @@ make_pure_c_string (const char *data)
4840Lisp_Object 4964Lisp_Object
4841pure_cons (Lisp_Object car, Lisp_Object cdr) 4965pure_cons (Lisp_Object car, Lisp_Object cdr)
4842{ 4966{
4843 register Lisp_Object new; 4967 Lisp_Object new;
4844 struct Lisp_Cons *p; 4968 struct Lisp_Cons *p = pure_alloc (sizeof *p, Lisp_Cons);
4845
4846 p = (struct Lisp_Cons *) pure_alloc (sizeof *p, Lisp_Cons);
4847 XSETCONS (new, p); 4969 XSETCONS (new, p);
4848 XSETCAR (new, Fpurecopy (car)); 4970 XSETCAR (new, Fpurecopy (car));
4849 XSETCDR (new, Fpurecopy (cdr)); 4971 XSETCDR (new, Fpurecopy (cdr));
@@ -4856,10 +4978,8 @@ pure_cons (Lisp_Object car, Lisp_Object cdr)
4856static Lisp_Object 4978static Lisp_Object
4857make_pure_float (double num) 4979make_pure_float (double num)
4858{ 4980{
4859 register Lisp_Object new; 4981 Lisp_Object new;
4860 struct Lisp_Float *p; 4982 struct Lisp_Float *p = pure_alloc (sizeof *p, Lisp_Float);
4861
4862 p = (struct Lisp_Float *) pure_alloc (sizeof *p, Lisp_Float);
4863 XSETFLOAT (new, p); 4983 XSETFLOAT (new, p);
4864 XFLOAT_INIT (new, num); 4984 XFLOAT_INIT (new, num);
4865 return new; 4985 return new;
@@ -4869,15 +4989,12 @@ make_pure_float (double num)
4869/* Return a vector with room for LEN Lisp_Objects allocated from 4989/* Return a vector with room for LEN Lisp_Objects allocated from
4870 pure space. */ 4990 pure space. */
4871 4991
4872Lisp_Object 4992static Lisp_Object
4873make_pure_vector (EMACS_INT len) 4993make_pure_vector (ptrdiff_t len)
4874{ 4994{
4875 Lisp_Object new; 4995 Lisp_Object new;
4876 struct Lisp_Vector *p; 4996 size_t size = header_size + len * word_size;
4877 size_t size = (offsetof (struct Lisp_Vector, contents) 4997 struct Lisp_Vector *p = pure_alloc (size, Lisp_Vectorlike);
4878 + len * sizeof (Lisp_Object));
4879
4880 p = (struct Lisp_Vector *) pure_alloc (size, Lisp_Vectorlike);
4881 XSETVECTOR (new, p); 4998 XSETVECTOR (new, p);
4882 XVECTOR (new)->header.size = len; 4999 XVECTOR (new)->header.size = len;
4883 return new; 5000 return new;
@@ -4914,15 +5031,15 @@ Does not copy symbols. Copies strings without text properties. */)
4914 else if (COMPILEDP (obj) || VECTORP (obj)) 5031 else if (COMPILEDP (obj) || VECTORP (obj))
4915 { 5032 {
4916 register struct Lisp_Vector *vec; 5033 register struct Lisp_Vector *vec;
4917 register EMACS_INT i; 5034 register ptrdiff_t i;
4918 EMACS_INT size; 5035 ptrdiff_t size;
4919 5036
4920 size = ASIZE (obj); 5037 size = ASIZE (obj);
4921 if (size & PSEUDOVECTOR_FLAG) 5038 if (size & PSEUDOVECTOR_FLAG)
4922 size &= PSEUDOVECTOR_SIZE_MASK; 5039 size &= PSEUDOVECTOR_SIZE_MASK;
4923 vec = XVECTOR (make_pure_vector (size)); 5040 vec = XVECTOR (make_pure_vector (size));
4924 for (i = 0; i < size; i++) 5041 for (i = 0; i < size; i++)
4925 vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]); 5042 vec->contents[i] = Fpurecopy (AREF (obj, i));
4926 if (COMPILEDP (obj)) 5043 if (COMPILEDP (obj))
4927 { 5044 {
4928 XSETPVECTYPE (vec, PVEC_COMPILED); 5045 XSETPVECTYPE (vec, PVEC_COMPILED);
@@ -4957,7 +5074,7 @@ staticpro (Lisp_Object *varaddress)
4957{ 5074{
4958 staticvec[staticidx++] = varaddress; 5075 staticvec[staticidx++] = varaddress;
4959 if (staticidx >= NSTATICS) 5076 if (staticidx >= NSTATICS)
4960 abort (); 5077 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
4961} 5078}
4962 5079
4963 5080
@@ -4967,84 +5084,96 @@ staticpro (Lisp_Object *varaddress)
4967 5084
4968/* Temporarily prevent garbage collection. */ 5085/* Temporarily prevent garbage collection. */
4969 5086
4970int 5087ptrdiff_t
4971inhibit_garbage_collection (void) 5088inhibit_garbage_collection (void)
4972{ 5089{
4973 int count = SPECPDL_INDEX (); 5090 ptrdiff_t count = SPECPDL_INDEX ();
4974 5091
4975 specbind (Qgc_cons_threshold, make_number (MOST_POSITIVE_FIXNUM)); 5092 specbind (Qgc_cons_threshold, make_number (MOST_POSITIVE_FIXNUM));
4976 return count; 5093 return count;
4977} 5094}
4978 5095
5096/* Used to avoid possible overflows when
5097 converting from C to Lisp integers. */
5098
5099static Lisp_Object
5100bounded_number (EMACS_INT number)
5101{
5102 return make_number (min (MOST_POSITIVE_FIXNUM, number));
5103}
5104
5105/* Calculate total bytes of live objects. */
5106
5107static size_t
5108total_bytes_of_live_objects (void)
5109{
5110 size_t tot = 0;
5111 tot += total_conses * sizeof (struct Lisp_Cons);
5112 tot += total_symbols * sizeof (struct Lisp_Symbol);
5113 tot += total_markers * sizeof (union Lisp_Misc);
5114 tot += total_string_bytes;
5115 tot += total_vector_slots * word_size;
5116 tot += total_floats * sizeof (struct Lisp_Float);
5117 tot += total_intervals * sizeof (struct interval);
5118 tot += total_strings * sizeof (struct Lisp_String);
5119 return tot;
5120}
4979 5121
4980DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "", 5122DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
4981 doc: /* Reclaim storage for Lisp objects no longer needed. 5123 doc: /* Reclaim storage for Lisp objects no longer needed.
4982Garbage collection happens automatically if you cons more than 5124Garbage collection happens automatically if you cons more than
4983`gc-cons-threshold' bytes of Lisp data since previous garbage collection. 5125`gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4984`garbage-collect' normally returns a list with info on amount of space in use: 5126`garbage-collect' normally returns a list with info on amount of space in use,
4985 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS) 5127where each entry has the form (NAME SIZE USED FREE), where:
4986 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS 5128- NAME is a symbol describing the kind of objects this entry represents,
4987 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS) 5129- SIZE is the number of bytes used by each one,
4988 (USED-STRINGS . FREE-STRINGS)) 5130- USED is the number of those objects that were found live in the heap,
5131- FREE is the number of those objects that are not live but that Emacs
5132 keeps around for future allocations (maybe because it does not know how
5133 to return them to the OS).
4989However, if there was overflow in pure space, `garbage-collect' 5134However, if there was overflow in pure space, `garbage-collect'
4990returns nil, because real GC can't be done. */) 5135returns nil, because real GC can't be done.
5136See Info node `(elisp)Garbage Collection'. */)
4991 (void) 5137 (void)
4992{ 5138{
4993 register struct specbinding *bind; 5139 struct specbinding *bind;
5140 struct buffer *nextb;
4994 char stack_top_variable; 5141 char stack_top_variable;
4995 ptrdiff_t i; 5142 ptrdiff_t i;
4996 int message_p; 5143 bool message_p;
4997 Lisp_Object total[8]; 5144 ptrdiff_t count = SPECPDL_INDEX ();
4998 int count = SPECPDL_INDEX (); 5145 EMACS_TIME start;
4999 EMACS_TIME t1, t2, t3; 5146 Lisp_Object retval = Qnil;
5147 size_t tot_before = 0;
5148 struct backtrace backtrace;
5000 5149
5001 if (abort_on_gc) 5150 if (abort_on_gc)
5002 abort (); 5151 emacs_abort ();
5003 5152
5004 /* Can't GC if pure storage overflowed because we can't determine 5153 /* Can't GC if pure storage overflowed because we can't determine
5005 if something is a pure object or not. */ 5154 if something is a pure object or not. */
5006 if (pure_bytes_used_before_overflow) 5155 if (pure_bytes_used_before_overflow)
5007 return Qnil; 5156 return Qnil;
5008 5157
5009 CHECK_CONS_LIST (); 5158 /* Record this function, so it appears on the profiler's backtraces. */
5159 backtrace.next = backtrace_list;
5160 backtrace.function = Qautomatic_gc;
5161 backtrace.args = &Qnil;
5162 backtrace.nargs = 0;
5163 backtrace.debug_on_exit = 0;
5164 backtrace_list = &backtrace;
5165
5166 check_cons_list ();
5010 5167
5011 /* Don't keep undo information around forever. 5168 /* Don't keep undo information around forever.
5012 Do this early on, so it is no problem if the user quits. */ 5169 Do this early on, so it is no problem if the user quits. */
5013 { 5170 FOR_EACH_BUFFER (nextb)
5014 register struct buffer *nextb = all_buffers; 5171 compact_buffer (nextb);
5015 5172
5016 while (nextb) 5173 if (profiler_memory_running)
5017 { 5174 tot_before = total_bytes_of_live_objects ();
5018 /* If a buffer's undo list is Qt, that means that undo is
5019 turned off in that buffer. Calling truncate_undo_list on
5020 Qt tends to return NULL, which effectively turns undo back on.
5021 So don't call truncate_undo_list if undo_list is Qt. */
5022 if (! NILP (nextb->BUFFER_INTERNAL_FIELD (name)) && ! EQ (nextb->BUFFER_INTERNAL_FIELD (undo_list), Qt))
5023 truncate_undo_list (nextb);
5024
5025 /* Shrink buffer gaps, but skip indirect and dead buffers. */
5026 if (nextb->base_buffer == 0 && !NILP (nextb->BUFFER_INTERNAL_FIELD (name))
5027 && ! nextb->text->inhibit_shrinking)
5028 {
5029 /* If a buffer's gap size is more than 10% of the buffer
5030 size, or larger than 2000 bytes, then shrink it
5031 accordingly. Keep a minimum size of 20 bytes. */
5032 int size = min (2000, max (20, (nextb->text->z_byte / 10)));
5033 5175
5034 if (nextb->text->gap_size > size) 5176 start = current_emacs_time ();
5035 {
5036 struct buffer *save_current = current_buffer;
5037 current_buffer = nextb;
5038 make_gap (-(nextb->text->gap_size - size));
5039 current_buffer = save_current;
5040 }
5041 }
5042
5043 nextb = nextb->header.next.buffer;
5044 }
5045 }
5046
5047 EMACS_GET_TIME (t1);
5048 5177
5049 /* In case user calls debug_print during GC, 5178 /* In case user calls debug_print during GC,
5050 don't let that cause a recursive GC. */ 5179 don't let that cause a recursive GC. */
@@ -5074,7 +5203,7 @@ returns nil, because real GC can't be done. */)
5074 { 5203 {
5075 if (stack_copy_size < stack_size) 5204 if (stack_copy_size < stack_size)
5076 { 5205 {
5077 stack_copy = (char *) xrealloc (stack_copy, stack_size); 5206 stack_copy = xrealloc (stack_copy, stack_size);
5078 stack_copy_size = stack_size; 5207 stack_copy_size = stack_size;
5079 } 5208 }
5080 memcpy (stack_copy, stack, stack_size); 5209 memcpy (stack_copy, stack, stack_size);
@@ -5085,16 +5214,17 @@ returns nil, because real GC can't be done. */)
5085 if (garbage_collection_messages) 5214 if (garbage_collection_messages)
5086 message1_nolog ("Garbage collecting..."); 5215 message1_nolog ("Garbage collecting...");
5087 5216
5088 BLOCK_INPUT; 5217 block_input ();
5089 5218
5090 shrink_regexp_cache (); 5219 shrink_regexp_cache ();
5091 5220
5092 gc_in_progress = 1; 5221 gc_in_progress = 1;
5093 5222
5094 /* clear_marks (); */
5095
5096 /* Mark all the special slots that serve as the roots of accessibility. */ 5223 /* Mark all the special slots that serve as the roots of accessibility. */
5097 5224
5225 mark_buffer (&buffer_defaults);
5226 mark_buffer (&buffer_local_symbols);
5227
5098 for (i = 0; i < staticidx; i++) 5228 for (i = 0; i < staticidx; i++)
5099 mark_object (*staticvec[i]); 5229 mark_object (*staticvec[i]);
5100 5230
@@ -5105,13 +5235,9 @@ returns nil, because real GC can't be done. */)
5105 } 5235 }
5106 mark_terminals (); 5236 mark_terminals ();
5107 mark_kboards (); 5237 mark_kboards ();
5108 mark_ttys ();
5109 5238
5110#ifdef USE_GTK 5239#ifdef USE_GTK
5111 { 5240 xg_mark_data ();
5112 extern void xg_mark_data (void);
5113 xg_mark_data ();
5114 }
5115#endif 5241#endif
5116 5242
5117#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ 5243#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
@@ -5156,48 +5282,42 @@ returns nil, because real GC can't be done. */)
5156 Look thru every buffer's undo list 5282 Look thru every buffer's undo list
5157 for elements that update markers that were not marked, 5283 for elements that update markers that were not marked,
5158 and delete them. */ 5284 and delete them. */
5159 { 5285 FOR_EACH_BUFFER (nextb)
5160 register struct buffer *nextb = all_buffers; 5286 {
5161 5287 /* If a buffer's undo list is Qt, that means that undo is
5162 while (nextb) 5288 turned off in that buffer. Calling truncate_undo_list on
5163 { 5289 Qt tends to return NULL, which effectively turns undo back on.
5164 /* If a buffer's undo list is Qt, that means that undo is 5290 So don't call truncate_undo_list if undo_list is Qt. */
5165 turned off in that buffer. Calling truncate_undo_list on 5291 if (! EQ (nextb->INTERNAL_FIELD (undo_list), Qt))
5166 Qt tends to return NULL, which effectively turns undo back on. 5292 {
5167 So don't call truncate_undo_list if undo_list is Qt. */ 5293 Lisp_Object tail, prev;
5168 if (! EQ (nextb->BUFFER_INTERNAL_FIELD (undo_list), Qt)) 5294 tail = nextb->INTERNAL_FIELD (undo_list);
5169 { 5295 prev = Qnil;
5170 Lisp_Object tail, prev; 5296 while (CONSP (tail))
5171 tail = nextb->BUFFER_INTERNAL_FIELD (undo_list); 5297 {
5172 prev = Qnil; 5298 if (CONSP (XCAR (tail))
5173 while (CONSP (tail)) 5299 && MARKERP (XCAR (XCAR (tail)))
5174 { 5300 && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
5175 if (CONSP (XCAR (tail)) 5301 {
5176 && MARKERP (XCAR (XCAR (tail))) 5302 if (NILP (prev))
5177 && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit) 5303 nextb->INTERNAL_FIELD (undo_list) = tail = XCDR (tail);
5178 { 5304 else
5179 if (NILP (prev)) 5305 {
5180 nextb->BUFFER_INTERNAL_FIELD (undo_list) = tail = XCDR (tail); 5306 tail = XCDR (tail);
5181 else 5307 XSETCDR (prev, tail);
5182 { 5308 }
5183 tail = XCDR (tail); 5309 }
5184 XSETCDR (prev, tail); 5310 else
5185 } 5311 {
5186 } 5312 prev = tail;
5187 else 5313 tail = XCDR (tail);
5188 { 5314 }
5189 prev = tail; 5315 }
5190 tail = XCDR (tail); 5316 }
5191 } 5317 /* Now that we have stripped the elements that need not be in the
5192 } 5318 undo_list any more, we can finally mark the list. */
5193 } 5319 mark_object (nextb->INTERNAL_FIELD (undo_list));
5194 /* Now that we have stripped the elements that need not be in the 5320 }
5195 undo_list any more, we can finally mark the list. */
5196 mark_object (nextb->BUFFER_INTERNAL_FIELD (undo_list));
5197
5198 nextb = nextb->header.next.buffer;
5199 }
5200 }
5201 5321
5202 gc_sweep (); 5322 gc_sweep ();
5203 5323
@@ -5211,30 +5331,20 @@ returns nil, because real GC can't be done. */)
5211 dump_zombies (); 5331 dump_zombies ();
5212#endif 5332#endif
5213 5333
5214 UNBLOCK_INPUT; 5334 check_cons_list ();
5215 5335
5216 CHECK_CONS_LIST ();
5217
5218 /* clear_marks (); */
5219 gc_in_progress = 0; 5336 gc_in_progress = 0;
5220 5337
5338 unblock_input ();
5339
5221 consing_since_gc = 0; 5340 consing_since_gc = 0;
5222 if (gc_cons_threshold < 10000) 5341 if (gc_cons_threshold < GC_DEFAULT_THRESHOLD / 10)
5223 gc_cons_threshold = 10000; 5342 gc_cons_threshold = GC_DEFAULT_THRESHOLD / 10;
5224 5343
5225 gc_relative_threshold = 0; 5344 gc_relative_threshold = 0;
5226 if (FLOATP (Vgc_cons_percentage)) 5345 if (FLOATP (Vgc_cons_percentage))
5227 { /* Set gc_cons_combined_threshold. */ 5346 { /* Set gc_cons_combined_threshold. */
5228 double tot = 0; 5347 double tot = total_bytes_of_live_objects ();
5229
5230 tot += total_conses * sizeof (struct Lisp_Cons);
5231 tot += total_symbols * sizeof (struct Lisp_Symbol);
5232 tot += total_markers * sizeof (union Lisp_Misc);
5233 tot += total_string_size;
5234 tot += total_vector_size * sizeof (Lisp_Object);
5235 tot += total_floats * sizeof (struct Lisp_Float);
5236 tot += total_intervals * sizeof (struct interval);
5237 tot += total_strings * sizeof (struct Lisp_String);
5238 5348
5239 tot *= XFLOAT_DATA (Vgc_cons_percentage); 5349 tot *= XFLOAT_DATA (Vgc_cons_percentage);
5240 if (0 < tot) 5350 if (0 < tot)
@@ -5255,56 +5365,100 @@ returns nil, because real GC can't be done. */)
5255 } 5365 }
5256 5366
5257 unbind_to (count, Qnil); 5367 unbind_to (count, Qnil);
5368 {
5369 Lisp_Object total[11];
5370 int total_size = 10;
5371
5372 total[0] = list4 (Qconses, make_number (sizeof (struct Lisp_Cons)),
5373 bounded_number (total_conses),
5374 bounded_number (total_free_conses));
5375
5376 total[1] = list4 (Qsymbols, make_number (sizeof (struct Lisp_Symbol)),
5377 bounded_number (total_symbols),
5378 bounded_number (total_free_symbols));
5379
5380 total[2] = list4 (Qmiscs, make_number (sizeof (union Lisp_Misc)),
5381 bounded_number (total_markers),
5382 bounded_number (total_free_markers));
5383
5384 total[3] = list4 (Qstrings, make_number (sizeof (struct Lisp_String)),
5385 bounded_number (total_strings),
5386 bounded_number (total_free_strings));
5387
5388 total[4] = list3 (Qstring_bytes, make_number (1),
5389 bounded_number (total_string_bytes));
5258 5390
5259 total[0] = Fcons (make_number (total_conses), 5391 total[5] = list3 (Qvectors, make_number (sizeof (struct Lisp_Vector)),
5260 make_number (total_free_conses)); 5392 bounded_number (total_vectors));
5261 total[1] = Fcons (make_number (total_symbols), 5393
5262 make_number (total_free_symbols)); 5394 total[6] = list4 (Qvector_slots, make_number (word_size),
5263 total[2] = Fcons (make_number (total_markers), 5395 bounded_number (total_vector_slots),
5264 make_number (total_free_markers)); 5396 bounded_number (total_free_vector_slots));
5265 total[3] = make_number (total_string_size); 5397
5266 total[4] = make_number (total_vector_size); 5398 total[7] = list4 (Qfloats, make_number (sizeof (struct Lisp_Float)),
5267 total[5] = Fcons (make_number (total_floats), 5399 bounded_number (total_floats),
5268 make_number (total_free_floats)); 5400 bounded_number (total_free_floats));
5269 total[6] = Fcons (make_number (total_intervals), 5401
5270 make_number (total_free_intervals)); 5402 total[8] = list4 (Qintervals, make_number (sizeof (struct interval)),
5271 total[7] = Fcons (make_number (total_strings), 5403 bounded_number (total_intervals),
5272 make_number (total_free_strings)); 5404 bounded_number (total_free_intervals));
5405
5406 total[9] = list3 (Qbuffers, make_number (sizeof (struct buffer)),
5407 bounded_number (total_buffers));
5408
5409#ifdef DOUG_LEA_MALLOC
5410 total_size++;
5411 total[10] = list4 (Qheap, make_number (1024),
5412 bounded_number ((mallinfo ().uordblks + 1023) >> 10),
5413 bounded_number ((mallinfo ().fordblks + 1023) >> 10));
5414#endif
5415 retval = Flist (total_size, total);
5416 }
5273 5417
5274#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES 5418#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5275 { 5419 {
5276 /* Compute average percentage of zombies. */ 5420 /* Compute average percentage of zombies. */
5277 double nlive = 0; 5421 double nlive
5278 5422 = (total_conses + total_symbols + total_markers + total_strings
5279 for (i = 0; i < 7; ++i) 5423 + total_vectors + total_floats + total_intervals + total_buffers);
5280 if (CONSP (total[i]))
5281 nlive += XFASTINT (XCAR (total[i]));
5282 5424
5283 avg_live = (avg_live * ngcs + nlive) / (ngcs + 1); 5425 avg_live = (avg_live * ngcs + nlive) / (ngcs + 1);
5284 max_live = max (nlive, max_live); 5426 max_live = max (nlive, max_live);
5285 avg_zombies = (avg_zombies * ngcs + nzombies) / (ngcs + 1); 5427 avg_zombies = (avg_zombies * ngcs + nzombies) / (ngcs + 1);
5286 max_zombies = max (nzombies, max_zombies); 5428 max_zombies = max (nzombies, max_zombies);
5287 ++ngcs; 5429 ++ngcs;
5288 } 5430 }
5289#endif 5431#endif
5290 5432
5291 if (!NILP (Vpost_gc_hook)) 5433 if (!NILP (Vpost_gc_hook))
5292 { 5434 {
5293 int gc_count = inhibit_garbage_collection (); 5435 ptrdiff_t gc_count = inhibit_garbage_collection ();
5294 safe_run_hooks (Qpost_gc_hook); 5436 safe_run_hooks (Qpost_gc_hook);
5295 unbind_to (gc_count, Qnil); 5437 unbind_to (gc_count, Qnil);
5296 } 5438 }
5297 5439
5298 /* Accumulate statistics. */ 5440 /* Accumulate statistics. */
5299 EMACS_GET_TIME (t2);
5300 EMACS_SUB_TIME (t3, t2, t1);
5301 if (FLOATP (Vgc_elapsed)) 5441 if (FLOATP (Vgc_elapsed))
5302 Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed) + 5442 {
5303 EMACS_SECS (t3) + 5443 EMACS_TIME since_start = sub_emacs_time (current_emacs_time (), start);
5304 EMACS_USECS (t3) * 1.0e-6); 5444 Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed)
5445 + EMACS_TIME_TO_DOUBLE (since_start));
5446 }
5447
5305 gcs_done++; 5448 gcs_done++;
5306 5449
5307 return Flist (sizeof total / sizeof *total, total); 5450 /* Collect profiling data. */
5451 if (profiler_memory_running)
5452 {
5453 size_t swept = 0;
5454 size_t tot_after = total_bytes_of_live_objects ();
5455 if (tot_before > tot_after)
5456 swept = tot_before - tot_after;
5457 malloc_probe (swept);
5458 }
5459
5460 backtrace_list = backtrace.next;
5461 return retval;
5308} 5462}
5309 5463
5310 5464
@@ -5375,19 +5529,19 @@ ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE;
5375static void 5529static void
5376mark_vectorlike (struct Lisp_Vector *ptr) 5530mark_vectorlike (struct Lisp_Vector *ptr)
5377{ 5531{
5378 EMACS_INT size = ptr->header.size; 5532 ptrdiff_t size = ptr->header.size;
5379 EMACS_INT i; 5533 ptrdiff_t i;
5380 5534
5381 eassert (!VECTOR_MARKED_P (ptr)); 5535 eassert (!VECTOR_MARKED_P (ptr));
5382 VECTOR_MARK (ptr); /* Else mark it */ 5536 VECTOR_MARK (ptr); /* Else mark it. */
5383 if (size & PSEUDOVECTOR_FLAG) 5537 if (size & PSEUDOVECTOR_FLAG)
5384 size &= PSEUDOVECTOR_SIZE_MASK; 5538 size &= PSEUDOVECTOR_SIZE_MASK;
5385 5539
5386 /* Note that this size is not the memory-footprint size, but only 5540 /* Note that this size is not the memory-footprint size, but only
5387 the number of Lisp_Object fields that we should trace. 5541 the number of Lisp_Object fields that we should trace.
5388 The distinction is used e.g. by Lisp_Process which places extra 5542 The distinction is used e.g. by Lisp_Process which places extra
5389 non-Lisp_Object fields at the end of the structure. */ 5543 non-Lisp_Object fields at the end of the structure... */
5390 for (i = 0; i < size; i++) /* and then mark its elements */ 5544 for (i = 0; i < size; i++) /* ...and then mark its elements. */
5391 mark_object (ptr->contents[i]); 5545 mark_object (ptr->contents[i]);
5392} 5546}
5393 5547
@@ -5419,6 +5573,73 @@ mark_char_table (struct Lisp_Vector *ptr)
5419 } 5573 }
5420} 5574}
5421 5575
5576/* Mark the chain of overlays starting at PTR. */
5577
5578static void
5579mark_overlay (struct Lisp_Overlay *ptr)
5580{
5581 for (; ptr && !ptr->gcmarkbit; ptr = ptr->next)
5582 {
5583 ptr->gcmarkbit = 1;
5584 mark_object (ptr->start);
5585 mark_object (ptr->end);
5586 mark_object (ptr->plist);
5587 }
5588}
5589
5590/* Mark Lisp_Objects and special pointers in BUFFER. */
5591
5592static void
5593mark_buffer (struct buffer *buffer)
5594{
5595 /* This is handled much like other pseudovectors... */
5596 mark_vectorlike ((struct Lisp_Vector *) buffer);
5597
5598 /* ...but there are some buffer-specific things. */
5599
5600 MARK_INTERVAL_TREE (buffer_intervals (buffer));
5601
5602 /* For now, we just don't mark the undo_list. It's done later in
5603 a special way just before the sweep phase, and after stripping
5604 some of its elements that are not needed any more. */
5605
5606 mark_overlay (buffer->overlays_before);
5607 mark_overlay (buffer->overlays_after);
5608
5609 /* If this is an indirect buffer, mark its base buffer. */
5610 if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
5611 mark_buffer (buffer->base_buffer);
5612}
5613
5614/* Remove killed buffers or items whose car is a killed buffer from
5615 LIST, and mark other items. Return changed LIST, which is marked. */
5616
5617static Lisp_Object
5618mark_discard_killed_buffers (Lisp_Object list)
5619{
5620 Lisp_Object tail, *prev = &list;
5621
5622 for (tail = list; CONSP (tail) && !CONS_MARKED_P (XCONS (tail));
5623 tail = XCDR (tail))
5624 {
5625 Lisp_Object tem = XCAR (tail);
5626 if (CONSP (tem))
5627 tem = XCAR (tem);
5628 if (BUFFERP (tem) && !BUFFER_LIVE_P (XBUFFER (tem)))
5629 *prev = XCDR (tail);
5630 else
5631 {
5632 CONS_MARK (XCONS (tail));
5633 mark_object (XCAR (tail));
5634 prev = &XCDR_AS_LVALUE (tail);
5635 }
5636 }
5637 mark_object (tail);
5638 return list;
5639}
5640
5641/* Determine type of generic Lisp_Object and mark it accordingly. */
5642
5422void 5643void
5423mark_object (Lisp_Object arg) 5644mark_object (Lisp_Object arg)
5424{ 5645{
@@ -5451,7 +5672,7 @@ mark_object (Lisp_Object arg)
5451 do { \ 5672 do { \
5452 m = mem_find (po); \ 5673 m = mem_find (po); \
5453 if (m == MEM_NIL) \ 5674 if (m == MEM_NIL) \
5454 abort (); \ 5675 emacs_abort (); \
5455 } while (0) 5676 } while (0)
5456 5677
5457 /* Check that the object pointed to by PO is live, using predicate 5678 /* Check that the object pointed to by PO is live, using predicate
@@ -5459,7 +5680,7 @@ mark_object (Lisp_Object arg)
5459#define CHECK_LIVE(LIVEP) \ 5680#define CHECK_LIVE(LIVEP) \
5460 do { \ 5681 do { \
5461 if (!LIVEP (m, po)) \ 5682 if (!LIVEP (m, po)) \
5462 abort (); \ 5683 emacs_abort (); \
5463 } while (0) 5684 } while (0)
5464 5685
5465 /* Check both of the above conditions. */ 5686 /* Check both of the above conditions. */
@@ -5476,7 +5697,7 @@ mark_object (Lisp_Object arg)
5476 5697
5477#endif /* not GC_CHECK_MARKED_OBJECTS */ 5698#endif /* not GC_CHECK_MARKED_OBJECTS */
5478 5699
5479 switch (SWITCH_ENUM_CAST (XTYPE (obj))) 5700 switch (XTYPE (obj))
5480 { 5701 {
5481 case Lisp_String: 5702 case Lisp_String:
5482 { 5703 {
@@ -5484,99 +5705,142 @@ mark_object (Lisp_Object arg)
5484 if (STRING_MARKED_P (ptr)) 5705 if (STRING_MARKED_P (ptr))
5485 break; 5706 break;
5486 CHECK_ALLOCATED_AND_LIVE (live_string_p); 5707 CHECK_ALLOCATED_AND_LIVE (live_string_p);
5487 MARK_INTERVAL_TREE (ptr->intervals);
5488 MARK_STRING (ptr); 5708 MARK_STRING (ptr);
5709 MARK_INTERVAL_TREE (ptr->intervals);
5489#ifdef GC_CHECK_STRING_BYTES 5710#ifdef GC_CHECK_STRING_BYTES
5490 /* Check that the string size recorded in the string is the 5711 /* Check that the string size recorded in the string is the
5491 same as the one recorded in the sdata structure. */ 5712 same as the one recorded in the sdata structure. */
5492 CHECK_STRING_BYTES (ptr); 5713 string_bytes (ptr);
5493#endif /* GC_CHECK_STRING_BYTES */ 5714#endif /* GC_CHECK_STRING_BYTES */
5494 } 5715 }
5495 break; 5716 break;
5496 5717
5497 case Lisp_Vectorlike: 5718 case Lisp_Vectorlike:
5498 if (VECTOR_MARKED_P (XVECTOR (obj))) 5719 {
5499 break; 5720 register struct Lisp_Vector *ptr = XVECTOR (obj);
5721 register ptrdiff_t pvectype;
5722
5723 if (VECTOR_MARKED_P (ptr))
5724 break;
5725
5500#ifdef GC_CHECK_MARKED_OBJECTS 5726#ifdef GC_CHECK_MARKED_OBJECTS
5501 m = mem_find (po); 5727 m = mem_find (po);
5502 if (m == MEM_NIL && !SUBRP (obj) 5728 if (m == MEM_NIL && !SUBRP (obj))
5503 && po != &buffer_defaults 5729 emacs_abort ();
5504 && po != &buffer_local_symbols)
5505 abort ();
5506#endif /* GC_CHECK_MARKED_OBJECTS */ 5730#endif /* GC_CHECK_MARKED_OBJECTS */
5507 5731
5508 if (BUFFERP (obj)) 5732 if (ptr->header.size & PSEUDOVECTOR_FLAG)
5509 { 5733 pvectype = ((ptr->header.size & PVEC_TYPE_MASK)
5734 >> PSEUDOVECTOR_AREA_BITS);
5735 else
5736 pvectype = PVEC_NORMAL_VECTOR;
5737
5738 if (pvectype != PVEC_SUBR && pvectype != PVEC_BUFFER)
5739 CHECK_LIVE (live_vector_p);
5740
5741 switch (pvectype)
5742 {
5743 case PVEC_BUFFER:
5510#ifdef GC_CHECK_MARKED_OBJECTS 5744#ifdef GC_CHECK_MARKED_OBJECTS
5511 if (po != &buffer_defaults && po != &buffer_local_symbols)
5512 { 5745 {
5513 struct buffer *b; 5746 struct buffer *b;
5514 for (b = all_buffers; b && b != po; b = b->header.next.buffer) 5747 FOR_EACH_BUFFER (b)
5515 ; 5748 if (b == po)
5749 break;
5516 if (b == NULL) 5750 if (b == NULL)
5517 abort (); 5751 emacs_abort ();
5518 } 5752 }
5519#endif /* GC_CHECK_MARKED_OBJECTS */ 5753#endif /* GC_CHECK_MARKED_OBJECTS */
5520 mark_buffer (obj); 5754 mark_buffer ((struct buffer *) ptr);
5521 } 5755 break;
5522 else if (SUBRP (obj))
5523 break;
5524 else if (COMPILEDP (obj))
5525 /* We could treat this just like a vector, but it is better to
5526 save the COMPILED_CONSTANTS element for last and avoid
5527 recursion there. */
5528 {
5529 register struct Lisp_Vector *ptr = XVECTOR (obj);
5530 int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
5531 int i;
5532 5756
5533 CHECK_LIVE (live_vector_p); 5757 case PVEC_COMPILED:
5534 VECTOR_MARK (ptr); /* Else mark it */ 5758 { /* We could treat this just like a vector, but it is better
5535 for (i = 0; i < size; i++) /* and then mark its elements */ 5759 to save the COMPILED_CONSTANTS element for last and avoid
5760 recursion there. */
5761 int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
5762 int i;
5763
5764 VECTOR_MARK (ptr);
5765 for (i = 0; i < size; i++)
5766 if (i != COMPILED_CONSTANTS)
5767 mark_object (ptr->contents[i]);
5768 if (size > COMPILED_CONSTANTS)
5769 {
5770 obj = ptr->contents[COMPILED_CONSTANTS];
5771 goto loop;
5772 }
5773 }
5774 break;
5775
5776 case PVEC_FRAME:
5777 mark_vectorlike (ptr);
5778 mark_face_cache (((struct frame *) ptr)->face_cache);
5779 break;
5780
5781 case PVEC_WINDOW:
5536 { 5782 {
5537 if (i != COMPILED_CONSTANTS) 5783 struct window *w = (struct window *) ptr;
5538 mark_object (ptr->contents[i]); 5784 bool leaf = NILP (w->hchild) && NILP (w->vchild);
5785
5786 mark_vectorlike (ptr);
5787
5788 /* Mark glyphs for leaf windows. Marking window
5789 matrices is sufficient because frame matrices
5790 use the same glyph memory. */
5791 if (leaf && w->current_matrix)
5792 {
5793 mark_glyph_matrix (w->current_matrix);
5794 mark_glyph_matrix (w->desired_matrix);
5795 }
5796
5797 /* Filter out killed buffers from both buffer lists
5798 in attempt to help GC to reclaim killed buffers faster.
5799 We can do it elsewhere for live windows, but this is the
5800 best place to do it for dead windows. */
5801 wset_prev_buffers
5802 (w, mark_discard_killed_buffers (w->prev_buffers));
5803 wset_next_buffers
5804 (w, mark_discard_killed_buffers (w->next_buffers));
5539 } 5805 }
5540 obj = ptr->contents[COMPILED_CONSTANTS]; 5806 break;
5541 goto loop; 5807
5542 } 5808 case PVEC_HASH_TABLE:
5543 else if (FRAMEP (obj))
5544 {
5545 register struct frame *ptr = XFRAME (obj);
5546 mark_vectorlike (XVECTOR (obj));
5547 mark_face_cache (ptr->face_cache);
5548 }
5549 else if (WINDOWP (obj))
5550 {
5551 register struct Lisp_Vector *ptr = XVECTOR (obj);
5552 struct window *w = XWINDOW (obj);
5553 mark_vectorlike (ptr);
5554 /* Mark glyphs for leaf windows. Marking window matrices is
5555 sufficient because frame matrices use the same glyph
5556 memory. */
5557 if (NILP (w->hchild)
5558 && NILP (w->vchild)
5559 && w->current_matrix)
5560 { 5809 {
5561 mark_glyph_matrix (w->current_matrix); 5810 struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *) ptr;
5562 mark_glyph_matrix (w->desired_matrix); 5811
5812 mark_vectorlike (ptr);
5813 mark_object (h->test.name);
5814 mark_object (h->test.user_hash_function);
5815 mark_object (h->test.user_cmp_function);
5816 /* If hash table is not weak, mark all keys and values.
5817 For weak tables, mark only the vector. */
5818 if (NILP (h->weak))
5819 mark_object (h->key_and_value);
5820 else
5821 VECTOR_MARK (XVECTOR (h->key_and_value));
5563 } 5822 }
5564 } 5823 break;
5565 else if (HASH_TABLE_P (obj)) 5824
5566 { 5825 case PVEC_CHAR_TABLE:
5567 struct Lisp_Hash_Table *h = XHASH_TABLE (obj); 5826 mark_char_table (ptr);
5568 mark_vectorlike ((struct Lisp_Vector *)h); 5827 break;
5569 /* If hash table is not weak, mark all keys and values. 5828
5570 For weak tables, mark only the vector. */ 5829 case PVEC_BOOL_VECTOR:
5571 if (NILP (h->weak)) 5830 /* No Lisp_Objects to mark in a bool vector. */
5572 mark_object (h->key_and_value); 5831 VECTOR_MARK (ptr);
5573 else 5832 break;
5574 VECTOR_MARK (XVECTOR (h->key_and_value)); 5833
5575 } 5834 case PVEC_SUBR:
5576 else if (CHAR_TABLE_P (obj)) 5835 break;
5577 mark_char_table (XVECTOR (obj)); 5836
5578 else 5837 case PVEC_FREE:
5579 mark_vectorlike (XVECTOR (obj)); 5838 emacs_abort ();
5839
5840 default:
5841 mark_vectorlike (ptr);
5842 }
5843 }
5580 break; 5844 break;
5581 5845
5582 case Lisp_Symbol: 5846 case Lisp_Symbol:
@@ -5603,10 +5867,14 @@ mark_object (Lisp_Object arg)
5603 case SYMBOL_LOCALIZED: 5867 case SYMBOL_LOCALIZED:
5604 { 5868 {
5605 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr); 5869 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
5606 /* If the value is forwarded to a buffer or keyboard field, 5870 Lisp_Object where = blv->where;
5607 these are marked when we see the corresponding object. 5871 /* If the value is set up for a killed buffer or deleted
5608 And if it's forwarded to a C variable, either it's not 5872 frame, restore it's global binding. If the value is
5609 a Lisp_Object var, or it's staticpro'd already. */ 5873 forwarded to a C variable, either it's not a Lisp_Object
5874 var, or it's staticpro'd already. */
5875 if ((BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where)))
5876 || (FRAMEP (where) && !FRAME_LIVE_P (XFRAME (where))))
5877 swap_in_global_binding (ptr);
5610 mark_object (blv->where); 5878 mark_object (blv->where);
5611 mark_object (blv->valcell); 5879 mark_object (blv->valcell);
5612 mark_object (blv->defcell); 5880 mark_object (blv->defcell);
@@ -5618,16 +5886,16 @@ mark_object (Lisp_Object arg)
5618 And if it's forwarded to a C variable, either it's not 5886 And if it's forwarded to a C variable, either it's not
5619 a Lisp_Object var, or it's staticpro'd already. */ 5887 a Lisp_Object var, or it's staticpro'd already. */
5620 break; 5888 break;
5621 default: abort (); 5889 default: emacs_abort ();
5622 } 5890 }
5623 if (!PURE_POINTER_P (XSTRING (ptr->xname))) 5891 if (!PURE_POINTER_P (XSTRING (ptr->name)))
5624 MARK_STRING (XSTRING (ptr->xname)); 5892 MARK_STRING (XSTRING (ptr->name));
5625 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname)); 5893 MARK_INTERVAL_TREE (string_intervals (ptr->name));
5626 5894
5627 ptr = ptr->next; 5895 ptr = ptr->next;
5628 if (ptr) 5896 if (ptr)
5629 { 5897 {
5630 ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun */ 5898 ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun. */
5631 XSETSYMBOL (obj, ptrx); 5899 XSETSYMBOL (obj, ptrx);
5632 goto loop; 5900 goto loop;
5633 } 5901 }
@@ -5636,20 +5904,21 @@ mark_object (Lisp_Object arg)
5636 5904
5637 case Lisp_Misc: 5905 case Lisp_Misc:
5638 CHECK_ALLOCATED_AND_LIVE (live_misc_p); 5906 CHECK_ALLOCATED_AND_LIVE (live_misc_p);
5907
5639 if (XMISCANY (obj)->gcmarkbit) 5908 if (XMISCANY (obj)->gcmarkbit)
5640 break; 5909 break;
5641 XMISCANY (obj)->gcmarkbit = 1;
5642 5910
5643 switch (XMISCTYPE (obj)) 5911 switch (XMISCTYPE (obj))
5644 { 5912 {
5645
5646 case Lisp_Misc_Marker: 5913 case Lisp_Misc_Marker:
5647 /* DO NOT mark thru the marker's chain. 5914 /* DO NOT mark thru the marker's chain.
5648 The buffer's markers chain does not preserve markers from gc; 5915 The buffer's markers chain does not preserve markers from gc;
5649 instead, markers are removed from the chain when freed by gc. */ 5916 instead, markers are removed from the chain when freed by gc. */
5917 XMISCANY (obj)->gcmarkbit = 1;
5650 break; 5918 break;
5651 5919
5652 case Lisp_Misc_Save_Value: 5920 case Lisp_Misc_Save_Value:
5921 XMISCANY (obj)->gcmarkbit = 1;
5653#if GC_MARK_STACK 5922#if GC_MARK_STACK
5654 { 5923 {
5655 register struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj); 5924 register struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj);
@@ -5667,21 +5936,11 @@ mark_object (Lisp_Object arg)
5667 break; 5936 break;
5668 5937
5669 case Lisp_Misc_Overlay: 5938 case Lisp_Misc_Overlay:
5670 { 5939 mark_overlay (XOVERLAY (obj));
5671 struct Lisp_Overlay *ptr = XOVERLAY (obj);
5672 mark_object (ptr->start);
5673 mark_object (ptr->end);
5674 mark_object (ptr->plist);
5675 if (ptr->next)
5676 {
5677 XSETMISC (obj, ptr->next);
5678 goto loop;
5679 }
5680 }
5681 break; 5940 break;
5682 5941
5683 default: 5942 default:
5684 abort (); 5943 emacs_abort ();
5685 } 5944 }
5686 break; 5945 break;
5687 5946
@@ -5703,7 +5962,7 @@ mark_object (Lisp_Object arg)
5703 obj = ptr->u.cdr; 5962 obj = ptr->u.cdr;
5704 cdr_count++; 5963 cdr_count++;
5705 if (cdr_count == mark_object_loop_halt) 5964 if (cdr_count == mark_object_loop_halt)
5706 abort (); 5965 emacs_abort ();
5707 goto loop; 5966 goto loop;
5708 } 5967 }
5709 5968
@@ -5716,61 +5975,15 @@ mark_object (Lisp_Object arg)
5716 break; 5975 break;
5717 5976
5718 default: 5977 default:
5719 abort (); 5978 emacs_abort ();
5720 } 5979 }
5721 5980
5722#undef CHECK_LIVE 5981#undef CHECK_LIVE
5723#undef CHECK_ALLOCATED 5982#undef CHECK_ALLOCATED
5724#undef CHECK_ALLOCATED_AND_LIVE 5983#undef CHECK_ALLOCATED_AND_LIVE
5725} 5984}
5726
5727/* Mark the pointers in a buffer structure. */
5728
5729static void
5730mark_buffer (Lisp_Object buf)
5731{
5732 register struct buffer *buffer = XBUFFER (buf);
5733 register Lisp_Object *ptr, tmp;
5734 Lisp_Object base_buffer;
5735
5736 eassert (!VECTOR_MARKED_P (buffer));
5737 VECTOR_MARK (buffer);
5738
5739 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
5740
5741 /* For now, we just don't mark the undo_list. It's done later in
5742 a special way just before the sweep phase, and after stripping
5743 some of its elements that are not needed any more. */
5744
5745 if (buffer->overlays_before)
5746 {
5747 XSETMISC (tmp, buffer->overlays_before);
5748 mark_object (tmp);
5749 }
5750 if (buffer->overlays_after)
5751 {
5752 XSETMISC (tmp, buffer->overlays_after);
5753 mark_object (tmp);
5754 }
5755
5756 /* buffer-local Lisp variables start at `undo_list',
5757 tho only the ones from `name' on are GC'd normally. */
5758 for (ptr = &buffer->BUFFER_INTERNAL_FIELD (name);
5759 ptr <= &PER_BUFFER_VALUE (buffer,
5760 PER_BUFFER_VAR_OFFSET (LAST_FIELD_PER_BUFFER));
5761 ptr++)
5762 mark_object (*ptr);
5763
5764 /* If this is an indirect buffer, mark its base buffer. */
5765 if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
5766 {
5767 XSETBUFFER (base_buffer, buffer->base_buffer);
5768 mark_buffer (base_buffer);
5769 }
5770}
5771
5772/* Mark the Lisp pointers in the terminal objects. 5985/* Mark the Lisp pointers in the terminal objects.
5773 Called by the Fgarbage_collector. */ 5986 Called by Fgarbage_collect. */
5774 5987
5775static void 5988static void
5776mark_terminals (void) 5989mark_terminals (void)
@@ -5795,10 +6008,10 @@ mark_terminals (void)
5795/* Value is non-zero if OBJ will survive the current GC because it's 6008/* Value is non-zero if OBJ will survive the current GC because it's
5796 either marked or does not need to be marked to survive. */ 6009 either marked or does not need to be marked to survive. */
5797 6010
5798int 6011bool
5799survives_gc_p (Lisp_Object obj) 6012survives_gc_p (Lisp_Object obj)
5800{ 6013{
5801 int survives_p; 6014 bool survives_p;
5802 6015
5803 switch (XTYPE (obj)) 6016 switch (XTYPE (obj))
5804 { 6017 {
@@ -5831,7 +6044,7 @@ survives_gc_p (Lisp_Object obj)
5831 break; 6044 break;
5832 6045
5833 default: 6046 default:
5834 abort (); 6047 emacs_abort ();
5835 } 6048 }
5836 6049
5837 return survives_p || PURE_POINTER_P ((void *) XPNTR (obj)); 6050 return survives_p || PURE_POINTER_P ((void *) XPNTR (obj));
@@ -5849,10 +6062,7 @@ gc_sweep (void)
5849 sweep_weak_hash_tables (); 6062 sweep_weak_hash_tables ();
5850 6063
5851 sweep_strings (); 6064 sweep_strings ();
5852#ifdef GC_CHECK_STRING_BYTES 6065 check_string_bytes (!noninteractive);
5853 if (!noninteractive)
5854 check_string_bytes (1);
5855#endif
5856 6066
5857 /* Put all unmarked conses on free list */ 6067 /* Put all unmarked conses on free list */
5858 { 6068 {
@@ -5995,7 +6205,7 @@ gc_sweep (void)
5995 { 6205 {
5996 if (!iblk->intervals[i].gcmarkbit) 6206 if (!iblk->intervals[i].gcmarkbit)
5997 { 6207 {
5998 SET_INTERVAL_PARENT (&iblk->intervals[i], interval_free_list); 6208 set_interval_parent (&iblk->intervals[i], interval_free_list);
5999 interval_free_list = &iblk->intervals[i]; 6209 interval_free_list = &iblk->intervals[i];
6000 this_free++; 6210 this_free++;
6001 } 6211 }
@@ -6038,22 +6248,22 @@ gc_sweep (void)
6038 for (sblk = symbol_block; sblk; sblk = *sprev) 6248 for (sblk = symbol_block; sblk; sblk = *sprev)
6039 { 6249 {
6040 int this_free = 0; 6250 int this_free = 0;
6041 struct Lisp_Symbol *sym = sblk->symbols; 6251 union aligned_Lisp_Symbol *sym = sblk->symbols;
6042 struct Lisp_Symbol *end = sym + lim; 6252 union aligned_Lisp_Symbol *end = sym + lim;
6043 6253
6044 for (; sym < end; ++sym) 6254 for (; sym < end; ++sym)
6045 { 6255 {
6046 /* Check if the symbol was created during loadup. In such a case 6256 /* Check if the symbol was created during loadup. In such a case
6047 it might be pointed to by pure bytecode which we don't trace, 6257 it might be pointed to by pure bytecode which we don't trace,
6048 so we conservatively assume that it is live. */ 6258 so we conservatively assume that it is live. */
6049 int pure_p = PURE_POINTER_P (XSTRING (sym->xname)); 6259 bool pure_p = PURE_POINTER_P (XSTRING (sym->s.name));
6050 6260
6051 if (!sym->gcmarkbit && !pure_p) 6261 if (!sym->s.gcmarkbit && !pure_p)
6052 { 6262 {
6053 if (sym->redirect == SYMBOL_LOCALIZED) 6263 if (sym->s.redirect == SYMBOL_LOCALIZED)
6054 xfree (SYMBOL_BLV (sym)); 6264 xfree (SYMBOL_BLV (&sym->s));
6055 sym->next = symbol_free_list; 6265 sym->s.next = symbol_free_list;
6056 symbol_free_list = sym; 6266 symbol_free_list = &sym->s;
6057#if GC_MARK_STACK 6267#if GC_MARK_STACK
6058 symbol_free_list->function = Vdead; 6268 symbol_free_list->function = Vdead;
6059#endif 6269#endif
@@ -6063,8 +6273,8 @@ gc_sweep (void)
6063 { 6273 {
6064 ++num_used; 6274 ++num_used;
6065 if (!pure_p) 6275 if (!pure_p)
6066 UNMARK_STRING (XSTRING (sym->xname)); 6276 UNMARK_STRING (XSTRING (sym->s.name));
6067 sym->gcmarkbit = 0; 6277 sym->s.gcmarkbit = 0;
6068 } 6278 }
6069 } 6279 }
6070 6280
@@ -6076,7 +6286,7 @@ gc_sweep (void)
6076 { 6286 {
6077 *sprev = sblk->next; 6287 *sprev = sblk->next;
6078 /* Unhook from the free list. */ 6288 /* Unhook from the free list. */
6079 symbol_free_list = sblk->symbols[0].next; 6289 symbol_free_list = sblk->symbols[0].s.next;
6080 lisp_free (sblk); 6290 lisp_free (sblk);
6081 } 6291 }
6082 else 6292 else
@@ -6106,22 +6316,22 @@ gc_sweep (void)
6106 6316
6107 for (i = 0; i < lim; i++) 6317 for (i = 0; i < lim; i++)
6108 { 6318 {
6109 if (!mblk->markers[i].u_any.gcmarkbit) 6319 if (!mblk->markers[i].m.u_any.gcmarkbit)
6110 { 6320 {
6111 if (mblk->markers[i].u_any.type == Lisp_Misc_Marker) 6321 if (mblk->markers[i].m.u_any.type == Lisp_Misc_Marker)
6112 unchain_marker (&mblk->markers[i].u_marker); 6322 unchain_marker (&mblk->markers[i].m.u_marker);
6113 /* Set the type of the freed object to Lisp_Misc_Free. 6323 /* Set the type of the freed object to Lisp_Misc_Free.
6114 We could leave the type alone, since nobody checks it, 6324 We could leave the type alone, since nobody checks it,
6115 but this might catch bugs faster. */ 6325 but this might catch bugs faster. */
6116 mblk->markers[i].u_marker.type = Lisp_Misc_Free; 6326 mblk->markers[i].m.u_marker.type = Lisp_Misc_Free;
6117 mblk->markers[i].u_free.chain = marker_free_list; 6327 mblk->markers[i].m.u_free.chain = marker_free_list;
6118 marker_free_list = &mblk->markers[i]; 6328 marker_free_list = &mblk->markers[i].m;
6119 this_free++; 6329 this_free++;
6120 } 6330 }
6121 else 6331 else
6122 { 6332 {
6123 num_used++; 6333 num_used++;
6124 mblk->markers[i].u_any.gcmarkbit = 0; 6334 mblk->markers[i].m.u_any.gcmarkbit = 0;
6125 } 6335 }
6126 } 6336 }
6127 lim = MARKER_BLOCK_SIZE; 6337 lim = MARKER_BLOCK_SIZE;
@@ -6132,7 +6342,7 @@ gc_sweep (void)
6132 { 6342 {
6133 *mprev = mblk->next; 6343 *mprev = mblk->next;
6134 /* Unhook from the free list. */ 6344 /* Unhook from the free list. */
6135 marker_free_list = mblk->markers[0].u_free.chain; 6345 marker_free_list = mblk->markers[0].m.u_free.chain;
6136 lisp_free (mblk); 6346 lisp_free (mblk);
6137 } 6347 }
6138 else 6348 else
@@ -6148,59 +6358,27 @@ gc_sweep (void)
6148 6358
6149 /* Free all unmarked buffers */ 6359 /* Free all unmarked buffers */
6150 { 6360 {
6151 register struct buffer *buffer = all_buffers, *prev = 0, *next; 6361 register struct buffer *buffer, **bprev = &all_buffers;
6152 6362
6153 while (buffer) 6363 total_buffers = 0;
6364 for (buffer = all_buffers; buffer; buffer = *bprev)
6154 if (!VECTOR_MARKED_P (buffer)) 6365 if (!VECTOR_MARKED_P (buffer))
6155 { 6366 {
6156 if (prev) 6367 *bprev = buffer->next;
6157 prev->header.next = buffer->header.next;
6158 else
6159 all_buffers = buffer->header.next.buffer;
6160 next = buffer->header.next.buffer;
6161 lisp_free (buffer); 6368 lisp_free (buffer);
6162 buffer = next;
6163 } 6369 }
6164 else 6370 else
6165 { 6371 {
6166 VECTOR_UNMARK (buffer); 6372 VECTOR_UNMARK (buffer);
6167 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer)); 6373 /* Do not use buffer_(set|get)_intervals here. */
6168 prev = buffer, buffer = buffer->header.next.buffer; 6374 buffer->text->intervals = balance_intervals (buffer->text->intervals);
6375 total_buffers++;
6376 bprev = &buffer->next;
6169 } 6377 }
6170 } 6378 }
6171 6379
6172 /* Free all unmarked vectors */ 6380 sweep_vectors ();
6173 { 6381 check_string_bytes (!noninteractive);
6174 register struct Lisp_Vector *vector = all_vectors, *prev = 0, *next;
6175 total_vector_size = 0;
6176
6177 while (vector)
6178 if (!VECTOR_MARKED_P (vector))
6179 {
6180 if (prev)
6181 prev->header.next = vector->header.next;
6182 else
6183 all_vectors = vector->header.next.vector;
6184 next = vector->header.next.vector;
6185 lisp_free (vector);
6186 vector = next;
6187
6188 }
6189 else
6190 {
6191 VECTOR_UNMARK (vector);
6192 if (vector->header.size & PSEUDOVECTOR_FLAG)
6193 total_vector_size += PSEUDOVECTOR_SIZE_MASK & vector->header.size;
6194 else
6195 total_vector_size += vector->header.size;
6196 prev = vector, vector = vector->header.next.vector;
6197 }
6198 }
6199
6200#ifdef GC_CHECK_STRING_BYTES
6201 if (!noninteractive)
6202 check_string_bytes (1);
6203#endif
6204} 6382}
6205 6383
6206 6384
@@ -6236,18 +6414,15 @@ Frames, windows, buffers, and subprocesses count as vectors
6236 (but the contents of a buffer's text do not count here). */) 6414 (but the contents of a buffer's text do not count here). */)
6237 (void) 6415 (void)
6238{ 6416{
6239 Lisp_Object consed[8]; 6417 return listn (CONSTYPE_HEAP, 8,
6240 6418 bounded_number (cons_cells_consed),
6241 consed[0] = make_number (min (MOST_POSITIVE_FIXNUM, cons_cells_consed)); 6419 bounded_number (floats_consed),
6242 consed[1] = make_number (min (MOST_POSITIVE_FIXNUM, floats_consed)); 6420 bounded_number (vector_cells_consed),
6243 consed[2] = make_number (min (MOST_POSITIVE_FIXNUM, vector_cells_consed)); 6421 bounded_number (symbols_consed),
6244 consed[3] = make_number (min (MOST_POSITIVE_FIXNUM, symbols_consed)); 6422 bounded_number (string_chars_consed),
6245 consed[4] = make_number (min (MOST_POSITIVE_FIXNUM, string_chars_consed)); 6423 bounded_number (misc_objects_consed),
6246 consed[5] = make_number (min (MOST_POSITIVE_FIXNUM, misc_objects_consed)); 6424 bounded_number (intervals_consed),
6247 consed[6] = make_number (min (MOST_POSITIVE_FIXNUM, intervals_consed)); 6425 bounded_number (strings_consed));
6248 consed[7] = make_number (min (MOST_POSITIVE_FIXNUM, strings_consed));
6249
6250 return Flist (8, consed);
6251} 6426}
6252 6427
6253/* Find at most FIND_MAX symbols which have OBJ as their value or 6428/* Find at most FIND_MAX symbols which have OBJ as their value or
@@ -6257,18 +6432,19 @@ Lisp_Object
6257which_symbols (Lisp_Object obj, EMACS_INT find_max) 6432which_symbols (Lisp_Object obj, EMACS_INT find_max)
6258{ 6433{
6259 struct symbol_block *sblk; 6434 struct symbol_block *sblk;
6260 int gc_count = inhibit_garbage_collection (); 6435 ptrdiff_t gc_count = inhibit_garbage_collection ();
6261 Lisp_Object found = Qnil; 6436 Lisp_Object found = Qnil;
6262 6437
6263 if (! DEADP (obj)) 6438 if (! DEADP (obj))
6264 { 6439 {
6265 for (sblk = symbol_block; sblk; sblk = sblk->next) 6440 for (sblk = symbol_block; sblk; sblk = sblk->next)
6266 { 6441 {
6267 struct Lisp_Symbol *sym = sblk->symbols; 6442 union aligned_Lisp_Symbol *aligned_sym = sblk->symbols;
6268 int bn; 6443 int bn;
6269 6444
6270 for (bn = 0; bn < SYMBOL_BLOCK_SIZE; bn++, sym++) 6445 for (bn = 0; bn < SYMBOL_BLOCK_SIZE; bn++, aligned_sym++)
6271 { 6446 {
6447 struct Lisp_Symbol *sym = &aligned_sym->s;
6272 Lisp_Object val; 6448 Lisp_Object val;
6273 Lisp_Object tem; 6449 Lisp_Object tem;
6274 6450
@@ -6300,14 +6476,15 @@ which_symbols (Lisp_Object obj, EMACS_INT find_max)
6300} 6476}
6301 6477
6302#ifdef ENABLE_CHECKING 6478#ifdef ENABLE_CHECKING
6303int suppress_checking; 6479
6480bool suppress_checking;
6304 6481
6305void 6482void
6306die (const char *msg, const char *file, int line) 6483die (const char *msg, const char *file, int line)
6307{ 6484{
6308 fprintf (stderr, "\r\n%s:%d: Emacs fatal error: %s\r\n", 6485 fprintf (stderr, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6309 file, line, msg); 6486 file, line, msg);
6310 abort (); 6487 terminate_due_to_signal (SIGABRT, INT_MAX);
6311} 6488}
6312#endif 6489#endif
6313 6490
@@ -6319,48 +6496,22 @@ init_alloc_once (void)
6319 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */ 6496 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6320 purebeg = PUREBEG; 6497 purebeg = PUREBEG;
6321 pure_size = PURESIZE; 6498 pure_size = PURESIZE;
6322 pure_bytes_used = 0;
6323 pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
6324 pure_bytes_used_before_overflow = 0;
6325
6326 /* Initialize the list of free aligned blocks. */
6327 free_ablock = NULL;
6328 6499
6329#if GC_MARK_STACK || defined GC_MALLOC_CHECK 6500#if GC_MARK_STACK || defined GC_MALLOC_CHECK
6330 mem_init (); 6501 mem_init ();
6331 Vdead = make_pure_string ("DEAD", 4, 4, 0); 6502 Vdead = make_pure_string ("DEAD", 4, 4, 0);
6332#endif 6503#endif
6333 6504
6334 all_vectors = 0;
6335 ignore_warnings = 1;
6336#ifdef DOUG_LEA_MALLOC 6505#ifdef DOUG_LEA_MALLOC
6337 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */ 6506 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
6338 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */ 6507 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
6339 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* max. number of mmap'ed areas */ 6508 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* max. number of mmap'ed areas */
6340#endif 6509#endif
6341 init_strings (); 6510 init_strings ();
6342 init_cons (); 6511 init_vectors ();
6343 init_symbol ();
6344 init_marker ();
6345 init_float ();
6346 init_intervals ();
6347 init_weak_hash_tables ();
6348
6349#ifdef REL_ALLOC
6350 malloc_hysteresis = 32;
6351#else
6352 malloc_hysteresis = 0;
6353#endif
6354 6512
6355 refill_memory_reserve (); 6513 refill_memory_reserve ();
6356 6514 gc_cons_threshold = GC_DEFAULT_THRESHOLD;
6357 ignore_warnings = 0;
6358 gcprolist = 0;
6359 byte_stack_list = 0;
6360 staticidx = 0;
6361 consing_since_gc = 0;
6362 gc_cons_threshold = 100000 * sizeof (Lisp_Object);
6363 gc_relative_threshold = 0;
6364} 6515}
6365 6516
6366void 6517void
@@ -6381,7 +6532,7 @@ void
6381syms_of_alloc (void) 6532syms_of_alloc (void)
6382{ 6533{
6383 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold, 6534 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold,
6384 doc: /* *Number of bytes of consing between garbage collections. 6535 doc: /* Number of bytes of consing between garbage collections.
6385Garbage collection can happen automatically once this many bytes have been 6536Garbage collection can happen automatically once this many bytes have been
6386allocated since the last garbage collection. All data types count. 6537allocated since the last garbage collection. All data types count.
6387 6538
@@ -6392,7 +6543,7 @@ prevent garbage collection during a part of the program.
6392See also `gc-cons-percentage'. */); 6543See also `gc-cons-percentage'. */);
6393 6544
6394 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage, 6545 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage,
6395 doc: /* *Portion of the heap used for allocation. 6546 doc: /* Portion of the heap used for allocation.
6396Garbage collection can happen automatically once this portion of the heap 6547Garbage collection can happen automatically once this portion of the heap
6397has been allocated since the last garbage collection. 6548has been allocated since the last garbage collection.
6398If this portion is smaller than `gc-cons-threshold', this is ignored. */); 6549If this portion is smaller than `gc-cons-threshold', this is ignored. */);
@@ -6417,7 +6568,9 @@ If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6417 doc: /* Number of string characters that have been consed so far. */); 6568 doc: /* Number of string characters that have been consed so far. */);
6418 6569
6419 DEFVAR_INT ("misc-objects-consed", misc_objects_consed, 6570 DEFVAR_INT ("misc-objects-consed", misc_objects_consed,
6420 doc: /* Number of miscellaneous objects that have been consed so far. */); 6571 doc: /* Number of miscellaneous objects that have been consed so far.
6572These include markers and overlays, plus certain objects not visible
6573to users. */);
6421 6574
6422 DEFVAR_INT ("intervals-consed", intervals_consed, 6575 DEFVAR_INT ("intervals-consed", intervals_consed,
6423 doc: /* Number of intervals that have been consed so far. */); 6576 doc: /* Number of intervals that have been consed so far. */);
@@ -6445,13 +6598,26 @@ do hash-consing of the objects allocated to pure space. */);
6445 /* We build this in advance because if we wait until we need it, we might 6598 /* We build this in advance because if we wait until we need it, we might
6446 not be able to allocate the memory to hold it. */ 6599 not be able to allocate the memory to hold it. */
6447 Vmemory_signal_data 6600 Vmemory_signal_data
6448 = pure_cons (Qerror, 6601 = listn (CONSTYPE_PURE, 2, Qerror,
6449 pure_cons (make_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil)); 6602 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6450 6603
6451 DEFVAR_LISP ("memory-full", Vmemory_full, 6604 DEFVAR_LISP ("memory-full", Vmemory_full,
6452 doc: /* Non-nil means Emacs cannot get much more Lisp memory. */); 6605 doc: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6453 Vmemory_full = Qnil; 6606 Vmemory_full = Qnil;
6454 6607
6608 DEFSYM (Qconses, "conses");
6609 DEFSYM (Qsymbols, "symbols");
6610 DEFSYM (Qmiscs, "miscs");
6611 DEFSYM (Qstrings, "strings");
6612 DEFSYM (Qvectors, "vectors");
6613 DEFSYM (Qfloats, "floats");
6614 DEFSYM (Qintervals, "intervals");
6615 DEFSYM (Qbuffers, "buffers");
6616 DEFSYM (Qstring_bytes, "string-bytes");
6617 DEFSYM (Qvector_slots, "vector-slots");
6618 DEFSYM (Qheap, "heap");
6619 DEFSYM (Qautomatic_gc, "Automatic GC");
6620
6455 DEFSYM (Qgc_cons_threshold, "gc-cons-threshold"); 6621 DEFSYM (Qgc_cons_threshold, "gc-cons-threshold");
6456 DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots"); 6622 DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots");
6457 6623
@@ -6480,3 +6646,29 @@ The time is in seconds as a floating point value. */);
6480 defsubr (&Sgc_status); 6646 defsubr (&Sgc_status);
6481#endif 6647#endif
6482} 6648}
6649
6650/* When compiled with GCC, GDB might say "No enum type named
6651 pvec_type" if we don't have at least one symbol with that type, and
6652 then xbacktrace could fail. Similarly for the other enums and
6653 their values. Some non-GCC compilers don't like these constructs. */
6654#ifdef __GNUC__
6655union
6656{
6657 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS;
6658 enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS;
6659 enum char_bits char_bits;
6660 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE;
6661 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE;
6662 enum enum_USE_LSB_TAG enum_USE_LSB_TAG;
6663 enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE;
6664 enum Lisp_Bits Lisp_Bits;
6665 enum Lisp_Compiled Lisp_Compiled;
6666 enum maxargs maxargs;
6667 enum MAX_ALLOCA MAX_ALLOCA;
6668 enum More_Lisp_Bits More_Lisp_Bits;
6669 enum pvec_type pvec_type;
6670#if USE_LSB_TAG
6671 enum lsb_bits lsb_bits;
6672#endif
6673} const EXTERNALLY_VISIBLE gdb_make_enums_visible = {0};
6674#endif /* __GNUC__ */
generated by cgit v1.2.1 (git 2.18.0) at 2026-02-04 03:53:52 +0000