aboutsummaryrefslogtreecommitdiffstats
path: root/src/alloc.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/alloc.c')
-rw-r--r--src/alloc.c2964
1 files changed, 1584 insertions, 1380 deletions
diff --git a/src/alloc.c b/src/alloc.c
index cf7778c05f6..0989e63664f 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -1,7 +1,7 @@
1/* Storage allocation and gc for GNU Emacs Lisp interpreter. 1/* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 2
3Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2012 3Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 Free Software
4 Free Software Foundation, Inc. 4Foundation, Inc.
5 5
6This file is part of GNU Emacs. 6This file is part of GNU Emacs.
7 7
@@ -19,34 +19,32 @@ You should have received a copy of the GNU General Public License
19along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ 19along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
20 20
21#include <config.h> 21#include <config.h>
22
23#define LISP_INLINE EXTERN_INLINE
24
22#include <stdio.h> 25#include <stdio.h>
23#include <limits.h> /* For CHAR_BIT. */ 26#include <limits.h> /* For CHAR_BIT. */
24#include <setjmp.h>
25 27
26#include <signal.h> 28#ifdef ENABLE_CHECKING
29#include <signal.h> /* For SIGABRT. */
30#endif
27 31
28#ifdef HAVE_PTHREAD 32#ifdef HAVE_PTHREAD
29#include <pthread.h> 33#include <pthread.h>
30#endif 34#endif
31 35
32/* This file is part of the core Lisp implementation, and thus must
33 deal with the real data structures. If the Lisp implementation is
34 replaced, this file likely will not be used. */
35
36#undef HIDE_LISP_IMPLEMENTATION
37#include "lisp.h" 36#include "lisp.h"
38#include "process.h" 37#include "process.h"
39#include "intervals.h" 38#include "intervals.h"
40#include "puresize.h" 39#include "puresize.h"
40#include "character.h"
41#include "buffer.h" 41#include "buffer.h"
42#include "window.h" 42#include "window.h"
43#include "keyboard.h" 43#include "keyboard.h"
44#include "frame.h" 44#include "frame.h"
45#include "blockinput.h" 45#include "blockinput.h"
46#include "character.h"
47#include "syssignal.h"
48#include "termhooks.h" /* For struct terminal. */ 46#include "termhooks.h" /* For struct terminal. */
49#include <setjmp.h> 47
50#include <verify.h> 48#include <verify.h>
51 49
52/* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects. 50/* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
@@ -65,14 +63,14 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
65#endif 63#endif
66 64
67#include <unistd.h> 65#include <unistd.h>
68#ifndef HAVE_UNISTD_H
69extern void *sbrk ();
70#endif
71
72#include <fcntl.h> 66#include <fcntl.h>
73 67
68#ifdef USE_GTK
69# include "gtkutil.h"
70#endif
74#ifdef WINDOWSNT 71#ifdef WINDOWSNT
75#include "w32.h" 72#include "w32.h"
73#include "w32heap.h" /* for sbrk */
76#endif 74#endif
77 75
78#ifdef DOUG_LEA_MALLOC 76#ifdef DOUG_LEA_MALLOC
@@ -84,66 +82,8 @@ extern void *sbrk ();
84 82
85#define MMAP_MAX_AREAS 100000000 83#define MMAP_MAX_AREAS 100000000
86 84
87#else /* not DOUG_LEA_MALLOC */
88
89/* The following come from gmalloc.c. */
90
91extern size_t _bytes_used;
92extern size_t __malloc_extra_blocks;
93extern void *_malloc_internal (size_t);
94extern void _free_internal (void *);
95
96#endif /* not DOUG_LEA_MALLOC */ 85#endif /* not DOUG_LEA_MALLOC */
97 86
98#if ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT
99#ifdef HAVE_PTHREAD
100
101/* When GTK uses the file chooser dialog, different backends can be loaded
102 dynamically. One such a backend is the Gnome VFS backend that gets loaded
103 if you run Gnome. That backend creates several threads and also allocates
104 memory with malloc.
105
106 Also, gconf and gsettings may create several threads.
107
108 If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
109 functions below are called from malloc, there is a chance that one
110 of these threads preempts the Emacs main thread and the hook variables
111 end up in an inconsistent state. So we have a mutex to prevent that (note
112 that the backend handles concurrent access to malloc within its own threads
113 but Emacs code running in the main thread is not included in that control).
114
115 When UNBLOCK_INPUT is called, reinvoke_input_signal may be called. If this
116 happens in one of the backend threads we will have two threads that tries
117 to run Emacs code at once, and the code is not prepared for that.
118 To prevent that, we only call BLOCK/UNBLOCK from the main thread. */
119
120static pthread_mutex_t alloc_mutex;
121
122#define BLOCK_INPUT_ALLOC \
123 do \
124 { \
125 if (pthread_equal (pthread_self (), main_thread)) \
126 BLOCK_INPUT; \
127 pthread_mutex_lock (&alloc_mutex); \
128 } \
129 while (0)
130#define UNBLOCK_INPUT_ALLOC \
131 do \
132 { \
133 pthread_mutex_unlock (&alloc_mutex); \
134 if (pthread_equal (pthread_self (), main_thread)) \
135 UNBLOCK_INPUT; \
136 } \
137 while (0)
138
139#else /* ! defined HAVE_PTHREAD */
140
141#define BLOCK_INPUT_ALLOC BLOCK_INPUT
142#define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
143
144#endif /* ! defined HAVE_PTHREAD */
145#endif /* ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT */
146
147/* 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
148 to a struct Lisp_String. */ 88 to a struct Lisp_String. */
149 89
@@ -155,11 +95,9 @@ static pthread_mutex_t alloc_mutex;
155#define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG) 95#define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
156#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)
157 97
158/* Value is the number of bytes of S, a pointer to a struct Lisp_String. 98/* Default value of gc_cons_threshold (see below). */
159 Be careful during GC, because S->size contains the mark bit for
160 strings. */
161 99
162#define GC_STRING_BYTES(S) (STRING_BYTES (S)) 100#define GC_DEFAULT_THRESHOLD (100000 * word_size)
163 101
164/* Global variables. */ 102/* Global variables. */
165struct emacs_globals globals; 103struct emacs_globals globals;
@@ -177,19 +115,19 @@ EMACS_INT gc_relative_threshold;
177 115
178EMACS_INT memory_full_cons_threshold; 116EMACS_INT memory_full_cons_threshold;
179 117
180/* Nonzero during GC. */ 118/* True during GC. */
181 119
182int gc_in_progress; 120bool gc_in_progress;
183 121
184/* Nonzero means abort if try to GC. 122/* True means abort if try to GC.
185 This is for code which is written on the assumption that 123 This is for code which is written on the assumption that
186 no GC will happen, so as to verify that assumption. */ 124 no GC will happen, so as to verify that assumption. */
187 125
188int abort_on_gc; 126bool abort_on_gc;
189 127
190/* Number of live and free conses etc. */ 128/* Number of live and free conses etc. */
191 129
192static EMACS_INT total_conses, total_markers, total_symbols, total_vector_size; 130static EMACS_INT total_conses, total_markers, total_symbols, total_buffers;
193static EMACS_INT total_free_conses, total_free_markers, total_free_symbols; 131static EMACS_INT total_free_conses, total_free_markers, total_free_symbols;
194static EMACS_INT total_free_floats, total_floats; 132static EMACS_INT total_free_floats, total_floats;
195 133
@@ -204,10 +142,6 @@ static char *spare_memory[7];
204 142
205#define SPARE_MEMORY (1 << 14) 143#define SPARE_MEMORY (1 << 14)
206 144
207/* Number of extra blocks malloc should get when it needs more core. */
208
209static int malloc_hysteresis;
210
211/* 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
212 (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
213 space (pure), on some systems. We have not implemented the 147 space (pure), on some systems. We have not implemented the
@@ -227,12 +161,12 @@ static ptrdiff_t pure_size;
227 161
228static ptrdiff_t pure_bytes_used_before_overflow; 162static ptrdiff_t pure_bytes_used_before_overflow;
229 163
230/* Value is non-zero if P points into pure space. */ 164/* True if P points into pure space. */
231 165
232#define PURE_POINTER_P(P) \ 166#define PURE_POINTER_P(P) \
233 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size) 167 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
234 168
235/* 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.. */
236 170
237static ptrdiff_t pure_bytes_used_lisp; 171static ptrdiff_t pure_bytes_used_lisp;
238 172
@@ -258,38 +192,38 @@ static char *stack_copy;
258static ptrdiff_t stack_copy_size; 192static ptrdiff_t stack_copy_size;
259#endif 193#endif
260 194
261/* Non-zero means ignore malloc warnings. Set during initialization. 195static Lisp_Object Qconses;
262 Currently not used. */ 196static Lisp_Object Qsymbols;
263 197static Lisp_Object Qmiscs;
264static int ignore_warnings; 198static Lisp_Object Qstrings;
265 199static Lisp_Object Qvectors;
200static Lisp_Object Qfloats;
201static Lisp_Object Qintervals;
202static Lisp_Object Qbuffers;
203static Lisp_Object Qstring_bytes, Qvector_slots, Qheap;
266static Lisp_Object Qgc_cons_threshold; 204static Lisp_Object Qgc_cons_threshold;
205Lisp_Object Qautomatic_gc;
267Lisp_Object Qchar_table_extra_slots; 206Lisp_Object Qchar_table_extra_slots;
268 207
269/* Hook run after GC has finished. */ 208/* Hook run after GC has finished. */
270 209
271static Lisp_Object Qpost_gc_hook; 210static Lisp_Object Qpost_gc_hook;
272 211
273static void mark_buffer (Lisp_Object);
274static void mark_terminals (void); 212static void mark_terminals (void);
275static void gc_sweep (void); 213static void gc_sweep (void);
276static Lisp_Object make_pure_vector (ptrdiff_t); 214static Lisp_Object make_pure_vector (ptrdiff_t);
277static void mark_glyph_matrix (struct glyph_matrix *); 215static void mark_buffer (struct buffer *);
278static void mark_face_cache (struct face_cache *);
279 216
280#if !defined REL_ALLOC || defined SYSTEM_MALLOC 217#if !defined REL_ALLOC || defined SYSTEM_MALLOC
281static void refill_memory_reserve (void); 218static void refill_memory_reserve (void);
282#endif 219#endif
283static struct Lisp_String *allocate_string (void);
284static void compact_small_strings (void); 220static void compact_small_strings (void);
285static void free_large_strings (void); 221static void free_large_strings (void);
286static void sweep_strings (void);
287static void free_misc (Lisp_Object);
288extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE; 222extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
289 223
290/* When scanning the C stack for live Lisp objects, Emacs keeps track 224/* When scanning the C stack for live Lisp objects, Emacs keeps track of
291 of what memory allocated via lisp_malloc is intended for what 225 what memory allocated via lisp_malloc and lisp_align_malloc is intended
292 purpose. This enumeration specifies the type of memory. */ 226 for what purpose. This enumeration specifies the type of memory. */
293 227
294enum mem_type 228enum mem_type
295{ 229{
@@ -300,22 +234,18 @@ enum mem_type
300 MEM_TYPE_MISC, 234 MEM_TYPE_MISC,
301 MEM_TYPE_SYMBOL, 235 MEM_TYPE_SYMBOL,
302 MEM_TYPE_FLOAT, 236 MEM_TYPE_FLOAT,
303 /* We used to keep separate mem_types for subtypes of vectors such as 237 /* Since all non-bool pseudovectors are small enough to be
304 process, hash_table, frame, terminal, and window, but we never made 238 allocated from vector blocks, this memory type denotes
305 use of the distinction, so it only caused source-code complexity 239 large regular vectors and large bool pseudovectors. */
306 and runtime slowdown. Minor but pointless. */ 240 MEM_TYPE_VECTORLIKE,
307 MEM_TYPE_VECTORLIKE 241 /* Special type to denote vector blocks. */
242 MEM_TYPE_VECTOR_BLOCK,
243 /* Special type to denote reserved memory. */
244 MEM_TYPE_SPARE
308}; 245};
309 246
310static void *lisp_malloc (size_t, enum mem_type);
311
312
313#if GC_MARK_STACK || defined GC_MALLOC_CHECK 247#if GC_MARK_STACK || defined GC_MALLOC_CHECK
314 248
315#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
316#include <stdio.h> /* For fprintf. */
317#endif
318
319/* A unique object in pure space used to make some Lisp objects 249/* A unique object in pure space used to make some Lisp objects
320 on free lists recognizable in O(1). */ 250 on free lists recognizable in O(1). */
321 251
@@ -388,33 +318,13 @@ static void *min_heap_address, *max_heap_address;
388static struct mem_node mem_z; 318static struct mem_node mem_z;
389#define MEM_NIL &mem_z 319#define MEM_NIL &mem_z
390 320
391static struct Lisp_Vector *allocate_vectorlike (ptrdiff_t);
392static void lisp_free (void *);
393static void mark_stack (void);
394static int live_vector_p (struct mem_node *, void *);
395static int live_buffer_p (struct mem_node *, void *);
396static int live_string_p (struct mem_node *, void *);
397static int live_cons_p (struct mem_node *, void *);
398static int live_symbol_p (struct mem_node *, void *);
399static int live_float_p (struct mem_node *, void *);
400static int live_misc_p (struct mem_node *, void *);
401static void mark_maybe_object (Lisp_Object);
402static void mark_memory (void *, void *);
403#if GC_MARK_STACK || defined GC_MALLOC_CHECK
404static void mem_init (void);
405static struct mem_node *mem_insert (void *, void *, enum mem_type); 321static struct mem_node *mem_insert (void *, void *, enum mem_type);
406static void mem_insert_fixup (struct mem_node *); 322static void mem_insert_fixup (struct mem_node *);
407#endif
408static void mem_rotate_left (struct mem_node *); 323static void mem_rotate_left (struct mem_node *);
409static void mem_rotate_right (struct mem_node *); 324static void mem_rotate_right (struct mem_node *);
410static void mem_delete (struct mem_node *); 325static void mem_delete (struct mem_node *);
411static void mem_delete_fixup (struct mem_node *); 326static void mem_delete_fixup (struct mem_node *);
412static inline struct mem_node *mem_find (void *); 327static struct mem_node *mem_find (void *);
413
414
415#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
416static void check_gcpros (void);
417#endif
418 328
419#endif /* GC_MARK_STACK || GC_MALLOC_CHECK */ 329#endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
420 330
@@ -429,12 +339,12 @@ struct gcpro *gcprolist;
429/* Addresses of staticpro'd variables. Initialize it to a nonzero 339/* Addresses of staticpro'd variables. Initialize it to a nonzero
430 value; otherwise some compilers put it into BSS. */ 340 value; otherwise some compilers put it into BSS. */
431 341
432#define NSTATICS 0x640 342enum { NSTATICS = 2048 };
433static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag}; 343static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
434 344
435/* Index of next unused slot in staticvec. */ 345/* Index of next unused slot in staticvec. */
436 346
437static int staticidx = 0; 347static int staticidx;
438 348
439static void *pure_alloc (size_t, int); 349static void *pure_alloc (size_t, int);
440 350
@@ -446,6 +356,11 @@ static void *pure_alloc (size_t, int);
446 ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \ 356 ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
447 & ~ ((ALIGNMENT) - 1))) 357 & ~ ((ALIGNMENT) - 1)))
448 358
359static void
360XFLOAT_INIT (Lisp_Object f, double n)
361{
362 XFLOAT (f)->u.data = n;
363}
449 364
450 365
451/************************************************************************ 366/************************************************************************
@@ -487,13 +402,18 @@ buffer_memory_full (ptrdiff_t nbytes)
487 402
488#ifndef REL_ALLOC 403#ifndef REL_ALLOC
489 memory_full (nbytes); 404 memory_full (nbytes);
490#endif 405#else
491
492 /* This used to call error, but if we've run out of memory, we could 406 /* This used to call error, but if we've run out of memory, we could
493 get infinite recursion trying to build the string. */ 407 get infinite recursion trying to build the string. */
494 xsignal (Qnil, Vmemory_signal_data); 408 xsignal (Qnil, Vmemory_signal_data);
409#endif
495} 410}
496 411
412/* A common multiple of the positive integers A and B. Ideally this
413 would be the least common multiple, but there's no way to do that
414 as a constant expression in C, so do the best that we can easily do. */
415#define COMMON_MULTIPLE(a, b) \
416 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
497 417
498#ifndef XMALLOC_OVERRUN_CHECK 418#ifndef XMALLOC_OVERRUN_CHECK
499#define XMALLOC_OVERRUN_CHECK_OVERHEAD 0 419#define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
@@ -519,20 +439,11 @@ buffer_memory_full (ptrdiff_t nbytes)
519 hold a size_t value and (2) the header size is a multiple of the 439 hold a size_t value and (2) the header size is a multiple of the
520 alignment that Emacs needs for C types and for USE_LSB_TAG. */ 440 alignment that Emacs needs for C types and for USE_LSB_TAG. */
521#define XMALLOC_BASE_ALIGNMENT \ 441#define XMALLOC_BASE_ALIGNMENT \
522 offsetof ( \ 442 alignof (union { long double d; intmax_t i; void *p; })
523 struct { \ 443
524 union { long double d; intmax_t i; void *p; } u; \ 444#if USE_LSB_TAG
525 char c; \
526 }, \
527 c)
528#ifdef USE_LSB_TAG
529/* A common multiple of the positive integers A and B. Ideally this
530 would be the least common multiple, but there's no way to do that
531 as a constant expression in C, so do the best that we can easily do. */
532# define COMMON_MULTIPLE(a, b) \
533 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
534# define XMALLOC_HEADER_ALIGNMENT \ 445# define XMALLOC_HEADER_ALIGNMENT \
535 COMMON_MULTIPLE (1 << GCTYPEBITS, XMALLOC_BASE_ALIGNMENT) 446 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
536#else 447#else
537# define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT 448# define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
538#endif 449#endif
@@ -582,39 +493,17 @@ xmalloc_get_size (unsigned char *ptr)
582} 493}
583 494
584 495
585/* The call depth in overrun_check functions. For example, this might happen:
586 xmalloc()
587 overrun_check_malloc()
588 -> malloc -> (via hook)_-> emacs_blocked_malloc
589 -> overrun_check_malloc
590 call malloc (hooks are NULL, so real malloc is called).
591 malloc returns 10000.
592 add overhead, return 10016.
593 <- (back in overrun_check_malloc)
594 add overhead again, return 10032
595 xmalloc returns 10032.
596
597 (time passes).
598
599 xfree(10032)
600 overrun_check_free(10032)
601 decrease overhead
602 free(10016) <- crash, because 10000 is the original pointer. */
603
604static ptrdiff_t check_depth;
605
606/* Like malloc, but wraps allocated block with header and trailer. */ 496/* Like malloc, but wraps allocated block with header and trailer. */
607 497
608static void * 498static void *
609overrun_check_malloc (size_t size) 499overrun_check_malloc (size_t size)
610{ 500{
611 register unsigned char *val; 501 register unsigned char *val;
612 int overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD : 0; 502 if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
613 if (SIZE_MAX - overhead < size) 503 emacs_abort ();
614 abort ();
615 504
616 val = (unsigned char *) malloc (size + overhead); 505 val = malloc (size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
617 if (val && check_depth == 1) 506 if (val)
618 { 507 {
619 memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE); 508 memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
620 val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE; 509 val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
@@ -622,7 +511,6 @@ overrun_check_malloc (size_t size)
622 memcpy (val + size, xmalloc_overrun_check_trailer, 511 memcpy (val + size, xmalloc_overrun_check_trailer,
623 XMALLOC_OVERRUN_CHECK_SIZE); 512 XMALLOC_OVERRUN_CHECK_SIZE);
624 } 513 }
625 --check_depth;
626 return val; 514 return val;
627} 515}
628 516
@@ -634,12 +522,10 @@ static void *
634overrun_check_realloc (void *block, size_t size) 522overrun_check_realloc (void *block, size_t size)
635{ 523{
636 register unsigned char *val = (unsigned char *) block; 524 register unsigned char *val = (unsigned char *) block;
637 int overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD : 0; 525 if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
638 if (SIZE_MAX - overhead < size) 526 emacs_abort ();
639 abort ();
640 527
641 if (val 528 if (val
642 && check_depth == 1
643 && memcmp (xmalloc_overrun_check_header, 529 && memcmp (xmalloc_overrun_check_header,
644 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE, 530 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
645 XMALLOC_OVERRUN_CHECK_SIZE) == 0) 531 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
@@ -647,15 +533,15 @@ overrun_check_realloc (void *block, size_t size)
647 size_t osize = xmalloc_get_size (val); 533 size_t osize = xmalloc_get_size (val);
648 if (memcmp (xmalloc_overrun_check_trailer, val + osize, 534 if (memcmp (xmalloc_overrun_check_trailer, val + osize,
649 XMALLOC_OVERRUN_CHECK_SIZE)) 535 XMALLOC_OVERRUN_CHECK_SIZE))
650 abort (); 536 emacs_abort ();
651 memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE); 537 memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
652 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE; 538 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
653 memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE); 539 memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
654 } 540 }
655 541
656 val = realloc (val, size + overhead); 542 val = realloc (val, size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
657 543
658 if (val && check_depth == 1) 544 if (val)
659 { 545 {
660 memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE); 546 memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
661 val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE; 547 val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
@@ -663,7 +549,6 @@ overrun_check_realloc (void *block, size_t size)
663 memcpy (val + size, xmalloc_overrun_check_trailer, 549 memcpy (val + size, xmalloc_overrun_check_trailer,
664 XMALLOC_OVERRUN_CHECK_SIZE); 550 XMALLOC_OVERRUN_CHECK_SIZE);
665 } 551 }
666 --check_depth;
667 return val; 552 return val;
668} 553}
669 554
@@ -674,9 +559,7 @@ overrun_check_free (void *block)
674{ 559{
675 unsigned char *val = (unsigned char *) block; 560 unsigned char *val = (unsigned char *) block;
676 561
677 ++check_depth;
678 if (val 562 if (val
679 && check_depth == 1
680 && memcmp (xmalloc_overrun_check_header, 563 && memcmp (xmalloc_overrun_check_header,
681 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE, 564 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
682 XMALLOC_OVERRUN_CHECK_SIZE) == 0) 565 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
@@ -684,7 +567,7 @@ overrun_check_free (void *block)
684 size_t osize = xmalloc_get_size (val); 567 size_t osize = xmalloc_get_size (val);
685 if (memcmp (xmalloc_overrun_check_trailer, val + osize, 568 if (memcmp (xmalloc_overrun_check_trailer, val + osize,
686 XMALLOC_OVERRUN_CHECK_SIZE)) 569 XMALLOC_OVERRUN_CHECK_SIZE))
687 abort (); 570 emacs_abort ();
688#ifdef XMALLOC_CLEAR_FREE_MEMORY 571#ifdef XMALLOC_CLEAR_FREE_MEMORY
689 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE; 572 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
690 memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_OVERHEAD); 573 memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_OVERHEAD);
@@ -696,7 +579,6 @@ overrun_check_free (void *block)
696 } 579 }
697 580
698 free (val); 581 free (val);
699 --check_depth;
700} 582}
701 583
702#undef malloc 584#undef malloc
@@ -707,16 +589,42 @@ overrun_check_free (void *block)
707#define free overrun_check_free 589#define free overrun_check_free
708#endif 590#endif
709 591
710#ifdef SYNC_INPUT 592/* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
711/* When using SYNC_INPUT, we don't call malloc from a signal handler, so 593 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
712 there's no need to block input around malloc. */ 594 If that variable is set, block input while in one of Emacs's memory
713#define MALLOC_BLOCK_INPUT ((void)0) 595 allocation functions. There should be no need for this debugging
714#define MALLOC_UNBLOCK_INPUT ((void)0) 596 option, since signal handlers do not allocate memory, but Emacs
597 formerly allocated memory in signal handlers and this compile-time
598 option remains as a way to help debug the issue should it rear its
599 ugly head again. */
600#ifdef XMALLOC_BLOCK_INPUT_CHECK
601bool block_input_in_memory_allocators EXTERNALLY_VISIBLE;
602static void
603malloc_block_input (void)
604{
605 if (block_input_in_memory_allocators)
606 block_input ();
607}
608static void
609malloc_unblock_input (void)
610{
611 if (block_input_in_memory_allocators)
612 unblock_input ();
613}
614# define MALLOC_BLOCK_INPUT malloc_block_input ()
615# define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
715#else 616#else
716#define MALLOC_BLOCK_INPUT BLOCK_INPUT 617# define MALLOC_BLOCK_INPUT ((void) 0)
717#define MALLOC_UNBLOCK_INPUT UNBLOCK_INPUT 618# define MALLOC_UNBLOCK_INPUT ((void) 0)
718#endif 619#endif
719 620
621#define MALLOC_PROBE(size) \
622 do { \
623 if (profiler_memory_running) \
624 malloc_probe (size); \
625 } while (0)
626
627
720/* Like malloc but check for no memory and block interrupt input.. */ 628/* Like malloc but check for no memory and block interrupt input.. */
721 629
722void * 630void *
@@ -730,9 +638,27 @@ xmalloc (size_t size)
730 638
731 if (!val && size) 639 if (!val && size)
732 memory_full (size); 640 memory_full (size);
641 MALLOC_PROBE (size);
733 return val; 642 return val;
734} 643}
735 644
645/* Like the above, but zeroes out the memory just allocated. */
646
647void *
648xzalloc (size_t size)
649{
650 void *val;
651
652 MALLOC_BLOCK_INPUT;
653 val = malloc (size);
654 MALLOC_UNBLOCK_INPUT;
655
656 if (!val && size)
657 memory_full (size);
658 memset (val, 0, size);
659 MALLOC_PROBE (size);
660 return val;
661}
736 662
737/* Like realloc but check for no memory and block interrupt input.. */ 663/* Like realloc but check for no memory and block interrupt input.. */
738 664
@@ -752,6 +678,7 @@ xrealloc (void *block, size_t size)
752 678
753 if (!val && size) 679 if (!val && size)
754 memory_full (size); 680 memory_full (size);
681 MALLOC_PROBE (size);
755 return val; 682 return val;
756} 683}
757 684
@@ -767,8 +694,7 @@ xfree (void *block)
767 free (block); 694 free (block);
768 MALLOC_UNBLOCK_INPUT; 695 MALLOC_UNBLOCK_INPUT;
769 /* We don't call refill_memory_reserve here 696 /* We don't call refill_memory_reserve here
770 because that duplicates doing so in emacs_blocked_free 697 because in practice the call in r_alloc_free seems to suffice. */
771 and the criterion should go there. */
772} 698}
773 699
774 700
@@ -784,7 +710,7 @@ verify (INT_MAX <= PTRDIFF_MAX);
784void * 710void *
785xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size) 711xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size)
786{ 712{
787 xassert (0 <= nitems && 0 < item_size); 713 eassert (0 <= nitems && 0 < item_size);
788 if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems) 714 if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems)
789 memory_full (SIZE_MAX); 715 memory_full (SIZE_MAX);
790 return xmalloc (nitems * item_size); 716 return xmalloc (nitems * item_size);
@@ -797,7 +723,7 @@ xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size)
797void * 723void *
798xnrealloc (void *pa, ptrdiff_t nitems, ptrdiff_t item_size) 724xnrealloc (void *pa, ptrdiff_t nitems, ptrdiff_t item_size)
799{ 725{
800 xassert (0 <= nitems && 0 < item_size); 726 eassert (0 <= nitems && 0 < item_size);
801 if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems) 727 if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems)
802 memory_full (SIZE_MAX); 728 memory_full (SIZE_MAX);
803 return xrealloc (pa, nitems * item_size); 729 return xrealloc (pa, nitems * item_size);
@@ -815,13 +741,17 @@ xnrealloc (void *pa, ptrdiff_t nitems, ptrdiff_t item_size)
815 infinity. 741 infinity.
816 742
817 If PA is null, then allocate a new array instead of reallocating 743 If PA is null, then allocate a new array instead of reallocating
818 the old one. Thus, to grow an array A without saving its old 744 the old one.
819 contents, invoke xfree (A) immediately followed by xgrowalloc (0,
820 &NITEMS, ...).
821 745
822 Block interrupt input as needed. If memory exhaustion occurs, set 746 Block interrupt input as needed. If memory exhaustion occurs, set
823 *NITEMS to zero if PA is null, and signal an error (i.e., do not 747 *NITEMS to zero if PA is null, and signal an error (i.e., do not
824 return). */ 748 return).
749
750 Thus, to grow an array A without saving its old contents, do
751 { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
752 The A = NULL avoids a dangling pointer if xpalloc exhausts memory
753 and signals an error, and later this code is reexecuted and
754 attempts to free A. */
825 755
826void * 756void *
827xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min, 757xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
@@ -847,7 +777,7 @@ xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
847 ptrdiff_t nitems_incr_max = n_max - n; 777 ptrdiff_t nitems_incr_max = n_max - n;
848 ptrdiff_t incr = max (nitems_incr_min, min (incr_estimate, nitems_incr_max)); 778 ptrdiff_t incr = max (nitems_incr_min, min (incr_estimate, nitems_incr_max));
849 779
850 xassert (0 < item_size && 0 < nitems_incr_min && 0 <= n && -1 <= nitems_max); 780 eassert (0 < item_size && 0 < nitems_incr_min && 0 <= n && -1 <= nitems_max);
851 if (! pa) 781 if (! pa)
852 *nitems = 0; 782 *nitems = 0;
853 if (nitems_incr_max < incr) 783 if (nitems_incr_max < incr)
@@ -864,25 +794,39 @@ xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
864char * 794char *
865xstrdup (const char *s) 795xstrdup (const char *s)
866{ 796{
867 size_t len = strlen (s) + 1; 797 ptrdiff_t size;
868 char *p = (char *) xmalloc (len); 798 eassert (s);
869 memcpy (p, s, len); 799 size = strlen (s) + 1;
870 return p; 800 return memcpy (xmalloc (size), s, size);
871} 801}
872 802
803/* Like above, but duplicates Lisp string to C string. */
804
805char *
806xlispstrdup (Lisp_Object string)
807{
808 ptrdiff_t size = SBYTES (string) + 1;
809 return memcpy (xmalloc (size), SSDATA (string), size);
810}
873 811
874/* Unwind for SAFE_ALLOCA */ 812/* Like putenv, but (1) use the equivalent of xmalloc and (2) the
813 argument is a const pointer. */
875 814
876Lisp_Object 815void
877safe_alloca_unwind (Lisp_Object arg) 816xputenv (char const *string)
878{ 817{
879 register struct Lisp_Save_Value *p = XSAVE_VALUE (arg); 818 if (putenv ((char *) string) != 0)
819 memory_full (0);
820}
880 821
881 p->dogc = 0; 822/* Return a newly allocated memory block of SIZE bytes, remembering
882 xfree (p->pointer); 823 to free it when unwinding. */
883 p->pointer = 0; 824void *
884 free_misc (arg); 825record_xmalloc (size_t size)
885 return Qnil; 826{
827 void *p = xmalloc (size);
828 record_unwind_protect_ptr (xfree, p);
829 return p;
886} 830}
887 831
888 832
@@ -890,8 +834,8 @@ safe_alloca_unwind (Lisp_Object arg)
890 number of bytes to allocate, TYPE describes the intended use of the 834 number of bytes to allocate, TYPE describes the intended use of the
891 allocated memory block (for strings, for conses, ...). */ 835 allocated memory block (for strings, for conses, ...). */
892 836
893#ifndef USE_LSB_TAG 837#if ! USE_LSB_TAG
894static void *lisp_malloc_loser; 838void *lisp_malloc_loser EXTERNALLY_VISIBLE;
895#endif 839#endif
896 840
897static void * 841static void *
@@ -905,9 +849,9 @@ lisp_malloc (size_t nbytes, enum mem_type type)
905 allocated_mem_type = type; 849 allocated_mem_type = type;
906#endif 850#endif
907 851
908 val = (void *) malloc (nbytes); 852 val = malloc (nbytes);
909 853
910#ifndef USE_LSB_TAG 854#if ! USE_LSB_TAG
911 /* If the memory just allocated cannot be addressed thru a Lisp 855 /* If the memory just allocated cannot be addressed thru a Lisp
912 object's pointer, and it needs to be, 856 object's pointer, and it needs to be,
913 that's equivalent to running out of memory. */ 857 that's equivalent to running out of memory. */
@@ -932,6 +876,7 @@ lisp_malloc (size_t nbytes, enum mem_type type)
932 MALLOC_UNBLOCK_INPUT; 876 MALLOC_UNBLOCK_INPUT;
933 if (!val && nbytes) 877 if (!val && nbytes)
934 memory_full (nbytes); 878 memory_full (nbytes);
879 MALLOC_PROBE (nbytes);
935 return val; 880 return val;
936} 881}
937 882
@@ -1088,7 +1033,7 @@ lisp_align_malloc (size_t nbytes, enum mem_type type)
1088 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); 1033 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
1089#endif 1034#endif
1090 1035
1091#ifndef USE_LSB_TAG 1036#if ! USE_LSB_TAG
1092 /* If the memory just allocated cannot be addressed thru a Lisp 1037 /* If the memory just allocated cannot be addressed thru a Lisp
1093 object's pointer, and it needs to be, that's equivalent to 1038 object's pointer, and it needs to be, that's equivalent to
1094 running out of memory. */ 1039 running out of memory. */
@@ -1137,6 +1082,8 @@ lisp_align_malloc (size_t nbytes, enum mem_type type)
1137 1082
1138 MALLOC_UNBLOCK_INPUT; 1083 MALLOC_UNBLOCK_INPUT;
1139 1084
1085 MALLOC_PROBE (nbytes);
1086
1140 eassert (0 == ((uintptr_t) val) % BLOCK_ALIGN); 1087 eassert (0 == ((uintptr_t) val) % BLOCK_ALIGN);
1141 return val; 1088 return val;
1142} 1089}
@@ -1184,271 +1131,6 @@ lisp_align_free (void *block)
1184 MALLOC_UNBLOCK_INPUT; 1131 MALLOC_UNBLOCK_INPUT;
1185} 1132}
1186 1133
1187/* Return a new buffer structure allocated from the heap with
1188 a call to lisp_malloc. */
1189
1190struct buffer *
1191allocate_buffer (void)
1192{
1193 struct buffer *b
1194 = (struct buffer *) lisp_malloc (sizeof (struct buffer),
1195 MEM_TYPE_BUFFER);
1196 XSETPVECTYPESIZE (b, PVEC_BUFFER,
1197 ((sizeof (struct buffer) + sizeof (EMACS_INT) - 1)
1198 / sizeof (EMACS_INT)));
1199 return b;
1200}
1201
1202
1203#ifndef SYSTEM_MALLOC
1204
1205/* Arranging to disable input signals while we're in malloc.
1206
1207 This only works with GNU malloc. To help out systems which can't
1208 use GNU malloc, all the calls to malloc, realloc, and free
1209 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
1210 pair; unfortunately, we have no idea what C library functions
1211 might call malloc, so we can't really protect them unless you're
1212 using GNU malloc. Fortunately, most of the major operating systems
1213 can use GNU malloc. */
1214
1215#ifndef SYNC_INPUT
1216/* When using SYNC_INPUT, we don't call malloc from a signal handler, so
1217 there's no need to block input around malloc. */
1218
1219#ifndef DOUG_LEA_MALLOC
1220extern void * (*__malloc_hook) (size_t, const void *);
1221extern void * (*__realloc_hook) (void *, size_t, const void *);
1222extern void (*__free_hook) (void *, const void *);
1223/* Else declared in malloc.h, perhaps with an extra arg. */
1224#endif /* DOUG_LEA_MALLOC */
1225static void * (*old_malloc_hook) (size_t, const void *);
1226static void * (*old_realloc_hook) (void *, size_t, const void*);
1227static void (*old_free_hook) (void*, const void*);
1228
1229#ifdef DOUG_LEA_MALLOC
1230# define BYTES_USED (mallinfo ().uordblks)
1231#else
1232# define BYTES_USED _bytes_used
1233#endif
1234
1235#ifdef GC_MALLOC_CHECK
1236static int dont_register_blocks;
1237#endif
1238
1239static size_t bytes_used_when_reconsidered;
1240
1241/* Value of _bytes_used, when spare_memory was freed. */
1242
1243static size_t bytes_used_when_full;
1244
1245/* This function is used as the hook for free to call. */
1246
1247static void
1248emacs_blocked_free (void *ptr, const void *ptr2)
1249{
1250 BLOCK_INPUT_ALLOC;
1251
1252#ifdef GC_MALLOC_CHECK
1253 if (ptr)
1254 {
1255 struct mem_node *m;
1256
1257 m = mem_find (ptr);
1258 if (m == MEM_NIL || m->start != ptr)
1259 {
1260 fprintf (stderr,
1261 "Freeing `%p' which wasn't allocated with malloc\n", ptr);
1262 abort ();
1263 }
1264 else
1265 {
1266 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
1267 mem_delete (m);
1268 }
1269 }
1270#endif /* GC_MALLOC_CHECK */
1271
1272 __free_hook = old_free_hook;
1273 free (ptr);
1274
1275 /* If we released our reserve (due to running out of memory),
1276 and we have a fair amount free once again,
1277 try to set aside another reserve in case we run out once more. */
1278 if (! NILP (Vmemory_full)
1279 /* Verify there is enough space that even with the malloc
1280 hysteresis this call won't run out again.
1281 The code here is correct as long as SPARE_MEMORY
1282 is substantially larger than the block size malloc uses. */
1283 && (bytes_used_when_full
1284 > ((bytes_used_when_reconsidered = BYTES_USED)
1285 + max (malloc_hysteresis, 4) * SPARE_MEMORY)))
1286 refill_memory_reserve ();
1287
1288 __free_hook = emacs_blocked_free;
1289 UNBLOCK_INPUT_ALLOC;
1290}
1291
1292
1293/* This function is the malloc hook that Emacs uses. */
1294
1295static void *
1296emacs_blocked_malloc (size_t size, const void *ptr)
1297{
1298 void *value;
1299
1300 BLOCK_INPUT_ALLOC;
1301 __malloc_hook = old_malloc_hook;
1302#ifdef DOUG_LEA_MALLOC
1303 /* Segfaults on my system. --lorentey */
1304 /* mallopt (M_TOP_PAD, malloc_hysteresis * 4096); */
1305#else
1306 __malloc_extra_blocks = malloc_hysteresis;
1307#endif
1308
1309 value = (void *) malloc (size);
1310
1311#ifdef GC_MALLOC_CHECK
1312 {
1313 struct mem_node *m = mem_find (value);
1314 if (m != MEM_NIL)
1315 {
1316 fprintf (stderr, "Malloc returned %p which is already in use\n",
1317 value);
1318 fprintf (stderr, "Region in use is %p...%p, %td bytes, type %d\n",
1319 m->start, m->end, (char *) m->end - (char *) m->start,
1320 m->type);
1321 abort ();
1322 }
1323
1324 if (!dont_register_blocks)
1325 {
1326 mem_insert (value, (char *) value + max (1, size), allocated_mem_type);
1327 allocated_mem_type = MEM_TYPE_NON_LISP;
1328 }
1329 }
1330#endif /* GC_MALLOC_CHECK */
1331
1332 __malloc_hook = emacs_blocked_malloc;
1333 UNBLOCK_INPUT_ALLOC;
1334
1335 /* fprintf (stderr, "%p malloc\n", value); */
1336 return value;
1337}
1338
1339
1340/* This function is the realloc hook that Emacs uses. */
1341
1342static void *
1343emacs_blocked_realloc (void *ptr, size_t size, const void *ptr2)
1344{
1345 void *value;
1346
1347 BLOCK_INPUT_ALLOC;
1348 __realloc_hook = old_realloc_hook;
1349
1350#ifdef GC_MALLOC_CHECK
1351 if (ptr)
1352 {
1353 struct mem_node *m = mem_find (ptr);
1354 if (m == MEM_NIL || m->start != ptr)
1355 {
1356 fprintf (stderr,
1357 "Realloc of %p which wasn't allocated with malloc\n",
1358 ptr);
1359 abort ();
1360 }
1361
1362 mem_delete (m);
1363 }
1364
1365 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1366
1367 /* Prevent malloc from registering blocks. */
1368 dont_register_blocks = 1;
1369#endif /* GC_MALLOC_CHECK */
1370
1371 value = (void *) realloc (ptr, size);
1372
1373#ifdef GC_MALLOC_CHECK
1374 dont_register_blocks = 0;
1375
1376 {
1377 struct mem_node *m = mem_find (value);
1378 if (m != MEM_NIL)
1379 {
1380 fprintf (stderr, "Realloc returns memory that is already in use\n");
1381 abort ();
1382 }
1383
1384 /* Can't handle zero size regions in the red-black tree. */
1385 mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP);
1386 }
1387
1388 /* fprintf (stderr, "%p <- realloc\n", value); */
1389#endif /* GC_MALLOC_CHECK */
1390
1391 __realloc_hook = emacs_blocked_realloc;
1392 UNBLOCK_INPUT_ALLOC;
1393
1394 return value;
1395}
1396
1397
1398#ifdef HAVE_PTHREAD
1399/* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
1400 normal malloc. Some thread implementations need this as they call
1401 malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
1402 calls malloc because it is the first call, and we have an endless loop. */
1403
1404void
1405reset_malloc_hooks (void)
1406{
1407 __free_hook = old_free_hook;
1408 __malloc_hook = old_malloc_hook;
1409 __realloc_hook = old_realloc_hook;
1410}
1411#endif /* HAVE_PTHREAD */
1412
1413
1414/* Called from main to set up malloc to use our hooks. */
1415
1416void
1417uninterrupt_malloc (void)
1418{
1419#ifdef HAVE_PTHREAD
1420#ifdef DOUG_LEA_MALLOC
1421 pthread_mutexattr_t attr;
1422
1423 /* GLIBC has a faster way to do this, but let's keep it portable.
1424 This is according to the Single UNIX Specification. */
1425 pthread_mutexattr_init (&attr);
1426 pthread_mutexattr_settype (&attr, PTHREAD_MUTEX_RECURSIVE);
1427 pthread_mutex_init (&alloc_mutex, &attr);
1428#else /* !DOUG_LEA_MALLOC */
1429 /* Some systems such as Solaris 2.6 don't have a recursive mutex,
1430 and the bundled gmalloc.c doesn't require it. */
1431 pthread_mutex_init (&alloc_mutex, NULL);
1432#endif /* !DOUG_LEA_MALLOC */
1433#endif /* HAVE_PTHREAD */
1434
1435 if (__free_hook != emacs_blocked_free)
1436 old_free_hook = __free_hook;
1437 __free_hook = emacs_blocked_free;
1438
1439 if (__malloc_hook != emacs_blocked_malloc)
1440 old_malloc_hook = __malloc_hook;
1441 __malloc_hook = emacs_blocked_malloc;
1442
1443 if (__realloc_hook != emacs_blocked_realloc)
1444 old_realloc_hook = __realloc_hook;
1445 __realloc_hook = emacs_blocked_realloc;
1446}
1447
1448#endif /* not SYNC_INPUT */
1449#endif /* not SYSTEM_MALLOC */
1450
1451
1452 1134
1453/*********************************************************************** 1135/***********************************************************************
1454 Interval Allocation 1136 Interval Allocation
@@ -1460,7 +1142,7 @@ uninterrupt_malloc (void)
1460#define INTERVAL_BLOCK_SIZE \ 1142#define INTERVAL_BLOCK_SIZE \
1461 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval)) 1143 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1462 1144
1463/* Intervals are allocated in chunks in form of an interval_block 1145/* Intervals are allocated in chunks in the form of an interval_block
1464 structure. */ 1146 structure. */
1465 1147
1466struct interval_block 1148struct interval_block
@@ -1478,7 +1160,7 @@ static struct interval_block *interval_block;
1478/* Index in interval_block above of the next unused interval 1160/* Index in interval_block above of the next unused interval
1479 structure. */ 1161 structure. */
1480 1162
1481static int interval_block_index; 1163static int interval_block_index = INTERVAL_BLOCK_SIZE;
1482 1164
1483/* Number of free and live intervals. */ 1165/* Number of free and live intervals. */
1484 1166
@@ -1488,18 +1170,6 @@ static EMACS_INT total_free_intervals, total_intervals;
1488 1170
1489static INTERVAL interval_free_list; 1171static INTERVAL interval_free_list;
1490 1172
1491
1492/* Initialize interval allocation. */
1493
1494static void
1495init_intervals (void)
1496{
1497 interval_block = NULL;
1498 interval_block_index = INTERVAL_BLOCK_SIZE;
1499 interval_free_list = 0;
1500}
1501
1502
1503/* Return a new interval. */ 1173/* Return a new interval. */
1504 1174
1505INTERVAL 1175INTERVAL
@@ -1507,8 +1177,6 @@ make_interval (void)
1507{ 1177{
1508 INTERVAL val; 1178 INTERVAL val;
1509 1179
1510 /* eassert (!handling_signal); */
1511
1512 MALLOC_BLOCK_INPUT; 1180 MALLOC_BLOCK_INPUT;
1513 1181
1514 if (interval_free_list) 1182 if (interval_free_list)
@@ -1520,14 +1188,13 @@ make_interval (void)
1520 { 1188 {
1521 if (interval_block_index == INTERVAL_BLOCK_SIZE) 1189 if (interval_block_index == INTERVAL_BLOCK_SIZE)
1522 { 1190 {
1523 register struct interval_block *newi; 1191 struct interval_block *newi
1524 1192 = lisp_malloc (sizeof *newi, MEM_TYPE_NON_LISP);
1525 newi = (struct interval_block *) lisp_malloc (sizeof *newi,
1526 MEM_TYPE_NON_LISP);
1527 1193
1528 newi->next = interval_block; 1194 newi->next = interval_block;
1529 interval_block = newi; 1195 interval_block = newi;
1530 interval_block_index = 0; 1196 interval_block_index = 0;
1197 total_free_intervals += INTERVAL_BLOCK_SIZE;
1531 } 1198 }
1532 val = &interval_block->intervals[interval_block_index++]; 1199 val = &interval_block->intervals[interval_block_index++];
1533 } 1200 }
@@ -1536,81 +1203,33 @@ make_interval (void)
1536 1203
1537 consing_since_gc += sizeof (struct interval); 1204 consing_since_gc += sizeof (struct interval);
1538 intervals_consed++; 1205 intervals_consed++;
1206 total_free_intervals--;
1539 RESET_INTERVAL (val); 1207 RESET_INTERVAL (val);
1540 val->gcmarkbit = 0; 1208 val->gcmarkbit = 0;
1541 return val; 1209 return val;
1542} 1210}
1543 1211
1544 1212
1545/* Mark Lisp objects in interval I. */ 1213/* Mark Lisp objects in interval I. */
1546 1214
1547static void 1215static void
1548mark_interval (register INTERVAL i, Lisp_Object dummy) 1216mark_interval (register INTERVAL i, Lisp_Object dummy)
1549{ 1217{
1550 eassert (!i->gcmarkbit); /* Intervals are never shared. */ 1218 /* Intervals should never be shared. So, if extra internal checking is
1219 enabled, GC aborts if it seems to have visited an interval twice. */
1220 eassert (!i->gcmarkbit);
1551 i->gcmarkbit = 1; 1221 i->gcmarkbit = 1;
1552 mark_object (i->plist); 1222 mark_object (i->plist);
1553} 1223}
1554 1224
1555
1556/* Mark the interval tree rooted in TREE. Don't call this directly;
1557 use the macro MARK_INTERVAL_TREE instead. */
1558
1559static void
1560mark_interval_tree (register INTERVAL tree)
1561{
1562 /* No need to test if this tree has been marked already; this
1563 function is always called through the MARK_INTERVAL_TREE macro,
1564 which takes care of that. */
1565
1566 traverse_intervals_noorder (tree, mark_interval, Qnil);
1567}
1568
1569
1570/* Mark the interval tree rooted in I. */ 1225/* Mark the interval tree rooted in I. */
1571 1226
1572#define MARK_INTERVAL_TREE(i) \ 1227#define MARK_INTERVAL_TREE(i) \
1573 do { \ 1228 do { \
1574 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \ 1229 if (i && !i->gcmarkbit) \
1575 mark_interval_tree (i); \ 1230 traverse_intervals_noorder (i, mark_interval, Qnil); \
1576 } while (0)
1577
1578
1579#define UNMARK_BALANCE_INTERVALS(i) \
1580 do { \
1581 if (! NULL_INTERVAL_P (i)) \
1582 (i) = balance_intervals (i); \
1583 } while (0) 1231 } while (0)
1584 1232
1585
1586/* Number support. If USE_LISP_UNION_TYPE is in effect, we
1587 can't create number objects in macros. */
1588#ifndef make_number
1589Lisp_Object
1590make_number (EMACS_INT n)
1591{
1592 Lisp_Object obj;
1593 obj.s.val = n;
1594 obj.s.type = Lisp_Int;
1595 return obj;
1596}
1597#endif
1598
1599/* Convert the pointer-sized word P to EMACS_INT while preserving its
1600 type and ptr fields. */
1601static Lisp_Object
1602widen_to_Lisp_Object (void *p)
1603{
1604 intptr_t i = (intptr_t) p;
1605#ifdef USE_LISP_UNION_TYPE
1606 Lisp_Object obj;
1607 obj.i = i;
1608 return obj;
1609#else
1610 return i;
1611#endif
1612}
1613
1614/*********************************************************************** 1233/***********************************************************************
1615 String Allocation 1234 String Allocation
1616 ***********************************************************************/ 1235 ***********************************************************************/
@@ -1634,7 +1253,7 @@ widen_to_Lisp_Object (void *p)
1634 When a Lisp_String is freed during GC, it is put back on 1253 When a Lisp_String is freed during GC, it is put back on
1635 string_free_list, and its `data' member and its sdata's `string' 1254 string_free_list, and its `data' member and its sdata's `string'
1636 pointer is set to null. The size of the string is recorded in the 1255 pointer is set to null. The size of the string is recorded in the
1637 `u.nbytes' member of the sdata. So, sdata structures that are no 1256 `n.nbytes' member of the sdata. So, sdata structures that are no
1638 longer used, can be easily recognized, and it's easy to compact the 1257 longer used, can be easily recognized, and it's easy to compact the
1639 sblocks of small strings which we do in compact_small_strings. */ 1258 sblocks of small strings which we do in compact_small_strings. */
1640 1259
@@ -1648,10 +1267,12 @@ widen_to_Lisp_Object (void *p)
1648 1267
1649#define LARGE_STRING_BYTES 1024 1268#define LARGE_STRING_BYTES 1024
1650 1269
1651/* Structure describing string memory sub-allocated from an sblock. 1270/* Struct or union describing string memory sub-allocated from an sblock.
1652 This is where the contents of Lisp strings are stored. */ 1271 This is where the contents of Lisp strings are stored. */
1653 1272
1654struct sdata 1273#ifdef GC_CHECK_STRING_BYTES
1274
1275typedef struct
1655{ 1276{
1656 /* Back-pointer to the string this sdata belongs to. If null, this 1277 /* Back-pointer to the string this sdata belongs to. If null, this
1657 structure is free, and the NBYTES member of the union below 1278 structure is free, and the NBYTES member of the union below
@@ -1661,34 +1282,42 @@ struct sdata
1661 contents. */ 1282 contents. */
1662 struct Lisp_String *string; 1283 struct Lisp_String *string;
1663 1284
1664#ifdef GC_CHECK_STRING_BYTES
1665
1666 ptrdiff_t nbytes; 1285 ptrdiff_t nbytes;
1667 unsigned char data[1]; 1286 unsigned char data[FLEXIBLE_ARRAY_MEMBER];
1287} sdata;
1668 1288
1669#define SDATA_NBYTES(S) (S)->nbytes 1289#define SDATA_NBYTES(S) (S)->nbytes
1670#define SDATA_DATA(S) (S)->data 1290#define SDATA_DATA(S) (S)->data
1671#define SDATA_SELECTOR(member) member 1291#define SDATA_SELECTOR(member) member
1672 1292
1673#else /* not GC_CHECK_STRING_BYTES */ 1293#else
1674 1294
1675 union 1295typedef union
1296{
1297 struct Lisp_String *string;
1298
1299 /* When STRING is non-null. */
1300 struct
1676 { 1301 {
1677 /* When STRING is non-null. */ 1302 struct Lisp_String *string;
1678 unsigned char data[1]; 1303 unsigned char data[FLEXIBLE_ARRAY_MEMBER];
1304 } u;
1679 1305
1680 /* When STRING is null. */ 1306 /* When STRING is null. */
1307 struct
1308 {
1309 struct Lisp_String *string;
1681 ptrdiff_t nbytes; 1310 ptrdiff_t nbytes;
1682 } u; 1311 } n;
1312} sdata;
1683 1313
1684#define SDATA_NBYTES(S) (S)->u.nbytes 1314#define SDATA_NBYTES(S) (S)->n.nbytes
1685#define SDATA_DATA(S) (S)->u.data 1315#define SDATA_DATA(S) (S)->u.data
1686#define SDATA_SELECTOR(member) u.member 1316#define SDATA_SELECTOR(member) u.member
1687 1317
1688#endif /* not GC_CHECK_STRING_BYTES */ 1318#endif /* not GC_CHECK_STRING_BYTES */
1689 1319
1690#define SDATA_DATA_OFFSET offsetof (struct sdata, SDATA_SELECTOR (data)) 1320#define SDATA_DATA_OFFSET offsetof (sdata, SDATA_SELECTOR (data))
1691};
1692 1321
1693 1322
1694/* Structure describing a block of memory which is sub-allocated to 1323/* Structure describing a block of memory which is sub-allocated to
@@ -1703,10 +1332,10 @@ struct sblock
1703 1332
1704 /* Pointer to the next free sdata block. This points past the end 1333 /* Pointer to the next free sdata block. This points past the end
1705 of the sblock if there isn't any space left in this block. */ 1334 of the sblock if there isn't any space left in this block. */
1706 struct sdata *next_free; 1335 sdata *next_free;
1707 1336
1708 /* Start of data. */ 1337 /* Start of data. */
1709 struct sdata first_data; 1338 sdata first_data;
1710}; 1339};
1711 1340
1712/* Number of Lisp strings in a string_block structure. The 1020 is 1341/* Number of Lisp strings in a string_block structure. The 1020 is
@@ -1749,7 +1378,7 @@ static EMACS_INT total_strings, total_free_strings;
1749 1378
1750/* Number of bytes used by live strings. */ 1379/* Number of bytes used by live strings. */
1751 1380
1752static EMACS_INT total_string_size; 1381static EMACS_INT total_string_bytes;
1753 1382
1754/* Given a pointer to a Lisp_String S which is on the free-list 1383/* Given a pointer to a Lisp_String S which is on the free-list
1755 string_free_list, return a pointer to its successor in the 1384 string_free_list, return a pointer to its successor in the
@@ -1762,7 +1391,7 @@ static EMACS_INT total_string_size;
1762 a pointer to the `u.data' member of its sdata structure; the 1391 a pointer to the `u.data' member of its sdata structure; the
1763 structure starts at a constant offset in front of that. */ 1392 structure starts at a constant offset in front of that. */
1764 1393
1765#define SDATA_OF_STRING(S) ((struct sdata *) ((S)->data - SDATA_DATA_OFFSET)) 1394#define SDATA_OF_STRING(S) ((sdata *) ((S)->data - SDATA_DATA_OFFSET))
1766 1395
1767 1396
1768#ifdef GC_CHECK_STRING_OVERRUN 1397#ifdef GC_CHECK_STRING_OVERRUN
@@ -1818,23 +1447,19 @@ static char const string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
1818 STRING_BYTES_BOUND, nor can it be so long that the size_t 1447 STRING_BYTES_BOUND, nor can it be so long that the size_t
1819 arithmetic in allocate_string_data would overflow while it is 1448 arithmetic in allocate_string_data would overflow while it is
1820 calculating a value to be passed to malloc. */ 1449 calculating a value to be passed to malloc. */
1821#define STRING_BYTES_MAX \ 1450static ptrdiff_t const STRING_BYTES_MAX =
1822 min (STRING_BYTES_BOUND, \ 1451 min (STRING_BYTES_BOUND,
1823 ((SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD \ 1452 ((SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD
1824 - GC_STRING_EXTRA \ 1453 - GC_STRING_EXTRA
1825 - offsetof (struct sblock, first_data) \ 1454 - offsetof (struct sblock, first_data)
1826 - SDATA_DATA_OFFSET) \ 1455 - SDATA_DATA_OFFSET)
1827 & ~(sizeof (EMACS_INT) - 1))) 1456 & ~(sizeof (EMACS_INT) - 1)));
1828 1457
1829/* Initialize string allocation. Called from init_alloc_once. */ 1458/* Initialize string allocation. Called from init_alloc_once. */
1830 1459
1831static void 1460static void
1832init_strings (void) 1461init_strings (void)
1833{ 1462{
1834 total_strings = total_free_strings = total_string_size = 0;
1835 oldest_sblock = current_sblock = large_sblocks = NULL;
1836 string_blocks = NULL;
1837 string_free_list = NULL;
1838 empty_unibyte_string = make_pure_string ("", 0, 0, 0); 1463 empty_unibyte_string = make_pure_string ("", 0, 0, 0);
1839 empty_multibyte_string = make_pure_string ("", 0, 0, 1); 1464 empty_multibyte_string = make_pure_string ("", 0, 0, 1);
1840} 1465}
@@ -1844,10 +1469,8 @@ init_strings (void)
1844 1469
1845static int check_string_bytes_count; 1470static int check_string_bytes_count;
1846 1471
1847#define CHECK_STRING_BYTES(S) STRING_BYTES (S) 1472/* Like STRING_BYTES, but with debugging check. Can be
1848 1473 called during GC, so pay attention to the mark bit. */
1849
1850/* Like GC_STRING_BYTES, but with debugging check. */
1851 1474
1852ptrdiff_t 1475ptrdiff_t
1853string_bytes (struct Lisp_String *s) 1476string_bytes (struct Lisp_String *s)
@@ -1858,7 +1481,7 @@ string_bytes (struct Lisp_String *s)
1858 if (!PURE_POINTER_P (s) 1481 if (!PURE_POINTER_P (s)
1859 && s->data 1482 && s->data
1860 && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s))) 1483 && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
1861 abort (); 1484 emacs_abort ();
1862 return nbytes; 1485 return nbytes;
1863} 1486}
1864 1487
@@ -1867,7 +1490,7 @@ string_bytes (struct Lisp_String *s)
1867static void 1490static void
1868check_sblock (struct sblock *b) 1491check_sblock (struct sblock *b)
1869{ 1492{
1870 struct sdata *from, *end, *from_end; 1493 sdata *from, *end, *from_end;
1871 1494
1872 end = b->next_free; 1495 end = b->next_free;
1873 1496
@@ -1878,27 +1501,20 @@ check_sblock (struct sblock *b)
1878 ptrdiff_t nbytes; 1501 ptrdiff_t nbytes;
1879 1502
1880 /* Check that the string size recorded in the string is the 1503 /* Check that the string size recorded in the string is the
1881 same as the one recorded in the sdata structure. */ 1504 same as the one recorded in the sdata structure. */
1882 if (from->string) 1505 nbytes = SDATA_SIZE (from->string ? string_bytes (from->string)
1883 CHECK_STRING_BYTES (from->string); 1506 : SDATA_NBYTES (from));
1884 1507 from_end = (sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
1885 if (from->string)
1886 nbytes = GC_STRING_BYTES (from->string);
1887 else
1888 nbytes = SDATA_NBYTES (from);
1889
1890 nbytes = SDATA_SIZE (nbytes);
1891 from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
1892 } 1508 }
1893} 1509}
1894 1510
1895 1511
1896/* Check validity of Lisp strings' string_bytes member. ALL_P 1512/* Check validity of Lisp strings' string_bytes member. ALL_P
1897 non-zero means check all strings, otherwise check only most 1513 means check all strings, otherwise check only most
1898 recently allocated strings. Used for hunting a bug. */ 1514 recently allocated strings. Used for hunting a bug. */
1899 1515
1900static void 1516static void
1901check_string_bytes (int all_p) 1517check_string_bytes (bool all_p)
1902{ 1518{
1903 if (all_p) 1519 if (all_p)
1904 { 1520 {
@@ -1908,16 +1524,20 @@ check_string_bytes (int all_p)
1908 { 1524 {
1909 struct Lisp_String *s = b->first_data.string; 1525 struct Lisp_String *s = b->first_data.string;
1910 if (s) 1526 if (s)
1911 CHECK_STRING_BYTES (s); 1527 string_bytes (s);
1912 } 1528 }
1913 1529
1914 for (b = oldest_sblock; b; b = b->next) 1530 for (b = oldest_sblock; b; b = b->next)
1915 check_sblock (b); 1531 check_sblock (b);
1916 } 1532 }
1917 else 1533 else if (current_sblock)
1918 check_sblock (current_sblock); 1534 check_sblock (current_sblock);
1919} 1535}
1920 1536
1537#else /* not GC_CHECK_STRING_BYTES */
1538
1539#define check_string_bytes(all) ((void) 0)
1540
1921#endif /* GC_CHECK_STRING_BYTES */ 1541#endif /* GC_CHECK_STRING_BYTES */
1922 1542
1923#ifdef GC_CHECK_STRING_FREE_LIST 1543#ifdef GC_CHECK_STRING_FREE_LIST
@@ -1935,7 +1555,7 @@ check_string_free_list (void)
1935 while (s != NULL) 1555 while (s != NULL)
1936 { 1556 {
1937 if ((uintptr_t) s < 1024) 1557 if ((uintptr_t) s < 1024)
1938 abort (); 1558 emacs_abort ();
1939 s = NEXT_FREE_LISP_STRING (s); 1559 s = NEXT_FREE_LISP_STRING (s);
1940 } 1560 }
1941} 1561}
@@ -1950,25 +1570,23 @@ allocate_string (void)
1950{ 1570{
1951 struct Lisp_String *s; 1571 struct Lisp_String *s;
1952 1572
1953 /* eassert (!handling_signal); */
1954
1955 MALLOC_BLOCK_INPUT; 1573 MALLOC_BLOCK_INPUT;
1956 1574
1957 /* If the free-list is empty, allocate a new string_block, and 1575 /* If the free-list is empty, allocate a new string_block, and
1958 add all the Lisp_Strings in it to the free-list. */ 1576 add all the Lisp_Strings in it to the free-list. */
1959 if (string_free_list == NULL) 1577 if (string_free_list == NULL)
1960 { 1578 {
1961 struct string_block *b; 1579 struct string_block *b = lisp_malloc (sizeof *b, MEM_TYPE_STRING);
1962 int i; 1580 int i;
1963 1581
1964 b = (struct string_block *) lisp_malloc (sizeof *b, MEM_TYPE_STRING);
1965 memset (b, 0, sizeof *b);
1966 b->next = string_blocks; 1582 b->next = string_blocks;
1967 string_blocks = b; 1583 string_blocks = b;
1968 1584
1969 for (i = STRING_BLOCK_SIZE - 1; i >= 0; --i) 1585 for (i = STRING_BLOCK_SIZE - 1; i >= 0; --i)
1970 { 1586 {
1971 s = b->strings + i; 1587 s = b->strings + i;
1588 /* Every string on a free list should have NULL data pointer. */
1589 s->data = NULL;
1972 NEXT_FREE_LISP_STRING (s) = string_free_list; 1590 NEXT_FREE_LISP_STRING (s) = string_free_list;
1973 string_free_list = s; 1591 string_free_list = s;
1974 } 1592 }
@@ -1984,9 +1602,6 @@ allocate_string (void)
1984 1602
1985 MALLOC_UNBLOCK_INPUT; 1603 MALLOC_UNBLOCK_INPUT;
1986 1604
1987 /* Probably not strictly necessary, but play it safe. */
1988 memset (s, 0, sizeof *s);
1989
1990 --total_free_strings; 1605 --total_free_strings;
1991 ++total_strings; 1606 ++total_strings;
1992 ++strings_consed; 1607 ++strings_consed;
@@ -2019,7 +1634,7 @@ void
2019allocate_string_data (struct Lisp_String *s, 1634allocate_string_data (struct Lisp_String *s,
2020 EMACS_INT nchars, EMACS_INT nbytes) 1635 EMACS_INT nchars, EMACS_INT nbytes)
2021{ 1636{
2022 struct sdata *data, *old_data; 1637 sdata *data, *old_data;
2023 struct sblock *b; 1638 struct sblock *b;
2024 ptrdiff_t needed, old_nbytes; 1639 ptrdiff_t needed, old_nbytes;
2025 1640
@@ -2029,8 +1644,13 @@ allocate_string_data (struct Lisp_String *s,
2029 /* Determine the number of bytes needed to store NBYTES bytes 1644 /* Determine the number of bytes needed to store NBYTES bytes
2030 of string data. */ 1645 of string data. */
2031 needed = SDATA_SIZE (nbytes); 1646 needed = SDATA_SIZE (nbytes);
2032 old_data = s->data ? SDATA_OF_STRING (s) : NULL; 1647 if (s->data)
2033 old_nbytes = GC_STRING_BYTES (s); 1648 {
1649 old_data = SDATA_OF_STRING (s);
1650 old_nbytes = STRING_BYTES (s);
1651 }
1652 else
1653 old_data = NULL;
2034 1654
2035 MALLOC_BLOCK_INPUT; 1655 MALLOC_BLOCK_INPUT;
2036 1656
@@ -2051,10 +1671,10 @@ allocate_string_data (struct Lisp_String *s,
2051 mallopt (M_MMAP_MAX, 0); 1671 mallopt (M_MMAP_MAX, 0);
2052#endif 1672#endif
2053 1673
2054 b = (struct sblock *) lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP); 1674 b = lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP);
2055 1675
2056#ifdef DOUG_LEA_MALLOC 1676#ifdef DOUG_LEA_MALLOC
2057 /* Back to a reasonable maximum of mmap'ed areas. */ 1677 /* Back to a reasonable maximum of mmap'ed areas. */
2058 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); 1678 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
2059#endif 1679#endif
2060 1680
@@ -2069,7 +1689,7 @@ allocate_string_data (struct Lisp_String *s,
2069 < (needed + GC_STRING_EXTRA))) 1689 < (needed + GC_STRING_EXTRA)))
2070 { 1690 {
2071 /* Not enough room in the current sblock. */ 1691 /* Not enough room in the current sblock. */
2072 b = (struct sblock *) lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP); 1692 b = lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
2073 b->next_free = &b->first_data; 1693 b->next_free = &b->first_data;
2074 b->first_data.string = NULL; 1694 b->first_data.string = NULL;
2075 b->next = NULL; 1695 b->next = NULL;
@@ -2084,7 +1704,7 @@ allocate_string_data (struct Lisp_String *s,
2084 b = current_sblock; 1704 b = current_sblock;
2085 1705
2086 data = b->next_free; 1706 data = b->next_free;
2087 b->next_free = (struct sdata *) ((char *) data + needed + GC_STRING_EXTRA); 1707 b->next_free = (sdata *) ((char *) data + needed + GC_STRING_EXTRA);
2088 1708
2089 MALLOC_UNBLOCK_INPUT; 1709 MALLOC_UNBLOCK_INPUT;
2090 1710
@@ -2101,9 +1721,9 @@ allocate_string_data (struct Lisp_String *s,
2101 GC_STRING_OVERRUN_COOKIE_SIZE); 1721 GC_STRING_OVERRUN_COOKIE_SIZE);
2102#endif 1722#endif
2103 1723
2104 /* If S had already data assigned, mark that as free by setting its 1724 /* Note that Faset may call to this function when S has already data
2105 string back-pointer to null, and recording the size of the data 1725 assigned. In this case, mark data as free by setting it's string
2106 in it. */ 1726 back-pointer to null, and record the size of the data in it. */
2107 if (old_data) 1727 if (old_data)
2108 { 1728 {
2109 SDATA_NBYTES (old_data) = old_nbytes; 1729 SDATA_NBYTES (old_data) = old_nbytes;
@@ -2124,7 +1744,7 @@ sweep_strings (void)
2124 1744
2125 string_free_list = NULL; 1745 string_free_list = NULL;
2126 total_strings = total_free_strings = 0; 1746 total_strings = total_free_strings = 0;
2127 total_string_size = 0; 1747 total_string_bytes = 0;
2128 1748
2129 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */ 1749 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2130 for (b = string_blocks; b; b = next) 1750 for (b = string_blocks; b; b = next)
@@ -2146,25 +1766,25 @@ sweep_strings (void)
2146 /* String is live; unmark it and its intervals. */ 1766 /* String is live; unmark it and its intervals. */
2147 UNMARK_STRING (s); 1767 UNMARK_STRING (s);
2148 1768
2149 if (!NULL_INTERVAL_P (s->intervals)) 1769 /* Do not use string_(set|get)_intervals here. */
2150 UNMARK_BALANCE_INTERVALS (s->intervals); 1770 s->intervals = balance_intervals (s->intervals);
2151 1771
2152 ++total_strings; 1772 ++total_strings;
2153 total_string_size += STRING_BYTES (s); 1773 total_string_bytes += STRING_BYTES (s);
2154 } 1774 }
2155 else 1775 else
2156 { 1776 {
2157 /* String is dead. Put it on the free-list. */ 1777 /* String is dead. Put it on the free-list. */
2158 struct sdata *data = SDATA_OF_STRING (s); 1778 sdata *data = SDATA_OF_STRING (s);
2159 1779
2160 /* Save the size of S in its sdata so that we know 1780 /* Save the size of S in its sdata so that we know
2161 how large that is. Reset the sdata's string 1781 how large that is. Reset the sdata's string
2162 back-pointer so that we know it's free. */ 1782 back-pointer so that we know it's free. */
2163#ifdef GC_CHECK_STRING_BYTES 1783#ifdef GC_CHECK_STRING_BYTES
2164 if (GC_STRING_BYTES (s) != SDATA_NBYTES (data)) 1784 if (string_bytes (s) != SDATA_NBYTES (data))
2165 abort (); 1785 emacs_abort ();
2166#else 1786#else
2167 data->u.nbytes = GC_STRING_BYTES (s); 1787 data->n.nbytes = STRING_BYTES (s);
2168#endif 1788#endif
2169 data->string = NULL; 1789 data->string = NULL;
2170 1790
@@ -2245,13 +1865,13 @@ static void
2245compact_small_strings (void) 1865compact_small_strings (void)
2246{ 1866{
2247 struct sblock *b, *tb, *next; 1867 struct sblock *b, *tb, *next;
2248 struct sdata *from, *to, *end, *tb_end; 1868 sdata *from, *to, *end, *tb_end;
2249 struct sdata *to_end, *from_end; 1869 sdata *to_end, *from_end;
2250 1870
2251 /* TB is the sblock we copy to, TO is the sdata within TB we copy 1871 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2252 to, and TB_END is the end of TB. */ 1872 to, and TB_END is the end of TB. */
2253 tb = oldest_sblock; 1873 tb = oldest_sblock;
2254 tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE); 1874 tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
2255 to = &tb->first_data; 1875 to = &tb->first_data;
2256 1876
2257 /* Step through the blocks from the oldest to the youngest. We 1877 /* Step through the blocks from the oldest to the youngest. We
@@ -2260,58 +1880,53 @@ compact_small_strings (void)
2260 for (b = oldest_sblock; b; b = b->next) 1880 for (b = oldest_sblock; b; b = b->next)
2261 { 1881 {
2262 end = b->next_free; 1882 end = b->next_free;
2263 xassert ((char *) end <= (char *) b + SBLOCK_SIZE); 1883 eassert ((char *) end <= (char *) b + SBLOCK_SIZE);
2264 1884
2265 for (from = &b->first_data; from < end; from = from_end) 1885 for (from = &b->first_data; from < end; from = from_end)
2266 { 1886 {
2267 /* Compute the next FROM here because copying below may 1887 /* Compute the next FROM here because copying below may
2268 overwrite data we need to compute it. */ 1888 overwrite data we need to compute it. */
2269 ptrdiff_t nbytes; 1889 ptrdiff_t nbytes;
1890 struct Lisp_String *s = from->string;
2270 1891
2271#ifdef GC_CHECK_STRING_BYTES 1892#ifdef GC_CHECK_STRING_BYTES
2272 /* Check that the string size recorded in the string is the 1893 /* Check that the string size recorded in the string is the
2273 same as the one recorded in the sdata structure. */ 1894 same as the one recorded in the sdata structure. */
2274 if (from->string 1895 if (s && string_bytes (s) != SDATA_NBYTES (from))
2275 && GC_STRING_BYTES (from->string) != SDATA_NBYTES (from)) 1896 emacs_abort ();
2276 abort ();
2277#endif /* GC_CHECK_STRING_BYTES */ 1897#endif /* GC_CHECK_STRING_BYTES */
2278 1898
2279 if (from->string) 1899 nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from);
2280 nbytes = GC_STRING_BYTES (from->string); 1900 eassert (nbytes <= LARGE_STRING_BYTES);
2281 else
2282 nbytes = SDATA_NBYTES (from);
2283
2284 if (nbytes > LARGE_STRING_BYTES)
2285 abort ();
2286 1901
2287 nbytes = SDATA_SIZE (nbytes); 1902 nbytes = SDATA_SIZE (nbytes);
2288 from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA); 1903 from_end = (sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
2289 1904
2290#ifdef GC_CHECK_STRING_OVERRUN 1905#ifdef GC_CHECK_STRING_OVERRUN
2291 if (memcmp (string_overrun_cookie, 1906 if (memcmp (string_overrun_cookie,
2292 (char *) from_end - GC_STRING_OVERRUN_COOKIE_SIZE, 1907 (char *) from_end - GC_STRING_OVERRUN_COOKIE_SIZE,
2293 GC_STRING_OVERRUN_COOKIE_SIZE)) 1908 GC_STRING_OVERRUN_COOKIE_SIZE))
2294 abort (); 1909 emacs_abort ();
2295#endif 1910#endif
2296 1911
2297 /* FROM->string non-null means it's alive. Copy its data. */ 1912 /* Non-NULL S means it's alive. Copy its data. */
2298 if (from->string) 1913 if (s)
2299 { 1914 {
2300 /* If TB is full, proceed with the next sblock. */ 1915 /* If TB is full, proceed with the next sblock. */
2301 to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA); 1916 to_end = (sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
2302 if (to_end > tb_end) 1917 if (to_end > tb_end)
2303 { 1918 {
2304 tb->next_free = to; 1919 tb->next_free = to;
2305 tb = tb->next; 1920 tb = tb->next;
2306 tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE); 1921 tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
2307 to = &tb->first_data; 1922 to = &tb->first_data;
2308 to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA); 1923 to_end = (sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
2309 } 1924 }
2310 1925
2311 /* Copy, and update the string's `data' pointer. */ 1926 /* Copy, and update the string's `data' pointer. */
2312 if (from != to) 1927 if (from != to)
2313 { 1928 {
2314 xassert (tb != b || to < from); 1929 eassert (tb != b || to < from);
2315 memmove (to, from, nbytes + GC_STRING_EXTRA); 1930 memmove (to, from, nbytes + GC_STRING_EXTRA);
2316 to->string->data = SDATA_DATA (to); 1931 to->string->data = SDATA_DATA (to);
2317 } 1932 }
@@ -2399,6 +2014,8 @@ LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2399 ptrdiff_t length_in_chars; 2014 ptrdiff_t length_in_chars;
2400 EMACS_INT length_in_elts; 2015 EMACS_INT length_in_elts;
2401 int bits_per_value; 2016 int bits_per_value;
2017 int extra_bool_elts = ((bool_header_size - header_size + word_size - 1)
2018 / word_size);
2402 2019
2403 CHECK_NATNUM (length); 2020 CHECK_NATNUM (length);
2404 2021
@@ -2406,12 +2023,10 @@ LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2406 2023
2407 length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value; 2024 length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
2408 2025
2409 /* We must allocate one more elements than LENGTH_IN_ELTS for the 2026 val = Fmake_vector (make_number (length_in_elts + extra_bool_elts), Qnil);
2410 slot `size' of the struct Lisp_Bool_Vector. */
2411 val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
2412 2027
2413 /* No Lisp_Object to trace in there. */ 2028 /* No Lisp_Object to trace in there. */
2414 XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0); 2029 XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0, 0);
2415 2030
2416 p = XBOOL_VECTOR (val); 2031 p = XBOOL_VECTOR (val);
2417 p->size = XFASTINT (length); 2032 p->size = XFASTINT (length);
@@ -2424,7 +2039,7 @@ LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2424 2039
2425 /* Clear any extraneous bits in the last byte. */ 2040 /* Clear any extraneous bits in the last byte. */
2426 p->data[length_in_chars - 1] 2041 p->data[length_in_chars - 1]
2427 &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1; 2042 &= (1 << ((XFASTINT (length) - 1) % BOOL_VECTOR_BITS_PER_CHAR + 1)) - 1;
2428 } 2043 }
2429 2044
2430 return val; 2045 return val;
@@ -2502,9 +2117,9 @@ make_string_from_bytes (const char *contents,
2502 2117
2503Lisp_Object 2118Lisp_Object
2504make_specified_string (const char *contents, 2119make_specified_string (const char *contents,
2505 ptrdiff_t nchars, ptrdiff_t nbytes, int multibyte) 2120 ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte)
2506{ 2121{
2507 register Lisp_Object val; 2122 Lisp_Object val;
2508 2123
2509 if (nchars < 0) 2124 if (nchars < 0)
2510 { 2125 {
@@ -2522,16 +2137,6 @@ make_specified_string (const char *contents,
2522} 2137}
2523 2138
2524 2139
2525/* Make a string from the data at STR, treating it as multibyte if the
2526 data warrants. */
2527
2528Lisp_Object
2529build_string (const char *str)
2530{
2531 return make_string (str, strlen (str));
2532}
2533
2534
2535/* Return an unibyte Lisp_String set up to hold LENGTH characters 2140/* Return an unibyte Lisp_String set up to hold LENGTH characters
2536 occupying LENGTH bytes. */ 2141 occupying LENGTH bytes. */
2537 2142
@@ -2558,17 +2163,32 @@ make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes)
2558 struct Lisp_String *s; 2163 struct Lisp_String *s;
2559 2164
2560 if (nchars < 0) 2165 if (nchars < 0)
2561 abort (); 2166 emacs_abort ();
2562 if (!nbytes) 2167 if (!nbytes)
2563 return empty_multibyte_string; 2168 return empty_multibyte_string;
2564 2169
2565 s = allocate_string (); 2170 s = allocate_string ();
2171 s->intervals = NULL;
2566 allocate_string_data (s, nchars, nbytes); 2172 allocate_string_data (s, nchars, nbytes);
2567 XSETSTRING (string, s); 2173 XSETSTRING (string, s);
2568 string_chars_consed += nbytes; 2174 string_chars_consed += nbytes;
2569 return string; 2175 return string;
2570} 2176}
2571 2177
2178/* Print arguments to BUF according to a FORMAT, then return
2179 a Lisp_String initialized with the data from BUF. */
2180
2181Lisp_Object
2182make_formatted_string (char *buf, const char *format, ...)
2183{
2184 va_list ap;
2185 int length;
2186
2187 va_start (ap, format);
2188 length = vsprintf (buf, format, ap);
2189 va_end (ap);
2190 return make_string (buf, length);
2191}
2572 2192
2573 2193
2574/*********************************************************************** 2194/***********************************************************************
@@ -2628,24 +2248,12 @@ static struct float_block *float_block;
2628 2248
2629/* Index of first unused Lisp_Float in the current float_block. */ 2249/* Index of first unused Lisp_Float in the current float_block. */
2630 2250
2631static int float_block_index; 2251static int float_block_index = FLOAT_BLOCK_SIZE;
2632 2252
2633/* Free-list of Lisp_Floats. */ 2253/* Free-list of Lisp_Floats. */
2634 2254
2635static struct Lisp_Float *float_free_list; 2255static struct Lisp_Float *float_free_list;
2636 2256
2637
2638/* Initialize float allocation. */
2639
2640static void
2641init_float (void)
2642{
2643 float_block = NULL;
2644 float_block_index = FLOAT_BLOCK_SIZE; /* Force alloc of new float_block. */
2645 float_free_list = 0;
2646}
2647
2648
2649/* Return a new float object with value FLOAT_VALUE. */ 2257/* Return a new float object with value FLOAT_VALUE. */
2650 2258
2651Lisp_Object 2259Lisp_Object
@@ -2653,8 +2261,6 @@ make_float (double float_value)
2653{ 2261{
2654 register Lisp_Object val; 2262 register Lisp_Object val;
2655 2263
2656 /* eassert (!handling_signal); */
2657
2658 MALLOC_BLOCK_INPUT; 2264 MALLOC_BLOCK_INPUT;
2659 2265
2660 if (float_free_list) 2266 if (float_free_list)
@@ -2668,14 +2274,13 @@ make_float (double float_value)
2668 { 2274 {
2669 if (float_block_index == FLOAT_BLOCK_SIZE) 2275 if (float_block_index == FLOAT_BLOCK_SIZE)
2670 { 2276 {
2671 register struct float_block *new; 2277 struct float_block *new
2672 2278 = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT);
2673 new = (struct float_block *) lisp_align_malloc (sizeof *new,
2674 MEM_TYPE_FLOAT);
2675 new->next = float_block; 2279 new->next = float_block;
2676 memset (new->gcmarkbits, 0, sizeof new->gcmarkbits); 2280 memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
2677 float_block = new; 2281 float_block = new;
2678 float_block_index = 0; 2282 float_block_index = 0;
2283 total_free_floats += FLOAT_BLOCK_SIZE;
2679 } 2284 }
2680 XSETFLOAT (val, &float_block->floats[float_block_index]); 2285 XSETFLOAT (val, &float_block->floats[float_block_index]);
2681 float_block_index++; 2286 float_block_index++;
@@ -2687,6 +2292,7 @@ make_float (double float_value)
2687 eassert (!FLOAT_MARKED_P (XFLOAT (val))); 2292 eassert (!FLOAT_MARKED_P (XFLOAT (val)));
2688 consing_since_gc += sizeof (struct Lisp_Float); 2293 consing_since_gc += sizeof (struct Lisp_Float);
2689 floats_consed++; 2294 floats_consed++;
2295 total_free_floats--;
2690 return val; 2296 return val;
2691} 2297}
2692 2298
@@ -2701,8 +2307,10 @@ make_float (double float_value)
2701 GC are put on a free list to be reallocated before allocating 2307 GC are put on a free list to be reallocated before allocating
2702 any new cons cells from the latest cons_block. */ 2308 any new cons cells from the latest cons_block. */
2703 2309
2704#define CONS_BLOCK_SIZE \ 2310#define CONS_BLOCK_SIZE \
2705 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \ 2311 (((BLOCK_BYTES - sizeof (struct cons_block *) \
2312 /* The compiler might add padding at the end. */ \
2313 - (sizeof (struct Lisp_Cons) - sizeof (int))) * CHAR_BIT) \
2706 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1)) 2314 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2707 2315
2708#define CONS_BLOCK(fptr) \ 2316#define CONS_BLOCK(fptr) \
@@ -2734,24 +2342,12 @@ static struct cons_block *cons_block;
2734 2342
2735/* Index of first unused Lisp_Cons in the current block. */ 2343/* Index of first unused Lisp_Cons in the current block. */
2736 2344
2737static int cons_block_index; 2345static int cons_block_index = CONS_BLOCK_SIZE;
2738 2346
2739/* Free-list of Lisp_Cons structures. */ 2347/* Free-list of Lisp_Cons structures. */
2740 2348
2741static struct Lisp_Cons *cons_free_list; 2349static struct Lisp_Cons *cons_free_list;
2742 2350
2743
2744/* Initialize cons allocation. */
2745
2746static void
2747init_cons (void)
2748{
2749 cons_block = NULL;
2750 cons_block_index = CONS_BLOCK_SIZE; /* Force alloc of new cons_block. */
2751 cons_free_list = 0;
2752}
2753
2754
2755/* Explicitly free a cons cell by putting it on the free-list. */ 2351/* Explicitly free a cons cell by putting it on the free-list. */
2756 2352
2757void 2353void
@@ -2762,6 +2358,8 @@ free_cons (struct Lisp_Cons *ptr)
2762 ptr->car = Vdead; 2358 ptr->car = Vdead;
2763#endif 2359#endif
2764 cons_free_list = ptr; 2360 cons_free_list = ptr;
2361 consing_since_gc -= sizeof *ptr;
2362 total_free_conses++;
2765} 2363}
2766 2364
2767DEFUN ("cons", Fcons, Scons, 2, 2, 0, 2365DEFUN ("cons", Fcons, Scons, 2, 2, 0,
@@ -2770,8 +2368,6 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
2770{ 2368{
2771 register Lisp_Object val; 2369 register Lisp_Object val;
2772 2370
2773 /* eassert (!handling_signal); */
2774
2775 MALLOC_BLOCK_INPUT; 2371 MALLOC_BLOCK_INPUT;
2776 2372
2777 if (cons_free_list) 2373 if (cons_free_list)
@@ -2785,13 +2381,13 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
2785 { 2381 {
2786 if (cons_block_index == CONS_BLOCK_SIZE) 2382 if (cons_block_index == CONS_BLOCK_SIZE)
2787 { 2383 {
2788 register struct cons_block *new; 2384 struct cons_block *new
2789 new = (struct cons_block *) lisp_align_malloc (sizeof *new, 2385 = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS);
2790 MEM_TYPE_CONS);
2791 memset (new->gcmarkbits, 0, sizeof new->gcmarkbits); 2386 memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
2792 new->next = cons_block; 2387 new->next = cons_block;
2793 cons_block = new; 2388 cons_block = new;
2794 cons_block_index = 0; 2389 cons_block_index = 0;
2390 total_free_conses += CONS_BLOCK_SIZE;
2795 } 2391 }
2796 XSETCONS (val, &cons_block->conses[cons_block_index]); 2392 XSETCONS (val, &cons_block->conses[cons_block_index]);
2797 cons_block_index++; 2393 cons_block_index++;
@@ -2803,6 +2399,7 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
2803 XSETCDR (val, cdr); 2399 XSETCDR (val, cdr);
2804 eassert (!CONS_MARKED_P (XCONS (val))); 2400 eassert (!CONS_MARKED_P (XCONS (val)));
2805 consing_since_gc += sizeof (struct Lisp_Cons); 2401 consing_since_gc += sizeof (struct Lisp_Cons);
2402 total_free_conses--;
2806 cons_cells_consed++; 2403 cons_cells_consed++;
2807 return val; 2404 return val;
2808} 2405}
@@ -2855,6 +2452,38 @@ list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, L
2855 Fcons (arg5, Qnil))))); 2452 Fcons (arg5, Qnil)))));
2856} 2453}
2857 2454
2455/* Make a list of COUNT Lisp_Objects, where ARG is the
2456 first one. Allocate conses from pure space if TYPE
2457 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
2458
2459Lisp_Object
2460listn (enum constype type, ptrdiff_t count, Lisp_Object arg, ...)
2461{
2462 va_list ap;
2463 ptrdiff_t i;
2464 Lisp_Object val, *objp;
2465
2466 /* Change to SAFE_ALLOCA if you hit this eassert. */
2467 eassert (count <= MAX_ALLOCA / word_size);
2468
2469 objp = alloca (count * word_size);
2470 objp[0] = arg;
2471 va_start (ap, arg);
2472 for (i = 1; i < count; i++)
2473 objp[i] = va_arg (ap, Lisp_Object);
2474 va_end (ap);
2475
2476 for (val = Qnil, i = count - 1; i >= 0; i--)
2477 {
2478 if (type == CONSTYPE_PURE)
2479 val = pure_cons (objp[i], val);
2480 else if (type == CONSTYPE_HEAP)
2481 val = Fcons (objp[i], val);
2482 else
2483 emacs_abort ();
2484 }
2485 return val;
2486}
2858 2487
2859DEFUN ("list", Flist, Slist, 0, MANY, 0, 2488DEFUN ("list", Flist, Slist, 0, MANY, 0,
2860 doc: /* Return a newly created list with specified arguments as elements. 2489 doc: /* Return a newly created list with specified arguments as elements.
@@ -2926,17 +2555,364 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
2926 Vector Allocation 2555 Vector Allocation
2927 ***********************************************************************/ 2556 ***********************************************************************/
2928 2557
2929/* Singly-linked list of all vectors. */ 2558/* This value is balanced well enough to avoid too much internal overhead
2559 for the most common cases; it's not required to be a power of two, but
2560 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2930 2561
2931static struct Lisp_Vector *all_vectors; 2562#define VECTOR_BLOCK_SIZE 4096
2932 2563
2933/* Handy constants for vectorlike objects. */ 2564/* Align allocation request sizes to be a multiple of ROUNDUP_SIZE. */
2934enum 2565enum
2935 { 2566 {
2936 header_size = offsetof (struct Lisp_Vector, contents), 2567 roundup_size = COMMON_MULTIPLE (word_size, USE_LSB_TAG ? GCALIGNMENT : 1)
2937 word_size = sizeof (Lisp_Object)
2938 }; 2568 };
2939 2569
2570/* ROUNDUP_SIZE must be a power of 2. */
2571verify ((roundup_size & (roundup_size - 1)) == 0);
2572
2573/* Verify assumptions described above. */
2574verify ((VECTOR_BLOCK_SIZE % roundup_size) == 0);
2575verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS));
2576
2577/* Round up X to nearest mult-of-ROUNDUP_SIZE. */
2578
2579#define vroundup(x) (((x) + (roundup_size - 1)) & ~(roundup_size - 1))
2580
2581/* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2582
2583#define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup (sizeof (void *)))
2584
2585/* Size of the minimal vector allocated from block. */
2586
2587#define VBLOCK_BYTES_MIN vroundup (header_size + sizeof (Lisp_Object))
2588
2589/* Size of the largest vector allocated from block. */
2590
2591#define VBLOCK_BYTES_MAX \
2592 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2593
2594/* We maintain one free list for each possible block-allocated
2595 vector size, and this is the number of free lists we have. */
2596
2597#define VECTOR_MAX_FREE_LIST_INDEX \
2598 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
2599
2600/* Common shortcut to advance vector pointer over a block data. */
2601
2602#define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
2603
2604/* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
2605
2606#define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
2607
2608/* Get and set the next field in block-allocated vectorlike objects on
2609 the free list. Doing it this way respects C's aliasing rules.
2610 We could instead make 'contents' a union, but that would mean
2611 changes everywhere that the code uses 'contents'. */
2612static struct Lisp_Vector *
2613next_in_free_list (struct Lisp_Vector *v)
2614{
2615 intptr_t i = XLI (v->contents[0]);
2616 return (struct Lisp_Vector *) i;
2617}
2618static void
2619set_next_in_free_list (struct Lisp_Vector *v, struct Lisp_Vector *next)
2620{
2621 v->contents[0] = XIL ((intptr_t) next);
2622}
2623
2624/* Common shortcut to setup vector on a free list. */
2625
2626#define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
2627 do { \
2628 (tmp) = ((nbytes - header_size) / word_size); \
2629 XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \
2630 eassert ((nbytes) % roundup_size == 0); \
2631 (tmp) = VINDEX (nbytes); \
2632 eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
2633 set_next_in_free_list (v, vector_free_lists[tmp]); \
2634 vector_free_lists[tmp] = (v); \
2635 total_free_vector_slots += (nbytes) / word_size; \
2636 } while (0)
2637
2638/* This internal type is used to maintain the list of large vectors
2639 which are allocated at their own, e.g. outside of vector blocks. */
2640
2641struct large_vector
2642{
2643 union {
2644 struct large_vector *vector;
2645#if USE_LSB_TAG
2646 /* We need to maintain ROUNDUP_SIZE alignment for the vector member. */
2647 unsigned char c[vroundup (sizeof (struct large_vector *))];
2648#endif
2649 } next;
2650 struct Lisp_Vector v;
2651};
2652
2653/* This internal type is used to maintain an underlying storage
2654 for small vectors. */
2655
2656struct vector_block
2657{
2658 char data[VECTOR_BLOCK_BYTES];
2659 struct vector_block *next;
2660};
2661
2662/* Chain of vector blocks. */
2663
2664static struct vector_block *vector_blocks;
2665
2666/* Vector free lists, where NTH item points to a chain of free
2667 vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
2668
2669static struct Lisp_Vector *vector_free_lists[VECTOR_MAX_FREE_LIST_INDEX];
2670
2671/* Singly-linked list of large vectors. */
2672
2673static struct large_vector *large_vectors;
2674
2675/* The only vector with 0 slots, allocated from pure space. */
2676
2677Lisp_Object zero_vector;
2678
2679/* Number of live vectors. */
2680
2681static EMACS_INT total_vectors;
2682
2683/* Total size of live and free vectors, in Lisp_Object units. */
2684
2685static EMACS_INT total_vector_slots, total_free_vector_slots;
2686
2687/* Get a new vector block. */
2688
2689static struct vector_block *
2690allocate_vector_block (void)
2691{
2692 struct vector_block *block = xmalloc (sizeof *block);
2693
2694#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2695 mem_insert (block->data, block->data + VECTOR_BLOCK_BYTES,
2696 MEM_TYPE_VECTOR_BLOCK);
2697#endif
2698
2699 block->next = vector_blocks;
2700 vector_blocks = block;
2701 return block;
2702}
2703
2704/* Called once to initialize vector allocation. */
2705
2706static void
2707init_vectors (void)
2708{
2709 zero_vector = make_pure_vector (0);
2710}
2711
2712/* Allocate vector from a vector block. */
2713
2714static struct Lisp_Vector *
2715allocate_vector_from_block (size_t nbytes)
2716{
2717 struct Lisp_Vector *vector;
2718 struct vector_block *block;
2719 size_t index, restbytes;
2720
2721 eassert (VBLOCK_BYTES_MIN <= nbytes && nbytes <= VBLOCK_BYTES_MAX);
2722 eassert (nbytes % roundup_size == 0);
2723
2724 /* First, try to allocate from a free list
2725 containing vectors of the requested size. */
2726 index = VINDEX (nbytes);
2727 if (vector_free_lists[index])
2728 {
2729 vector = vector_free_lists[index];
2730 vector_free_lists[index] = next_in_free_list (vector);
2731 total_free_vector_slots -= nbytes / word_size;
2732 return vector;
2733 }
2734
2735 /* Next, check free lists containing larger vectors. Since
2736 we will split the result, we should have remaining space
2737 large enough to use for one-slot vector at least. */
2738 for (index = VINDEX (nbytes + VBLOCK_BYTES_MIN);
2739 index < VECTOR_MAX_FREE_LIST_INDEX; index++)
2740 if (vector_free_lists[index])
2741 {
2742 /* This vector is larger than requested. */
2743 vector = vector_free_lists[index];
2744 vector_free_lists[index] = next_in_free_list (vector);
2745 total_free_vector_slots -= nbytes / word_size;
2746
2747 /* Excess bytes are used for the smaller vector,
2748 which should be set on an appropriate free list. */
2749 restbytes = index * roundup_size + VBLOCK_BYTES_MIN - nbytes;
2750 eassert (restbytes % roundup_size == 0);
2751 SETUP_ON_FREE_LIST (ADVANCE (vector, nbytes), restbytes, index);
2752 return vector;
2753 }
2754
2755 /* Finally, need a new vector block. */
2756 block = allocate_vector_block ();
2757
2758 /* New vector will be at the beginning of this block. */
2759 vector = (struct Lisp_Vector *) block->data;
2760
2761 /* If the rest of space from this block is large enough
2762 for one-slot vector at least, set up it on a free list. */
2763 restbytes = VECTOR_BLOCK_BYTES - nbytes;
2764 if (restbytes >= VBLOCK_BYTES_MIN)
2765 {
2766 eassert (restbytes % roundup_size == 0);
2767 SETUP_ON_FREE_LIST (ADVANCE (vector, nbytes), restbytes, index);
2768 }
2769 return vector;
2770}
2771
2772/* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
2773
2774#define VECTOR_IN_BLOCK(vector, block) \
2775 ((char *) (vector) <= (block)->data \
2776 + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
2777
2778/* Return the memory footprint of V in bytes. */
2779
2780static ptrdiff_t
2781vector_nbytes (struct Lisp_Vector *v)
2782{
2783 ptrdiff_t size = v->header.size & ~ARRAY_MARK_FLAG;
2784
2785 if (size & PSEUDOVECTOR_FLAG)
2786 {
2787 if (PSEUDOVECTOR_TYPEP (&v->header, PVEC_BOOL_VECTOR))
2788 size = (bool_header_size
2789 + (((struct Lisp_Bool_Vector *) v)->size
2790 + BOOL_VECTOR_BITS_PER_CHAR - 1)
2791 / BOOL_VECTOR_BITS_PER_CHAR);
2792 else
2793 size = (header_size
2794 + ((size & PSEUDOVECTOR_SIZE_MASK)
2795 + ((size & PSEUDOVECTOR_REST_MASK)
2796 >> PSEUDOVECTOR_SIZE_BITS)) * word_size);
2797 }
2798 else
2799 size = header_size + size * word_size;
2800 return vroundup (size);
2801}
2802
2803/* Reclaim space used by unmarked vectors. */
2804
2805static void
2806sweep_vectors (void)
2807{
2808 struct vector_block *block, **bprev = &vector_blocks;
2809 struct large_vector *lv, **lvprev = &large_vectors;
2810 struct Lisp_Vector *vector, *next;
2811
2812 total_vectors = total_vector_slots = total_free_vector_slots = 0;
2813 memset (vector_free_lists, 0, sizeof (vector_free_lists));
2814
2815 /* Looking through vector blocks. */
2816
2817 for (block = vector_blocks; block; block = *bprev)
2818 {
2819 bool free_this_block = 0;
2820 ptrdiff_t nbytes;
2821
2822 for (vector = (struct Lisp_Vector *) block->data;
2823 VECTOR_IN_BLOCK (vector, block); vector = next)
2824 {
2825 if (VECTOR_MARKED_P (vector))
2826 {
2827 VECTOR_UNMARK (vector);
2828 total_vectors++;
2829 nbytes = vector_nbytes (vector);
2830 total_vector_slots += nbytes / word_size;
2831 next = ADVANCE (vector, nbytes);
2832 }
2833 else
2834 {
2835 ptrdiff_t total_bytes;
2836
2837 nbytes = vector_nbytes (vector);
2838 total_bytes = nbytes;
2839 next = ADVANCE (vector, nbytes);
2840
2841 /* While NEXT is not marked, try to coalesce with VECTOR,
2842 thus making VECTOR of the largest possible size. */
2843
2844 while (VECTOR_IN_BLOCK (next, block))
2845 {
2846 if (VECTOR_MARKED_P (next))
2847 break;
2848 nbytes = vector_nbytes (next);
2849 total_bytes += nbytes;
2850 next = ADVANCE (next, nbytes);
2851 }
2852
2853 eassert (total_bytes % roundup_size == 0);
2854
2855 if (vector == (struct Lisp_Vector *) block->data
2856 && !VECTOR_IN_BLOCK (next, block))
2857 /* This block should be freed because all of it's
2858 space was coalesced into the only free vector. */
2859 free_this_block = 1;
2860 else
2861 {
2862 int tmp;
2863 SETUP_ON_FREE_LIST (vector, total_bytes, tmp);
2864 }
2865 }
2866 }
2867
2868 if (free_this_block)
2869 {
2870 *bprev = block->next;
2871#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
2872 mem_delete (mem_find (block->data));
2873#endif
2874 xfree (block);
2875 }
2876 else
2877 bprev = &block->next;
2878 }
2879
2880 /* Sweep large vectors. */
2881
2882 for (lv = large_vectors; lv; lv = *lvprev)
2883 {
2884 vector = &lv->v;
2885 if (VECTOR_MARKED_P (vector))
2886 {
2887 VECTOR_UNMARK (vector);
2888 total_vectors++;
2889 if (vector->header.size & PSEUDOVECTOR_FLAG)
2890 {
2891 struct Lisp_Bool_Vector *b = (struct Lisp_Bool_Vector *) vector;
2892
2893 /* All non-bool pseudovectors are small enough to be allocated
2894 from vector blocks. This code should be redesigned if some
2895 pseudovector type grows beyond VBLOCK_BYTES_MAX. */
2896 eassert (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_BOOL_VECTOR));
2897
2898 total_vector_slots
2899 += (bool_header_size
2900 + ((b->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
2901 / BOOL_VECTOR_BITS_PER_CHAR)) / word_size;
2902 }
2903 else
2904 total_vector_slots
2905 += header_size / word_size + vector->header.size;
2906 lvprev = &lv->next.vector;
2907 }
2908 else
2909 {
2910 *lvprev = lv->next.vector;
2911 lisp_free (lv);
2912 }
2913 }
2914}
2915
2940/* Value is a pointer to a newly allocated Lisp_Vector structure 2916/* Value is a pointer to a newly allocated Lisp_Vector structure
2941 with room for LEN Lisp_Objects. */ 2917 with room for LEN Lisp_Objects. */
2942 2918
@@ -2944,33 +2920,43 @@ static struct Lisp_Vector *
2944allocate_vectorlike (ptrdiff_t len) 2920allocate_vectorlike (ptrdiff_t len)
2945{ 2921{
2946 struct Lisp_Vector *p; 2922 struct Lisp_Vector *p;
2947 size_t nbytes;
2948 2923
2949 MALLOC_BLOCK_INPUT; 2924 MALLOC_BLOCK_INPUT;
2950 2925
2926 if (len == 0)
2927 p = XVECTOR (zero_vector);
2928 else
2929 {
2930 size_t nbytes = header_size + len * word_size;
2931
2951#ifdef DOUG_LEA_MALLOC 2932#ifdef DOUG_LEA_MALLOC
2952 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed 2933 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2953 because mapped region contents are not preserved in 2934 because mapped region contents are not preserved in
2954 a dumped Emacs. */ 2935 a dumped Emacs. */
2955 mallopt (M_MMAP_MAX, 0); 2936 mallopt (M_MMAP_MAX, 0);
2956#endif 2937#endif
2957 2938
2958 /* This gets triggered by code which I haven't bothered to fix. --Stef */ 2939 if (nbytes <= VBLOCK_BYTES_MAX)
2959 /* eassert (!handling_signal); */ 2940 p = allocate_vector_from_block (vroundup (nbytes));
2960 2941 else
2961 nbytes = header_size + len * word_size; 2942 {
2962 p = (struct Lisp_Vector *) lisp_malloc (nbytes, MEM_TYPE_VECTORLIKE); 2943 struct large_vector *lv
2944 = lisp_malloc ((offsetof (struct large_vector, v.contents)
2945 + len * word_size),
2946 MEM_TYPE_VECTORLIKE);
2947 lv->next.vector = large_vectors;
2948 large_vectors = lv;
2949 p = &lv->v;
2950 }
2963 2951
2964#ifdef DOUG_LEA_MALLOC 2952#ifdef DOUG_LEA_MALLOC
2965 /* Back to a reasonable maximum of mmap'ed areas. */ 2953 /* Back to a reasonable maximum of mmap'ed areas. */
2966 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); 2954 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
2967#endif 2955#endif
2968 2956
2969 consing_since_gc += nbytes; 2957 consing_since_gc += nbytes;
2970 vector_cells_consed += len; 2958 vector_cells_consed += len;
2971 2959 }
2972 p->header.next.vector = all_vectors;
2973 all_vectors = p;
2974 2960
2975 MALLOC_UNBLOCK_INPUT; 2961 MALLOC_UNBLOCK_INPUT;
2976 2962
@@ -2997,63 +2983,90 @@ allocate_vector (EMACS_INT len)
2997/* Allocate other vector-like structures. */ 2983/* Allocate other vector-like structures. */
2998 2984
2999struct Lisp_Vector * 2985struct Lisp_Vector *
3000allocate_pseudovector (int memlen, int lisplen, int tag) 2986allocate_pseudovector (int memlen, int lisplen, enum pvec_type tag)
3001{ 2987{
3002 struct Lisp_Vector *v = allocate_vectorlike (memlen); 2988 struct Lisp_Vector *v = allocate_vectorlike (memlen);
3003 int i; 2989 int i;
3004 2990
2991 /* Catch bogus values. */
2992 eassert (tag <= PVEC_FONT);
2993 eassert (memlen - lisplen <= (1 << PSEUDOVECTOR_REST_BITS) - 1);
2994 eassert (lisplen <= (1 << PSEUDOVECTOR_SIZE_BITS) - 1);
2995
3005 /* Only the first lisplen slots will be traced normally by the GC. */ 2996 /* Only the first lisplen slots will be traced normally by the GC. */
3006 for (i = 0; i < lisplen; ++i) 2997 for (i = 0; i < lisplen; ++i)
3007 v->contents[i] = Qnil; 2998 v->contents[i] = Qnil;
3008 2999
3009 XSETPVECTYPESIZE (v, tag, lisplen); 3000 XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen);
3010 return v; 3001 return v;
3011} 3002}
3012 3003
3004struct buffer *
3005allocate_buffer (void)
3006{
3007 struct buffer *b = lisp_malloc (sizeof *b, MEM_TYPE_BUFFER);
3008
3009 BUFFER_PVEC_INIT (b);
3010 /* Put B on the chain of all buffers including killed ones. */
3011 b->next = all_buffers;
3012 all_buffers = b;
3013 /* Note that the rest fields of B are not initialized. */
3014 return b;
3015}
3016
3013struct Lisp_Hash_Table * 3017struct Lisp_Hash_Table *
3014allocate_hash_table (void) 3018allocate_hash_table (void)
3015{ 3019{
3016 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table, count, PVEC_HASH_TABLE); 3020 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table, count, PVEC_HASH_TABLE);
3017} 3021}
3018 3022
3019
3020struct window * 3023struct window *
3021allocate_window (void) 3024allocate_window (void)
3022{ 3025{
3023 return ALLOCATE_PSEUDOVECTOR (struct window, current_matrix, PVEC_WINDOW); 3026 struct window *w;
3024}
3025 3027
3028 w = ALLOCATE_PSEUDOVECTOR (struct window, current_matrix, PVEC_WINDOW);
3029 /* Users assumes that non-Lisp data is zeroed. */
3030 memset (&w->current_matrix, 0,
3031 sizeof (*w) - offsetof (struct window, current_matrix));
3032 return w;
3033}
3026 3034
3027struct terminal * 3035struct terminal *
3028allocate_terminal (void) 3036allocate_terminal (void)
3029{ 3037{
3030 struct terminal *t = ALLOCATE_PSEUDOVECTOR (struct terminal, 3038 struct terminal *t;
3031 next_terminal, PVEC_TERMINAL);
3032 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
3033 memset (&t->next_terminal, 0,
3034 (char*) (t + 1) - (char*) &t->next_terminal);
3035 3039
3040 t = ALLOCATE_PSEUDOVECTOR (struct terminal, next_terminal, PVEC_TERMINAL);
3041 /* Users assumes that non-Lisp data is zeroed. */
3042 memset (&t->next_terminal, 0,
3043 sizeof (*t) - offsetof (struct terminal, next_terminal));
3036 return t; 3044 return t;
3037} 3045}
3038 3046
3039struct frame * 3047struct frame *
3040allocate_frame (void) 3048allocate_frame (void)
3041{ 3049{
3042 struct frame *f = ALLOCATE_PSEUDOVECTOR (struct frame, 3050 struct frame *f;
3043 face_cache, PVEC_FRAME); 3051
3044 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */ 3052 f = ALLOCATE_PSEUDOVECTOR (struct frame, face_cache, PVEC_FRAME);
3053 /* Users assumes that non-Lisp data is zeroed. */
3045 memset (&f->face_cache, 0, 3054 memset (&f->face_cache, 0,
3046 (char *) (f + 1) - (char *) &f->face_cache); 3055 sizeof (*f) - offsetof (struct frame, face_cache));
3047 return f; 3056 return f;
3048} 3057}
3049 3058
3050
3051struct Lisp_Process * 3059struct Lisp_Process *
3052allocate_process (void) 3060allocate_process (void)
3053{ 3061{
3054 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS); 3062 struct Lisp_Process *p;
3055}
3056 3063
3064 p = ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS);
3065 /* Users assumes that non-Lisp data is zeroed. */
3066 memset (&p->pid, 0,
3067 sizeof (*p) - offsetof (struct Lisp_Process, pid));
3068 return p;
3069}
3057 3070
3058DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0, 3071DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
3059 doc: /* Return a newly created vector of length LENGTH, with each element being INIT. 3072 doc: /* Return a newly created vector of length LENGTH, with each element being INIT.
@@ -3083,18 +3096,28 @@ Any number of arguments, even zero arguments, are allowed.
3083usage: (vector &rest OBJECTS) */) 3096usage: (vector &rest OBJECTS) */)
3084 (ptrdiff_t nargs, Lisp_Object *args) 3097 (ptrdiff_t nargs, Lisp_Object *args)
3085{ 3098{
3086 register Lisp_Object len, val;
3087 ptrdiff_t i; 3099 ptrdiff_t i;
3088 register struct Lisp_Vector *p; 3100 register Lisp_Object val = make_uninit_vector (nargs);
3101 register struct Lisp_Vector *p = XVECTOR (val);
3089 3102
3090 XSETFASTINT (len, nargs);
3091 val = Fmake_vector (len, Qnil);
3092 p = XVECTOR (val);
3093 for (i = 0; i < nargs; i++) 3103 for (i = 0; i < nargs; i++)
3094 p->contents[i] = args[i]; 3104 p->contents[i] = args[i];
3095 return val; 3105 return val;
3096} 3106}
3097 3107
3108void
3109make_byte_code (struct Lisp_Vector *v)
3110{
3111 if (v->header.size > 1 && STRINGP (v->contents[1])
3112 && STRING_MULTIBYTE (v->contents[1]))
3113 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3114 earlier because they produced a raw 8-bit string for byte-code
3115 and now such a byte-code string is loaded as multibyte while
3116 raw 8-bit characters converted to multibyte form. Thus, now we
3117 must convert them back to the original unibyte form. */
3118 v->contents[1] = Fstring_as_unibyte (v->contents[1]);
3119 XSETPVECTYPE (v, PVEC_COMPILED);
3120}
3098 3121
3099DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, 3122DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
3100 doc: /* Create a byte-code object with specified arguments as elements. 3123 doc: /* Create a byte-code object with specified arguments as elements.
@@ -3114,32 +3137,21 @@ stack before executing the byte-code.
3114usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) 3137usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3115 (ptrdiff_t nargs, Lisp_Object *args) 3138 (ptrdiff_t nargs, Lisp_Object *args)
3116{ 3139{
3117 register Lisp_Object len, val;
3118 ptrdiff_t i; 3140 ptrdiff_t i;
3119 register struct Lisp_Vector *p; 3141 register Lisp_Object val = make_uninit_vector (nargs);
3142 register struct Lisp_Vector *p = XVECTOR (val);
3120 3143
3121 XSETFASTINT (len, nargs); 3144 /* We used to purecopy everything here, if purify-flag was set. This worked
3122 if (!NILP (Vpurify_flag)) 3145 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
3123 val = make_pure_vector (nargs); 3146 dangerous, since make-byte-code is used during execution to build
3124 else 3147 closures, so any closure built during the preload phase would end up
3125 val = Fmake_vector (len, Qnil); 3148 copied into pure space, including its free variables, which is sometimes
3149 just wasteful and other times plainly wrong (e.g. those free vars may want
3150 to be setcar'd). */
3126 3151
3127 if (nargs > 1 && STRINGP (args[1]) && STRING_MULTIBYTE (args[1]))
3128 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3129 earlier because they produced a raw 8-bit string for byte-code
3130 and now such a byte-code string is loaded as multibyte while
3131 raw 8-bit characters converted to multibyte form. Thus, now we
3132 must convert them back to the original unibyte form. */
3133 args[1] = Fstring_as_unibyte (args[1]);
3134
3135 p = XVECTOR (val);
3136 for (i = 0; i < nargs; i++) 3152 for (i = 0; i < nargs; i++)
3137 { 3153 p->contents[i] = args[i];
3138 if (!NILP (Vpurify_flag)) 3154 make_byte_code (p);
3139 args[i] = Fpurecopy (args[i]);
3140 p->contents[i] = args[i];
3141 }
3142 XSETPVECTYPE (p, PVEC_COMPILED);
3143 XSETCOMPILED (val, p); 3155 XSETCOMPILED (val, p);
3144 return val; 3156 return val;
3145} 3157}
@@ -3156,15 +3168,15 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT
3156union aligned_Lisp_Symbol 3168union aligned_Lisp_Symbol
3157{ 3169{
3158 struct Lisp_Symbol s; 3170 struct Lisp_Symbol s;
3159#ifdef USE_LSB_TAG 3171#if USE_LSB_TAG
3160 unsigned char c[(sizeof (struct Lisp_Symbol) + (1 << GCTYPEBITS) - 1) 3172 unsigned char c[(sizeof (struct Lisp_Symbol) + GCALIGNMENT - 1)
3161 & -(1 << GCTYPEBITS)]; 3173 & -GCALIGNMENT];
3162#endif 3174#endif
3163}; 3175};
3164 3176
3165/* Each symbol_block is just under 1020 bytes long, since malloc 3177/* Each symbol_block is just under 1020 bytes long, since malloc
3166 really allocates in units of powers of two and uses 4 bytes for its 3178 really allocates in units of powers of two and uses 4 bytes for its
3167 own overhead. */ 3179 own overhead. */
3168 3180
3169#define SYMBOL_BLOCK_SIZE \ 3181#define SYMBOL_BLOCK_SIZE \
3170 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol)) 3182 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
@@ -3180,27 +3192,21 @@ struct symbol_block
3180 structure in it. */ 3192 structure in it. */
3181 3193
3182static struct symbol_block *symbol_block; 3194static struct symbol_block *symbol_block;
3183static int symbol_block_index; 3195static int symbol_block_index = SYMBOL_BLOCK_SIZE;
3184 3196
3185/* List of free symbols. */ 3197/* List of free symbols. */
3186 3198
3187static struct Lisp_Symbol *symbol_free_list; 3199static struct Lisp_Symbol *symbol_free_list;
3188 3200
3189
3190/* Initialize symbol allocation. */
3191
3192static void 3201static void
3193init_symbol (void) 3202set_symbol_name (Lisp_Object sym, Lisp_Object name)
3194{ 3203{
3195 symbol_block = NULL; 3204 XSYMBOL (sym)->name = name;
3196 symbol_block_index = SYMBOL_BLOCK_SIZE;
3197 symbol_free_list = 0;
3198} 3205}
3199 3206
3200
3201DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, 3207DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
3202 doc: /* Return a newly allocated uninterned symbol whose name is NAME. 3208 doc: /* Return a newly allocated uninterned symbol whose name is NAME.
3203Its value and function definition are void, and its property list is nil. */) 3209Its value is void, and its function definition and property list are nil. */)
3204 (Lisp_Object name) 3210 (Lisp_Object name)
3205{ 3211{
3206 register Lisp_Object val; 3212 register Lisp_Object val;
@@ -3208,8 +3214,6 @@ Its value and function definition are void, and its property list is nil. */)
3208 3214
3209 CHECK_STRING (name); 3215 CHECK_STRING (name);
3210 3216
3211 /* eassert (!handling_signal); */
3212
3213 MALLOC_BLOCK_INPUT; 3217 MALLOC_BLOCK_INPUT;
3214 3218
3215 if (symbol_free_list) 3219 if (symbol_free_list)
@@ -3221,12 +3225,12 @@ Its value and function definition are void, and its property list is nil. */)
3221 { 3225 {
3222 if (symbol_block_index == SYMBOL_BLOCK_SIZE) 3226 if (symbol_block_index == SYMBOL_BLOCK_SIZE)
3223 { 3227 {
3224 struct symbol_block *new; 3228 struct symbol_block *new
3225 new = (struct symbol_block *) lisp_malloc (sizeof *new, 3229 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL);
3226 MEM_TYPE_SYMBOL);
3227 new->next = symbol_block; 3230 new->next = symbol_block;
3228 symbol_block = new; 3231 symbol_block = new;
3229 symbol_block_index = 0; 3232 symbol_block_index = 0;
3233 total_free_symbols += SYMBOL_BLOCK_SIZE;
3230 } 3234 }
3231 XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index].s); 3235 XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index].s);
3232 symbol_block_index++; 3236 symbol_block_index++;
@@ -3235,18 +3239,19 @@ Its value and function definition are void, and its property list is nil. */)
3235 MALLOC_UNBLOCK_INPUT; 3239 MALLOC_UNBLOCK_INPUT;
3236 3240
3237 p = XSYMBOL (val); 3241 p = XSYMBOL (val);
3238 p->xname = name; 3242 set_symbol_name (val, name);
3239 p->plist = Qnil; 3243 set_symbol_plist (val, Qnil);
3240 p->redirect = SYMBOL_PLAINVAL; 3244 p->redirect = SYMBOL_PLAINVAL;
3241 SET_SYMBOL_VAL (p, Qunbound); 3245 SET_SYMBOL_VAL (p, Qunbound);
3242 p->function = Qunbound; 3246 set_symbol_function (val, Qnil);
3243 p->next = NULL; 3247 set_symbol_next (val, NULL);
3244 p->gcmarkbit = 0; 3248 p->gcmarkbit = 0;
3245 p->interned = SYMBOL_UNINTERNED; 3249 p->interned = SYMBOL_UNINTERNED;
3246 p->constant = 0; 3250 p->constant = 0;
3247 p->declared_special = 0; 3251 p->declared_special = 0;
3248 consing_since_gc += sizeof (struct Lisp_Symbol); 3252 consing_since_gc += sizeof (struct Lisp_Symbol);
3249 symbols_consed++; 3253 symbols_consed++;
3254 total_free_symbols--;
3250 return val; 3255 return val;
3251} 3256}
3252 3257
@@ -3262,9 +3267,9 @@ Its value and function definition are void, and its property list is nil. */)
3262union aligned_Lisp_Misc 3267union aligned_Lisp_Misc
3263{ 3268{
3264 union Lisp_Misc m; 3269 union Lisp_Misc m;
3265#ifdef USE_LSB_TAG 3270#if USE_LSB_TAG
3266 unsigned char c[(sizeof (union Lisp_Misc) + (1 << GCTYPEBITS) - 1) 3271 unsigned char c[(sizeof (union Lisp_Misc) + GCALIGNMENT - 1)
3267 & -(1 << GCTYPEBITS)]; 3272 & -GCALIGNMENT];
3268#endif 3273#endif
3269}; 3274};
3270 3275
@@ -3282,27 +3287,17 @@ struct marker_block
3282}; 3287};
3283 3288
3284static struct marker_block *marker_block; 3289static struct marker_block *marker_block;
3285static int marker_block_index; 3290static int marker_block_index = MARKER_BLOCK_SIZE;
3286 3291
3287static union Lisp_Misc *marker_free_list; 3292static union Lisp_Misc *marker_free_list;
3288 3293
3289static void 3294/* Return a newly allocated Lisp_Misc object of specified TYPE. */
3290init_marker (void)
3291{
3292 marker_block = NULL;
3293 marker_block_index = MARKER_BLOCK_SIZE;
3294 marker_free_list = 0;
3295}
3296
3297/* Return a newly allocated Lisp_Misc object, with no substructure. */
3298 3295
3299Lisp_Object 3296static Lisp_Object
3300allocate_misc (void) 3297allocate_misc (enum Lisp_Misc_Type type)
3301{ 3298{
3302 Lisp_Object val; 3299 Lisp_Object val;
3303 3300
3304 /* eassert (!handling_signal); */
3305
3306 MALLOC_BLOCK_INPUT; 3301 MALLOC_BLOCK_INPUT;
3307 3302
3308 if (marker_free_list) 3303 if (marker_free_list)
@@ -3314,9 +3309,7 @@ allocate_misc (void)
3314 { 3309 {
3315 if (marker_block_index == MARKER_BLOCK_SIZE) 3310 if (marker_block_index == MARKER_BLOCK_SIZE)
3316 { 3311 {
3317 struct marker_block *new; 3312 struct marker_block *new = lisp_malloc (sizeof *new, MEM_TYPE_MISC);
3318 new = (struct marker_block *) lisp_malloc (sizeof *new,
3319 MEM_TYPE_MISC);
3320 new->next = marker_block; 3313 new->next = marker_block;
3321 marker_block = new; 3314 marker_block = new;
3322 marker_block_index = 0; 3315 marker_block_index = 0;
@@ -3331,40 +3324,146 @@ allocate_misc (void)
3331 --total_free_markers; 3324 --total_free_markers;
3332 consing_since_gc += sizeof (union Lisp_Misc); 3325 consing_since_gc += sizeof (union Lisp_Misc);
3333 misc_objects_consed++; 3326 misc_objects_consed++;
3327 XMISCANY (val)->type = type;
3334 XMISCANY (val)->gcmarkbit = 0; 3328 XMISCANY (val)->gcmarkbit = 0;
3335 return val; 3329 return val;
3336} 3330}
3337 3331
3338/* Free a Lisp_Misc object */ 3332/* Free a Lisp_Misc object. */
3339 3333
3340static void 3334void
3341free_misc (Lisp_Object misc) 3335free_misc (Lisp_Object misc)
3342{ 3336{
3343 XMISCTYPE (misc) = Lisp_Misc_Free; 3337 XMISCANY (misc)->type = Lisp_Misc_Free;
3344 XMISC (misc)->u_free.chain = marker_free_list; 3338 XMISC (misc)->u_free.chain = marker_free_list;
3345 marker_free_list = XMISC (misc); 3339 marker_free_list = XMISC (misc);
3346 3340 consing_since_gc -= sizeof (union Lisp_Misc);
3347 total_free_markers++; 3341 total_free_markers++;
3348} 3342}
3349 3343
3350/* Return a Lisp_Misc_Save_Value object containing POINTER and 3344/* Verify properties of Lisp_Save_Value's representation
3351 INTEGER. This is used to package C values to call record_unwind_protect. 3345 that are assumed here and elsewhere. */
3352 The unwind function can get the C values back using XSAVE_VALUE. */ 3346
3347verify (SAVE_UNUSED == 0);
3348verify (((SAVE_INTEGER | SAVE_POINTER | SAVE_FUNCPOINTER | SAVE_OBJECT)
3349 >> SAVE_SLOT_BITS)
3350 == 0);
3351
3352/* Return Lisp_Save_Value objects for the various combinations
3353 that callers need. */
3354
3355Lisp_Object
3356make_save_int_int_int (ptrdiff_t a, ptrdiff_t b, ptrdiff_t c)
3357{
3358 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3359 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3360 p->save_type = SAVE_TYPE_INT_INT_INT;
3361 p->data[0].integer = a;
3362 p->data[1].integer = b;
3363 p->data[2].integer = c;
3364 return val;
3365}
3353 3366
3354Lisp_Object 3367Lisp_Object
3355make_save_value (void *pointer, ptrdiff_t integer) 3368make_save_obj_obj_obj_obj (Lisp_Object a, Lisp_Object b, Lisp_Object c,
3369 Lisp_Object d)
3370{
3371 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3372 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3373 p->save_type = SAVE_TYPE_OBJ_OBJ_OBJ_OBJ;
3374 p->data[0].object = a;
3375 p->data[1].object = b;
3376 p->data[2].object = c;
3377 p->data[3].object = d;
3378 return val;
3379}
3380
3381#if defined HAVE_NS || defined HAVE_NTGUI
3382Lisp_Object
3383make_save_ptr (void *a)
3356{ 3384{
3357 register Lisp_Object val; 3385 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3358 register struct Lisp_Save_Value *p; 3386 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3359 3387 p->save_type = SAVE_POINTER;
3360 val = allocate_misc (); 3388 p->data[0].pointer = a;
3361 XMISCTYPE (val) = Lisp_Misc_Save_Value;
3362 p = XSAVE_VALUE (val);
3363 p->pointer = pointer;
3364 p->integer = integer;
3365 p->dogc = 0;
3366 return val; 3389 return val;
3367} 3390}
3391#endif
3392
3393Lisp_Object
3394make_save_ptr_int (void *a, ptrdiff_t b)
3395{
3396 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3397 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3398 p->save_type = SAVE_TYPE_PTR_INT;
3399 p->data[0].pointer = a;
3400 p->data[1].integer = b;
3401 return val;
3402}
3403
3404#if defined HAVE_MENUS && ! (defined USE_X_TOOLKIT || defined USE_GTK)
3405Lisp_Object
3406make_save_ptr_ptr (void *a, void *b)
3407{
3408 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3409 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3410 p->save_type = SAVE_TYPE_PTR_PTR;
3411 p->data[0].pointer = a;
3412 p->data[1].pointer = b;
3413 return val;
3414}
3415#endif
3416
3417Lisp_Object
3418make_save_funcptr_ptr_obj (void (*a) (void), void *b, Lisp_Object c)
3419{
3420 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3421 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3422 p->save_type = SAVE_TYPE_FUNCPTR_PTR_OBJ;
3423 p->data[0].funcpointer = a;
3424 p->data[1].pointer = b;
3425 p->data[2].object = c;
3426 return val;
3427}
3428
3429/* Return a Lisp_Save_Value object that represents an array A
3430 of N Lisp objects. */
3431
3432Lisp_Object
3433make_save_memory (Lisp_Object *a, ptrdiff_t n)
3434{
3435 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3436 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3437 p->save_type = SAVE_TYPE_MEMORY;
3438 p->data[0].pointer = a;
3439 p->data[1].integer = n;
3440 return val;
3441}
3442
3443/* Free a Lisp_Save_Value object. Do not use this function
3444 if SAVE contains pointer other than returned by xmalloc. */
3445
3446void
3447free_save_value (Lisp_Object save)
3448{
3449 xfree (XSAVE_POINTER (save, 0));
3450 free_misc (save);
3451}
3452
3453/* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3454
3455Lisp_Object
3456build_overlay (Lisp_Object start, Lisp_Object end, Lisp_Object plist)
3457{
3458 register Lisp_Object overlay;
3459
3460 overlay = allocate_misc (Lisp_Misc_Overlay);
3461 OVERLAY_START (overlay) = start;
3462 OVERLAY_END (overlay) = end;
3463 set_overlay_plist (overlay, plist);
3464 XOVERLAY (overlay)->next = NULL;
3465 return overlay;
3466}
3368 3467
3369DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, 3468DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
3370 doc: /* Return a newly allocated marker which does not point at any place. */) 3469 doc: /* Return a newly allocated marker which does not point at any place. */)
@@ -3373,17 +3472,44 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
3373 register Lisp_Object val; 3472 register Lisp_Object val;
3374 register struct Lisp_Marker *p; 3473 register struct Lisp_Marker *p;
3375 3474
3376 val = allocate_misc (); 3475 val = allocate_misc (Lisp_Misc_Marker);
3377 XMISCTYPE (val) = Lisp_Misc_Marker;
3378 p = XMARKER (val); 3476 p = XMARKER (val);
3379 p->buffer = 0; 3477 p->buffer = 0;
3380 p->bytepos = 0; 3478 p->bytepos = 0;
3381 p->charpos = 0; 3479 p->charpos = 0;
3382 p->next = NULL; 3480 p->next = NULL;
3383 p->insertion_type = 0; 3481 p->insertion_type = 0;
3482 p->need_adjustment = 0;
3384 return val; 3483 return val;
3385} 3484}
3386 3485
3486/* Return a newly allocated marker which points into BUF
3487 at character position CHARPOS and byte position BYTEPOS. */
3488
3489Lisp_Object
3490build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos)
3491{
3492 Lisp_Object obj;
3493 struct Lisp_Marker *m;
3494
3495 /* No dead buffers here. */
3496 eassert (BUFFER_LIVE_P (buf));
3497
3498 /* Every character is at least one byte. */
3499 eassert (charpos <= bytepos);
3500
3501 obj = allocate_misc (Lisp_Misc_Marker);
3502 m = XMARKER (obj);
3503 m->buffer = buf;
3504 m->charpos = charpos;
3505 m->bytepos = bytepos;
3506 m->insertion_type = 0;
3507 m->need_adjustment = 0;
3508 m->next = BUF_MARKERS (buf);
3509 BUF_MARKERS (buf) = m;
3510 return obj;
3511}
3512
3387/* Put MARKER back on the free list after using it temporarily. */ 3513/* Put MARKER back on the free list after using it temporarily. */
3388 3514
3389void 3515void
@@ -3401,9 +3527,9 @@ free_marker (Lisp_Object marker)
3401 Any number of arguments, even zero arguments, are allowed. */ 3527 Any number of arguments, even zero arguments, are allowed. */
3402 3528
3403Lisp_Object 3529Lisp_Object
3404make_event_array (register int nargs, Lisp_Object *args) 3530make_event_array (ptrdiff_t nargs, Lisp_Object *args)
3405{ 3531{
3406 int i; 3532 ptrdiff_t i;
3407 3533
3408 for (i = 0; i < nargs; i++) 3534 for (i = 0; i < nargs; i++)
3409 /* The things that fit in a string 3535 /* The things that fit in a string
@@ -3449,7 +3575,7 @@ void
3449memory_full (size_t nbytes) 3575memory_full (size_t nbytes)
3450{ 3576{
3451 /* Do not go into hysterics merely because a large request failed. */ 3577 /* Do not go into hysterics merely because a large request failed. */
3452 int enough_free_memory = 0; 3578 bool enough_free_memory = 0;
3453 if (SPARE_MEMORY < nbytes) 3579 if (SPARE_MEMORY < nbytes)
3454 { 3580 {
3455 void *p; 3581 void *p;
@@ -3484,12 +3610,6 @@ memory_full (size_t nbytes)
3484 lisp_free (spare_memory[i]); 3610 lisp_free (spare_memory[i]);
3485 spare_memory[i] = 0; 3611 spare_memory[i] = 0;
3486 } 3612 }
3487
3488 /* Record the space now used. When it decreases substantially,
3489 we can refill the memory reserve. */
3490#if !defined SYSTEM_MALLOC && !defined SYNC_INPUT
3491 bytes_used_when_full = BYTES_USED;
3492#endif
3493 } 3613 }
3494 3614
3495 /* This used to call error, but if we've run out of memory, we could 3615 /* This used to call error, but if we've run out of memory, we could
@@ -3509,25 +3629,25 @@ refill_memory_reserve (void)
3509{ 3629{
3510#ifndef SYSTEM_MALLOC 3630#ifndef SYSTEM_MALLOC
3511 if (spare_memory[0] == 0) 3631 if (spare_memory[0] == 0)
3512 spare_memory[0] = (char *) malloc (SPARE_MEMORY); 3632 spare_memory[0] = malloc (SPARE_MEMORY);
3513 if (spare_memory[1] == 0) 3633 if (spare_memory[1] == 0)
3514 spare_memory[1] = (char *) lisp_align_malloc (sizeof (struct cons_block), 3634 spare_memory[1] = lisp_align_malloc (sizeof (struct cons_block),
3515 MEM_TYPE_CONS); 3635 MEM_TYPE_SPARE);
3516 if (spare_memory[2] == 0) 3636 if (spare_memory[2] == 0)
3517 spare_memory[2] = (char *) lisp_align_malloc (sizeof (struct cons_block), 3637 spare_memory[2] = lisp_align_malloc (sizeof (struct cons_block),
3518 MEM_TYPE_CONS); 3638 MEM_TYPE_SPARE);
3519 if (spare_memory[3] == 0) 3639 if (spare_memory[3] == 0)
3520 spare_memory[3] = (char *) lisp_align_malloc (sizeof (struct cons_block), 3640 spare_memory[3] = lisp_align_malloc (sizeof (struct cons_block),
3521 MEM_TYPE_CONS); 3641 MEM_TYPE_SPARE);
3522 if (spare_memory[4] == 0) 3642 if (spare_memory[4] == 0)
3523 spare_memory[4] = (char *) lisp_align_malloc (sizeof (struct cons_block), 3643 spare_memory[4] = lisp_align_malloc (sizeof (struct cons_block),
3524 MEM_TYPE_CONS); 3644 MEM_TYPE_SPARE);
3525 if (spare_memory[5] == 0) 3645 if (spare_memory[5] == 0)
3526 spare_memory[5] = (char *) lisp_malloc (sizeof (struct string_block), 3646 spare_memory[5] = lisp_malloc (sizeof (struct string_block),
3527 MEM_TYPE_STRING); 3647 MEM_TYPE_SPARE);
3528 if (spare_memory[6] == 0) 3648 if (spare_memory[6] == 0)
3529 spare_memory[6] = (char *) lisp_malloc (sizeof (struct string_block), 3649 spare_memory[6] = lisp_malloc (sizeof (struct string_block),
3530 MEM_TYPE_STRING); 3650 MEM_TYPE_SPARE);
3531 if (spare_memory[0] && spare_memory[1] && spare_memory[5]) 3651 if (spare_memory[0] && spare_memory[1] && spare_memory[5])
3532 Vmemory_full = Qnil; 3652 Vmemory_full = Qnil;
3533#endif 3653#endif
@@ -3566,7 +3686,7 @@ mem_init (void)
3566/* Value is a pointer to the mem_node containing START. Value is 3686/* Value is a pointer to the mem_node containing START. Value is
3567 MEM_NIL if there is no node in the tree containing START. */ 3687 MEM_NIL if there is no node in the tree containing START. */
3568 3688
3569static inline struct mem_node * 3689static struct mem_node *
3570mem_find (void *start) 3690mem_find (void *start)
3571{ 3691{
3572 struct mem_node *p; 3692 struct mem_node *p;
@@ -3610,7 +3730,7 @@ mem_insert (void *start, void *end, enum mem_type type)
3610 while (c != MEM_NIL) 3730 while (c != MEM_NIL)
3611 { 3731 {
3612 if (start >= c->start && start < c->end) 3732 if (start >= c->start && start < c->end)
3613 abort (); 3733 emacs_abort ();
3614 parent = c; 3734 parent = c;
3615 c = start < c->start ? c->left : c->right; 3735 c = start < c->start ? c->left : c->right;
3616 } 3736 }
@@ -3627,11 +3747,11 @@ mem_insert (void *start, void *end, enum mem_type type)
3627 3747
3628 /* Create a new node. */ 3748 /* Create a new node. */
3629#ifdef GC_MALLOC_CHECK 3749#ifdef GC_MALLOC_CHECK
3630 x = (struct mem_node *) _malloc_internal (sizeof *x); 3750 x = malloc (sizeof *x);
3631 if (x == NULL) 3751 if (x == NULL)
3632 abort (); 3752 emacs_abort ();
3633#else 3753#else
3634 x = (struct mem_node *) xmalloc (sizeof *x); 3754 x = xmalloc (sizeof *x);
3635#endif 3755#endif
3636 x->start = start; 3756 x->start = start;
3637 x->end = end; 3757 x->end = end;
@@ -3851,7 +3971,7 @@ mem_delete (struct mem_node *z)
3851 mem_delete_fixup (x); 3971 mem_delete_fixup (x);
3852 3972
3853#ifdef GC_MALLOC_CHECK 3973#ifdef GC_MALLOC_CHECK
3854 _free_internal (y); 3974 free (y);
3855#else 3975#else
3856 xfree (y); 3976 xfree (y);
3857#endif 3977#endif
@@ -3942,12 +4062,12 @@ mem_delete_fixup (struct mem_node *x)
3942/* Value is non-zero if P is a pointer to a live Lisp string on 4062/* Value is non-zero if P is a pointer to a live Lisp string on
3943 the heap. M is a pointer to the mem_block for P. */ 4063 the heap. M is a pointer to the mem_block for P. */
3944 4064
3945static inline int 4065static bool
3946live_string_p (struct mem_node *m, void *p) 4066live_string_p (struct mem_node *m, void *p)
3947{ 4067{
3948 if (m->type == MEM_TYPE_STRING) 4068 if (m->type == MEM_TYPE_STRING)
3949 { 4069 {
3950 struct string_block *b = (struct string_block *) m->start; 4070 struct string_block *b = m->start;
3951 ptrdiff_t offset = (char *) p - (char *) &b->strings[0]; 4071 ptrdiff_t offset = (char *) p - (char *) &b->strings[0];
3952 4072
3953 /* P must point to the start of a Lisp_String structure, and it 4073 /* P must point to the start of a Lisp_String structure, and it
@@ -3965,12 +4085,12 @@ live_string_p (struct mem_node *m, void *p)
3965/* Value is non-zero if P is a pointer to a live Lisp cons on 4085/* Value is non-zero if P is a pointer to a live Lisp cons on
3966 the heap. M is a pointer to the mem_block for P. */ 4086 the heap. M is a pointer to the mem_block for P. */
3967 4087
3968static inline int 4088static bool
3969live_cons_p (struct mem_node *m, void *p) 4089live_cons_p (struct mem_node *m, void *p)
3970{ 4090{
3971 if (m->type == MEM_TYPE_CONS) 4091 if (m->type == MEM_TYPE_CONS)
3972 { 4092 {
3973 struct cons_block *b = (struct cons_block *) m->start; 4093 struct cons_block *b = m->start;
3974 ptrdiff_t offset = (char *) p - (char *) &b->conses[0]; 4094 ptrdiff_t offset = (char *) p - (char *) &b->conses[0];
3975 4095
3976 /* P must point to the start of a Lisp_Cons, not be 4096 /* P must point to the start of a Lisp_Cons, not be
@@ -3991,12 +4111,12 @@ live_cons_p (struct mem_node *m, void *p)
3991/* Value is non-zero if P is a pointer to a live Lisp symbol on 4111/* Value is non-zero if P is a pointer to a live Lisp symbol on
3992 the heap. M is a pointer to the mem_block for P. */ 4112 the heap. M is a pointer to the mem_block for P. */
3993 4113
3994static inline int 4114static bool
3995live_symbol_p (struct mem_node *m, void *p) 4115live_symbol_p (struct mem_node *m, void *p)
3996{ 4116{
3997 if (m->type == MEM_TYPE_SYMBOL) 4117 if (m->type == MEM_TYPE_SYMBOL)
3998 { 4118 {
3999 struct symbol_block *b = (struct symbol_block *) m->start; 4119 struct symbol_block *b = m->start;
4000 ptrdiff_t offset = (char *) p - (char *) &b->symbols[0]; 4120 ptrdiff_t offset = (char *) p - (char *) &b->symbols[0];
4001 4121
4002 /* P must point to the start of a Lisp_Symbol, not be 4122 /* P must point to the start of a Lisp_Symbol, not be
@@ -4007,7 +4127,7 @@ live_symbol_p (struct mem_node *m, void *p)
4007 && offset < (SYMBOL_BLOCK_SIZE * sizeof b->symbols[0]) 4127 && offset < (SYMBOL_BLOCK_SIZE * sizeof b->symbols[0])
4008 && (b != symbol_block 4128 && (b != symbol_block
4009 || offset / sizeof b->symbols[0] < symbol_block_index) 4129 || offset / sizeof b->symbols[0] < symbol_block_index)
4010 && !EQ (((struct Lisp_Symbol *) p)->function, Vdead)); 4130 && !EQ (((struct Lisp_Symbol *)p)->function, Vdead));
4011 } 4131 }
4012 else 4132 else
4013 return 0; 4133 return 0;
@@ -4017,12 +4137,12 @@ live_symbol_p (struct mem_node *m, void *p)
4017/* Value is non-zero if P is a pointer to a live Lisp float on 4137/* Value is non-zero if P is a pointer to a live Lisp float on
4018 the heap. M is a pointer to the mem_block for P. */ 4138 the heap. M is a pointer to the mem_block for P. */
4019 4139
4020static inline int 4140static bool
4021live_float_p (struct mem_node *m, void *p) 4141live_float_p (struct mem_node *m, void *p)
4022{ 4142{
4023 if (m->type == MEM_TYPE_FLOAT) 4143 if (m->type == MEM_TYPE_FLOAT)
4024 { 4144 {
4025 struct float_block *b = (struct float_block *) m->start; 4145 struct float_block *b = m->start;
4026 ptrdiff_t offset = (char *) p - (char *) &b->floats[0]; 4146 ptrdiff_t offset = (char *) p - (char *) &b->floats[0];
4027 4147
4028 /* P must point to the start of a Lisp_Float and not be 4148 /* P must point to the start of a Lisp_Float and not be
@@ -4041,12 +4161,12 @@ live_float_p (struct mem_node *m, void *p)
4041/* Value is non-zero if P is a pointer to a live Lisp Misc on 4161/* Value is non-zero if P is a pointer to a live Lisp Misc on
4042 the heap. M is a pointer to the mem_block for P. */ 4162 the heap. M is a pointer to the mem_block for P. */
4043 4163
4044static inline int 4164static bool
4045live_misc_p (struct mem_node *m, void *p) 4165live_misc_p (struct mem_node *m, void *p)
4046{ 4166{
4047 if (m->type == MEM_TYPE_MISC) 4167 if (m->type == MEM_TYPE_MISC)
4048 { 4168 {
4049 struct marker_block *b = (struct marker_block *) m->start; 4169 struct marker_block *b = m->start;
4050 ptrdiff_t offset = (char *) p - (char *) &b->markers[0]; 4170 ptrdiff_t offset = (char *) p - (char *) &b->markers[0];
4051 4171
4052 /* P must point to the start of a Lisp_Misc, not be 4172 /* P must point to the start of a Lisp_Misc, not be
@@ -4067,24 +4187,49 @@ live_misc_p (struct mem_node *m, void *p)
4067/* Value is non-zero if P is a pointer to a live vector-like object. 4187/* Value is non-zero if P is a pointer to a live vector-like object.
4068 M is a pointer to the mem_block for P. */ 4188 M is a pointer to the mem_block for P. */
4069 4189
4070static inline int 4190static bool
4071live_vector_p (struct mem_node *m, void *p) 4191live_vector_p (struct mem_node *m, void *p)
4072{ 4192{
4073 return (p == m->start && m->type == MEM_TYPE_VECTORLIKE); 4193 if (m->type == MEM_TYPE_VECTOR_BLOCK)
4194 {
4195 /* This memory node corresponds to a vector block. */
4196 struct vector_block *block = m->start;
4197 struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data;
4198
4199 /* P is in the block's allocation range. Scan the block
4200 up to P and see whether P points to the start of some
4201 vector which is not on a free list. FIXME: check whether
4202 some allocation patterns (probably a lot of short vectors)
4203 may cause a substantial overhead of this loop. */
4204 while (VECTOR_IN_BLOCK (vector, block)
4205 && vector <= (struct Lisp_Vector *) p)
4206 {
4207 if (!PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE) && vector == p)
4208 return 1;
4209 else
4210 vector = ADVANCE (vector, vector_nbytes (vector));
4211 }
4212 }
4213 else if (m->type == MEM_TYPE_VECTORLIKE
4214 && (char *) p == ((char *) m->start
4215 + offsetof (struct large_vector, v)))
4216 /* This memory node corresponds to a large vector. */
4217 return 1;
4218 return 0;
4074} 4219}
4075 4220
4076 4221
4077/* Value is non-zero if P is a pointer to a live buffer. M is a 4222/* Value is non-zero if P is a pointer to a live buffer. M is a
4078 pointer to the mem_block for P. */ 4223 pointer to the mem_block for P. */
4079 4224
4080static inline int 4225static bool
4081live_buffer_p (struct mem_node *m, void *p) 4226live_buffer_p (struct mem_node *m, void *p)
4082{ 4227{
4083 /* P must point to the start of the block, and the buffer 4228 /* P must point to the start of the block, and the buffer
4084 must not have been killed. */ 4229 must not have been killed. */
4085 return (m->type == MEM_TYPE_BUFFER 4230 return (m->type == MEM_TYPE_BUFFER
4086 && p == m->start 4231 && p == m->start
4087 && !NILP (((struct buffer *) p)->BUFFER_INTERNAL_FIELD (name))); 4232 && !NILP (((struct buffer *) p)->INTERNAL_FIELD (name)));
4088} 4233}
4089 4234
4090#endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */ 4235#endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
@@ -4093,6 +4238,10 @@ live_buffer_p (struct mem_node *m, void *p)
4093 4238
4094#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES 4239#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4095 4240
4241/* Currently not used, but may be called from gdb. */
4242
4243void dump_zombies (void) EXTERNALLY_VISIBLE;
4244
4096/* Array of objects that are kept alive because the C stack contains 4245/* Array of objects that are kept alive because the C stack contains
4097 a pattern that looks like a reference to them . */ 4246 a pattern that looks like a reference to them . */
4098 4247
@@ -4143,7 +4292,7 @@ DEFUN ("gc-status", Fgc_status, Sgc_status, 0, 0, "",
4143 4292
4144/* Mark OBJ if we can prove it's a Lisp_Object. */ 4293/* Mark OBJ if we can prove it's a Lisp_Object. */
4145 4294
4146static inline void 4295static void
4147mark_maybe_object (Lisp_Object obj) 4296mark_maybe_object (Lisp_Object obj)
4148{ 4297{
4149 void *po; 4298 void *po;
@@ -4157,7 +4306,7 @@ mark_maybe_object (Lisp_Object obj)
4157 4306
4158 if (m != MEM_NIL) 4307 if (m != MEM_NIL)
4159 { 4308 {
4160 int mark_p = 0; 4309 bool mark_p = 0;
4161 4310
4162 switch (XTYPE (obj)) 4311 switch (XTYPE (obj))
4163 { 4312 {
@@ -4212,19 +4361,15 @@ mark_maybe_object (Lisp_Object obj)
4212/* If P points to Lisp data, mark that as live if it isn't already 4361/* If P points to Lisp data, mark that as live if it isn't already
4213 marked. */ 4362 marked. */
4214 4363
4215static inline void 4364static void
4216mark_maybe_pointer (void *p) 4365mark_maybe_pointer (void *p)
4217{ 4366{
4218 struct mem_node *m; 4367 struct mem_node *m;
4219 4368
4220 /* Quickly rule out some values which can't point to Lisp data. */ 4369 /* Quickly rule out some values which can't point to Lisp data.
4221 if ((intptr_t) p % 4370 USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
4222#ifdef USE_LSB_TAG 4371 Otherwise, assume that Lisp data is aligned on even addresses. */
4223 8 /* USE_LSB_TAG needs Lisp data to be aligned on multiples of 8. */ 4372 if ((intptr_t) p % (USE_LSB_TAG ? GCALIGNMENT : 2))
4224#else
4225 2 /* We assume that Lisp data is aligned on even addresses. */
4226#endif
4227 )
4228 return; 4373 return;
4229 4374
4230 m = mem_find (p); 4375 m = mem_find (p);
@@ -4235,6 +4380,7 @@ mark_maybe_pointer (void *p)
4235 switch (m->type) 4380 switch (m->type)
4236 { 4381 {
4237 case MEM_TYPE_NON_LISP: 4382 case MEM_TYPE_NON_LISP:
4383 case MEM_TYPE_SPARE:
4238 /* Nothing to do; not a pointer to Lisp memory. */ 4384 /* Nothing to do; not a pointer to Lisp memory. */
4239 break; 4385 break;
4240 4386
@@ -4270,6 +4416,7 @@ mark_maybe_pointer (void *p)
4270 break; 4416 break;
4271 4417
4272 case MEM_TYPE_VECTORLIKE: 4418 case MEM_TYPE_VECTORLIKE:
4419 case MEM_TYPE_VECTOR_BLOCK:
4273 if (live_vector_p (m, p)) 4420 if (live_vector_p (m, p))
4274 { 4421 {
4275 Lisp_Object tem; 4422 Lisp_Object tem;
@@ -4280,7 +4427,7 @@ mark_maybe_pointer (void *p)
4280 break; 4427 break;
4281 4428
4282 default: 4429 default:
4283 abort (); 4430 emacs_abort ();
4284 } 4431 }
4285 4432
4286 if (!NILP (obj)) 4433 if (!NILP (obj))
@@ -4289,18 +4436,18 @@ mark_maybe_pointer (void *p)
4289} 4436}
4290 4437
4291 4438
4292/* Alignment of pointer values. Use offsetof, as it sometimes returns 4439/* Alignment of pointer values. Use alignof, as it sometimes returns
4293 a smaller alignment than GCC's __alignof__ and mark_memory might 4440 a smaller alignment than GCC's __alignof__ and mark_memory might
4294 miss objects if __alignof__ were used. */ 4441 miss objects if __alignof__ were used. */
4295#define GC_POINTER_ALIGNMENT offsetof (struct {char a; void *b;}, b) 4442#define GC_POINTER_ALIGNMENT alignof (void *)
4296 4443
4297/* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does 4444/* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4298 not suffice, which is the typical case. A host where a Lisp_Object is 4445 not suffice, which is the typical case. A host where a Lisp_Object is
4299 wider than a pointer might allocate a Lisp_Object in non-adjacent halves. 4446 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4300 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should 4447 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4301 suffice to widen it to to a Lisp_Object and check it that way. */ 4448 suffice to widen it to to a Lisp_Object and check it that way. */
4302#if defined USE_LSB_TAG || VAL_MAX < UINTPTR_MAX 4449#if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4303# if !defined USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS 4450# if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4304 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer 4451 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4305 nor mark_maybe_object can follow the pointers. This should not occur on 4452 nor mark_maybe_object can follow the pointers. This should not occur on
4306 any practical porting target. */ 4453 any practical porting target. */
@@ -4320,6 +4467,14 @@ mark_maybe_pointer (void *p)
4320 4467
4321static void 4468static void
4322mark_memory (void *start, void *end) 4469mark_memory (void *start, void *end)
4470#if defined (__clang__) && defined (__has_feature)
4471#if __has_feature(address_sanitizer)
4472 /* Do not allow -faddress-sanitizer to check this function, since it
4473 crosses the function stack boundary, and thus would yield many
4474 false positives. */
4475 __attribute__((no_address_safety_analysis))
4476#endif
4477#endif
4323{ 4478{
4324 void **pp; 4479 void **pp;
4325 int i; 4480 int i;
@@ -4361,18 +4516,14 @@ mark_memory (void *start, void *end)
4361 void *p = *(void **) ((char *) pp + i); 4516 void *p = *(void **) ((char *) pp + i);
4362 mark_maybe_pointer (p); 4517 mark_maybe_pointer (p);
4363 if (POINTERS_MIGHT_HIDE_IN_OBJECTS) 4518 if (POINTERS_MIGHT_HIDE_IN_OBJECTS)
4364 mark_maybe_object (widen_to_Lisp_Object (p)); 4519 mark_maybe_object (XIL ((intptr_t) p));
4365 } 4520 }
4366} 4521}
4367 4522
4368/* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4369 the GCC system configuration. In gcc 3.2, the only systems for
4370 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4371 by others?) and ns32k-pc532-min. */
4372
4373#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS 4523#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4374 4524
4375static int setjmp_tested_p, longjmps_done; 4525static bool setjmp_tested_p;
4526static int longjmps_done;
4376 4527
4377#define SETJMP_WILL_LIKELY_WORK "\ 4528#define SETJMP_WILL_LIKELY_WORK "\
4378\n\ 4529\n\
@@ -4415,15 +4566,14 @@ test_setjmp (void)
4415{ 4566{
4416 char buf[10]; 4567 char buf[10];
4417 register int x; 4568 register int x;
4418 jmp_buf jbuf; 4569 sys_jmp_buf jbuf;
4419 int result = 0;
4420 4570
4421 /* Arrange for X to be put in a register. */ 4571 /* Arrange for X to be put in a register. */
4422 sprintf (buf, "1"); 4572 sprintf (buf, "1");
4423 x = strlen (buf); 4573 x = strlen (buf);
4424 x = 2 * x - 1; 4574 x = 2 * x - 1;
4425 4575
4426 setjmp (jbuf); 4576 sys_setjmp (jbuf);
4427 if (longjmps_done == 1) 4577 if (longjmps_done == 1)
4428 { 4578 {
4429 /* Came here after the longjmp at the end of the function. 4579 /* Came here after the longjmp at the end of the function.
@@ -4448,7 +4598,7 @@ test_setjmp (void)
4448 ++longjmps_done; 4598 ++longjmps_done;
4449 x = 2; 4599 x = 2;
4450 if (longjmps_done == 1) 4600 if (longjmps_done == 1)
4451 longjmp (jbuf, 1); 4601 sys_longjmp (jbuf, 1);
4452} 4602}
4453 4603
4454#endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */ 4604#endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
@@ -4469,12 +4619,12 @@ check_gcpros (void)
4469 if (!survives_gc_p (p->var[i])) 4619 if (!survives_gc_p (p->var[i]))
4470 /* FIXME: It's not necessarily a bug. It might just be that the 4620 /* FIXME: It's not necessarily a bug. It might just be that the
4471 GCPRO is unnecessary or should release the object sooner. */ 4621 GCPRO is unnecessary or should release the object sooner. */
4472 abort (); 4622 emacs_abort ();
4473} 4623}
4474 4624
4475#elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES 4625#elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4476 4626
4477static void 4627void
4478dump_zombies (void) 4628dump_zombies (void)
4479{ 4629{
4480 int i; 4630 int i;
@@ -4554,9 +4704,9 @@ mark_stack (void)
4554 /* jmp_buf may not be aligned enough on darwin-ppc64 */ 4704 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4555 union aligned_jmpbuf { 4705 union aligned_jmpbuf {
4556 Lisp_Object o; 4706 Lisp_Object o;
4557 jmp_buf j; 4707 sys_jmp_buf j;
4558 } j; 4708 } j;
4559 volatile int stack_grows_down_p = (char *) &j > (char *) stack_base; 4709 volatile bool stack_grows_down_p = (char *) &j > (char *) stack_base;
4560#endif 4710#endif
4561 /* This trick flushes the register windows so that all the state of 4711 /* This trick flushes the register windows so that all the state of
4562 the process is contained in the stack. */ 4712 the process is contained in the stack. */
@@ -4590,7 +4740,7 @@ mark_stack (void)
4590 } 4740 }
4591#endif /* GC_SETJMP_WORKS */ 4741#endif /* GC_SETJMP_WORKS */
4592 4742
4593 setjmp (j.j); 4743 sys_setjmp (j.j);
4594 end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j; 4744 end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
4595#endif /* not GC_SAVE_REGISTERS_ON_STACK */ 4745#endif /* not GC_SAVE_REGISTERS_ON_STACK */
4596#endif /* not HAVE___BUILTIN_UNWIND_INIT */ 4746#endif /* not HAVE___BUILTIN_UNWIND_INIT */
@@ -4611,6 +4761,10 @@ mark_stack (void)
4611#endif 4761#endif
4612} 4762}
4613 4763
4764#else /* GC_MARK_STACK == 0 */
4765
4766#define mark_maybe_object(obj) emacs_abort ()
4767
4614#endif /* GC_MARK_STACK != 0 */ 4768#endif /* GC_MARK_STACK != 0 */
4615 4769
4616 4770
@@ -4628,9 +4782,9 @@ valid_pointer_p (void *p)
4628 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may 4782 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4629 not validate p in that case. */ 4783 not validate p in that case. */
4630 4784
4631 if (pipe (fd) == 0) 4785 if (emacs_pipe (fd) == 0)
4632 { 4786 {
4633 int valid = (emacs_write (fd[1], (char *) p, 16) == 16); 4787 bool valid = emacs_write (fd[1], (char *) p, 16) == 16;
4634 emacs_close (fd[1]); 4788 emacs_close (fd[1]);
4635 emacs_close (fd[0]); 4789 emacs_close (fd[0]);
4636 return valid; 4790 return valid;
@@ -4640,11 +4794,12 @@ valid_pointer_p (void *p)
4640#endif 4794#endif
4641} 4795}
4642 4796
4643/* Return 1 if OBJ is a valid lisp object. 4797/* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
4644 Return 0 if OBJ is NOT a valid lisp object. 4798 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
4645 Return -1 if we cannot validate OBJ. 4799 cannot validate OBJ. This function can be quite slow, so its primary
4646 This function can be quite slow, 4800 use is the manual debugging. The only exception is print_object, where
4647 so it should only be used in code for manual debugging. */ 4801 we use it to check whether the memory referenced by the pointer of
4802 Lisp_Save_Value object contains valid objects. */
4648 4803
4649int 4804int
4650valid_lisp_object_p (Lisp_Object obj) 4805valid_lisp_object_p (Lisp_Object obj)
@@ -4661,6 +4816,9 @@ valid_lisp_object_p (Lisp_Object obj)
4661 if (PURE_POINTER_P (p)) 4816 if (PURE_POINTER_P (p))
4662 return 1; 4817 return 1;
4663 4818
4819 if (p == &buffer_defaults || p == &buffer_local_symbols)
4820 return 2;
4821
4664#if !GC_MARK_STACK 4822#if !GC_MARK_STACK
4665 return valid_pointer_p (p); 4823 return valid_pointer_p (p);
4666#else 4824#else
@@ -4682,10 +4840,11 @@ valid_lisp_object_p (Lisp_Object obj)
4682 switch (m->type) 4840 switch (m->type)
4683 { 4841 {
4684 case MEM_TYPE_NON_LISP: 4842 case MEM_TYPE_NON_LISP:
4843 case MEM_TYPE_SPARE:
4685 return 0; 4844 return 0;
4686 4845
4687 case MEM_TYPE_BUFFER: 4846 case MEM_TYPE_BUFFER:
4688 return live_buffer_p (m, p); 4847 return live_buffer_p (m, p) ? 1 : 2;
4689 4848
4690 case MEM_TYPE_CONS: 4849 case MEM_TYPE_CONS:
4691 return live_cons_p (m, p); 4850 return live_cons_p (m, p);
@@ -4703,6 +4862,7 @@ valid_lisp_object_p (Lisp_Object obj)
4703 return live_float_p (m, p); 4862 return live_float_p (m, p);
4704 4863
4705 case MEM_TYPE_VECTORLIKE: 4864 case MEM_TYPE_VECTORLIKE:
4865 case MEM_TYPE_VECTOR_BLOCK:
4706 return live_vector_p (m, p); 4866 return live_vector_p (m, p);
4707 4867
4708 default: 4868 default:
@@ -4728,20 +4888,14 @@ static void *
4728pure_alloc (size_t size, int type) 4888pure_alloc (size_t size, int type)
4729{ 4889{
4730 void *result; 4890 void *result;
4731#ifdef USE_LSB_TAG 4891#if USE_LSB_TAG
4732 size_t alignment = (1 << GCTYPEBITS); 4892 size_t alignment = GCALIGNMENT;
4733#else 4893#else
4734 size_t alignment = sizeof (EMACS_INT); 4894 size_t alignment = alignof (EMACS_INT);
4735 4895
4736 /* Give Lisp_Floats an extra alignment. */ 4896 /* Give Lisp_Floats an extra alignment. */
4737 if (type == Lisp_Float) 4897 if (type == Lisp_Float)
4738 { 4898 alignment = alignof (struct Lisp_Float);
4739#if defined __GNUC__ && __GNUC__ >= 2
4740 alignment = __alignof (struct Lisp_Float);
4741#else
4742 alignment = sizeof (struct Lisp_Float);
4743#endif
4744 }
4745#endif 4899#endif
4746 4900
4747 again: 4901 again:
@@ -4767,7 +4921,7 @@ pure_alloc (size_t size, int type)
4767 /* Don't allocate a large amount here, 4921 /* Don't allocate a large amount here,
4768 because it might get mmap'd and then its address 4922 because it might get mmap'd and then its address
4769 might not be usable. */ 4923 might not be usable. */
4770 purebeg = (char *) xmalloc (10000); 4924 purebeg = xmalloc (10000);
4771 pure_size = 10000; 4925 pure_size = 10000;
4772 pure_bytes_used_before_overflow += pure_bytes_used - size; 4926 pure_bytes_used_before_overflow += pure_bytes_used - size;
4773 pure_bytes_used = 0; 4927 pure_bytes_used = 0;
@@ -4856,7 +5010,7 @@ find_string_data_in_pure (const char *data, ptrdiff_t nbytes)
4856 5010
4857/* Return a string allocated in pure space. DATA is a buffer holding 5011/* Return a string allocated in pure space. DATA is a buffer holding
4858 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE 5012 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4859 non-zero means make the result string multibyte. 5013 means make the result string multibyte.
4860 5014
4861 Must get an error if pure storage is full, since if it cannot hold 5015 Must get an error if pure storage is full, since if it cannot hold
4862 a large string it may be able to hold conses that point to that 5016 a large string it may be able to hold conses that point to that
@@ -4864,41 +5018,36 @@ find_string_data_in_pure (const char *data, ptrdiff_t nbytes)
4864 5018
4865Lisp_Object 5019Lisp_Object
4866make_pure_string (const char *data, 5020make_pure_string (const char *data,
4867 ptrdiff_t nchars, ptrdiff_t nbytes, int multibyte) 5021 ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte)
4868{ 5022{
4869 Lisp_Object string; 5023 Lisp_Object string;
4870 struct Lisp_String *s; 5024 struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String);
4871
4872 s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
4873 s->data = (unsigned char *) find_string_data_in_pure (data, nbytes); 5025 s->data = (unsigned char *) find_string_data_in_pure (data, nbytes);
4874 if (s->data == NULL) 5026 if (s->data == NULL)
4875 { 5027 {
4876 s->data = (unsigned char *) pure_alloc (nbytes + 1, -1); 5028 s->data = pure_alloc (nbytes + 1, -1);
4877 memcpy (s->data, data, nbytes); 5029 memcpy (s->data, data, nbytes);
4878 s->data[nbytes] = '\0'; 5030 s->data[nbytes] = '\0';
4879 } 5031 }
4880 s->size = nchars; 5032 s->size = nchars;
4881 s->size_byte = multibyte ? nbytes : -1; 5033 s->size_byte = multibyte ? nbytes : -1;
4882 s->intervals = NULL_INTERVAL; 5034 s->intervals = NULL;
4883 XSETSTRING (string, s); 5035 XSETSTRING (string, s);
4884 return string; 5036 return string;
4885} 5037}
4886 5038
4887/* Return a string a string allocated in pure space. Do not allocate 5039/* Return a string allocated in pure space. Do not
4888 the string data, just point to DATA. */ 5040 allocate the string data, just point to DATA. */
4889 5041
4890Lisp_Object 5042Lisp_Object
4891make_pure_c_string (const char *data) 5043make_pure_c_string (const char *data, ptrdiff_t nchars)
4892{ 5044{
4893 Lisp_Object string; 5045 Lisp_Object string;
4894 struct Lisp_String *s; 5046 struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String);
4895 ptrdiff_t nchars = strlen (data);
4896
4897 s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
4898 s->size = nchars; 5047 s->size = nchars;
4899 s->size_byte = -1; 5048 s->size_byte = -1;
4900 s->data = (unsigned char *) data; 5049 s->data = (unsigned char *) data;
4901 s->intervals = NULL_INTERVAL; 5050 s->intervals = NULL;
4902 XSETSTRING (string, s); 5051 XSETSTRING (string, s);
4903 return string; 5052 return string;
4904} 5053}
@@ -4909,10 +5058,8 @@ make_pure_c_string (const char *data)
4909Lisp_Object 5058Lisp_Object
4910pure_cons (Lisp_Object car, Lisp_Object cdr) 5059pure_cons (Lisp_Object car, Lisp_Object cdr)
4911{ 5060{
4912 register Lisp_Object new; 5061 Lisp_Object new;
4913 struct Lisp_Cons *p; 5062 struct Lisp_Cons *p = pure_alloc (sizeof *p, Lisp_Cons);
4914
4915 p = (struct Lisp_Cons *) pure_alloc (sizeof *p, Lisp_Cons);
4916 XSETCONS (new, p); 5063 XSETCONS (new, p);
4917 XSETCAR (new, Fpurecopy (car)); 5064 XSETCAR (new, Fpurecopy (car));
4918 XSETCDR (new, Fpurecopy (cdr)); 5065 XSETCDR (new, Fpurecopy (cdr));
@@ -4925,10 +5072,8 @@ pure_cons (Lisp_Object car, Lisp_Object cdr)
4925static Lisp_Object 5072static Lisp_Object
4926make_pure_float (double num) 5073make_pure_float (double num)
4927{ 5074{
4928 register Lisp_Object new; 5075 Lisp_Object new;
4929 struct Lisp_Float *p; 5076 struct Lisp_Float *p = pure_alloc (sizeof *p, Lisp_Float);
4930
4931 p = (struct Lisp_Float *) pure_alloc (sizeof *p, Lisp_Float);
4932 XSETFLOAT (new, p); 5077 XSETFLOAT (new, p);
4933 XFLOAT_INIT (new, num); 5078 XFLOAT_INIT (new, num);
4934 return new; 5079 return new;
@@ -4942,11 +5087,8 @@ static Lisp_Object
4942make_pure_vector (ptrdiff_t len) 5087make_pure_vector (ptrdiff_t len)
4943{ 5088{
4944 Lisp_Object new; 5089 Lisp_Object new;
4945 struct Lisp_Vector *p; 5090 size_t size = header_size + len * word_size;
4946 size_t size = (offsetof (struct Lisp_Vector, contents) 5091 struct Lisp_Vector *p = pure_alloc (size, Lisp_Vectorlike);
4947 + len * sizeof (Lisp_Object));
4948
4949 p = (struct Lisp_Vector *) pure_alloc (size, Lisp_Vectorlike);
4950 XSETVECTOR (new, p); 5092 XSETVECTOR (new, p);
4951 XVECTOR (new)->header.size = len; 5093 XVECTOR (new)->header.size = len;
4952 return new; 5094 return new;
@@ -4991,7 +5133,7 @@ Does not copy symbols. Copies strings without text properties. */)
4991 size &= PSEUDOVECTOR_SIZE_MASK; 5133 size &= PSEUDOVECTOR_SIZE_MASK;
4992 vec = XVECTOR (make_pure_vector (size)); 5134 vec = XVECTOR (make_pure_vector (size));
4993 for (i = 0; i < size; i++) 5135 for (i = 0; i < size; i++)
4994 vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]); 5136 vec->contents[i] = Fpurecopy (AREF (obj, i));
4995 if (COMPILEDP (obj)) 5137 if (COMPILEDP (obj))
4996 { 5138 {
4997 XSETPVECTYPE (vec, PVEC_COMPILED); 5139 XSETPVECTYPE (vec, PVEC_COMPILED);
@@ -5024,9 +5166,9 @@ Does not copy symbols. Copies strings without text properties. */)
5024void 5166void
5025staticpro (Lisp_Object *varaddress) 5167staticpro (Lisp_Object *varaddress)
5026{ 5168{
5027 staticvec[staticidx++] = varaddress;
5028 if (staticidx >= NSTATICS) 5169 if (staticidx >= NSTATICS)
5029 abort (); 5170 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5171 staticvec[staticidx++] = varaddress;
5030} 5172}
5031 5173
5032 5174
@@ -5045,76 +5187,80 @@ inhibit_garbage_collection (void)
5045 return count; 5187 return count;
5046} 5188}
5047 5189
5190/* Used to avoid possible overflows when
5191 converting from C to Lisp integers. */
5192
5193static Lisp_Object
5194bounded_number (EMACS_INT number)
5195{
5196 return make_number (min (MOST_POSITIVE_FIXNUM, number));
5197}
5198
5199/* Calculate total bytes of live objects. */
5200
5201static size_t
5202total_bytes_of_live_objects (void)
5203{
5204 size_t tot = 0;
5205 tot += total_conses * sizeof (struct Lisp_Cons);
5206 tot += total_symbols * sizeof (struct Lisp_Symbol);
5207 tot += total_markers * sizeof (union Lisp_Misc);
5208 tot += total_string_bytes;
5209 tot += total_vector_slots * word_size;
5210 tot += total_floats * sizeof (struct Lisp_Float);
5211 tot += total_intervals * sizeof (struct interval);
5212 tot += total_strings * sizeof (struct Lisp_String);
5213 return tot;
5214}
5048 5215
5049DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "", 5216DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
5050 doc: /* Reclaim storage for Lisp objects no longer needed. 5217 doc: /* Reclaim storage for Lisp objects no longer needed.
5051Garbage collection happens automatically if you cons more than 5218Garbage collection happens automatically if you cons more than
5052`gc-cons-threshold' bytes of Lisp data since previous garbage collection. 5219`gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5053`garbage-collect' normally returns a list with info on amount of space in use: 5220`garbage-collect' normally returns a list with info on amount of space in use,
5054 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS) 5221where each entry has the form (NAME SIZE USED FREE), where:
5055 (USED-MISCS . FREE-MISCS) USED-STRING-CHARS USED-VECTOR-SLOTS 5222- NAME is a symbol describing the kind of objects this entry represents,
5056 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS) 5223- SIZE is the number of bytes used by each one,
5057 (USED-STRINGS . FREE-STRINGS)) 5224- USED is the number of those objects that were found live in the heap,
5225- FREE is the number of those objects that are not live but that Emacs
5226 keeps around for future allocations (maybe because it does not know how
5227 to return them to the OS).
5058However, if there was overflow in pure space, `garbage-collect' 5228However, if there was overflow in pure space, `garbage-collect'
5059returns nil, because real GC can't be done. 5229returns nil, because real GC can't be done.
5060See Info node `(elisp)Garbage Collection'. */) 5230See Info node `(elisp)Garbage Collection'. */)
5061 (void) 5231 (void)
5062{ 5232{
5063 register struct specbinding *bind; 5233 struct buffer *nextb;
5064 char stack_top_variable; 5234 char stack_top_variable;
5065 ptrdiff_t i; 5235 ptrdiff_t i;
5066 int message_p; 5236 bool message_p;
5067 Lisp_Object total[8];
5068 ptrdiff_t count = SPECPDL_INDEX (); 5237 ptrdiff_t count = SPECPDL_INDEX ();
5069 EMACS_TIME t1, t2, t3; 5238 struct timespec start;
5239 Lisp_Object retval = Qnil;
5240 size_t tot_before = 0;
5070 5241
5071 if (abort_on_gc) 5242 if (abort_on_gc)
5072 abort (); 5243 emacs_abort ();
5073 5244
5074 /* Can't GC if pure storage overflowed because we can't determine 5245 /* Can't GC if pure storage overflowed because we can't determine
5075 if something is a pure object or not. */ 5246 if something is a pure object or not. */
5076 if (pure_bytes_used_before_overflow) 5247 if (pure_bytes_used_before_overflow)
5077 return Qnil; 5248 return Qnil;
5078 5249
5079 CHECK_CONS_LIST (); 5250 /* Record this function, so it appears on the profiler's backtraces. */
5251 record_in_backtrace (Qautomatic_gc, &Qnil, 0);
5252
5253 check_cons_list ();
5080 5254
5081 /* Don't keep undo information around forever. 5255 /* Don't keep undo information around forever.
5082 Do this early on, so it is no problem if the user quits. */ 5256 Do this early on, so it is no problem if the user quits. */
5083 { 5257 FOR_EACH_BUFFER (nextb)
5084 register struct buffer *nextb = all_buffers; 5258 compact_buffer (nextb);
5085
5086 while (nextb)
5087 {
5088 /* If a buffer's undo list is Qt, that means that undo is
5089 turned off in that buffer. Calling truncate_undo_list on
5090 Qt tends to return NULL, which effectively turns undo back on.
5091 So don't call truncate_undo_list if undo_list is Qt. */
5092 if (! NILP (nextb->BUFFER_INTERNAL_FIELD (name)) && ! EQ (nextb->BUFFER_INTERNAL_FIELD (undo_list), Qt))
5093 truncate_undo_list (nextb);
5094
5095 /* Shrink buffer gaps, but skip indirect and dead buffers. */
5096 if (nextb->base_buffer == 0 && !NILP (nextb->BUFFER_INTERNAL_FIELD (name))
5097 && ! nextb->text->inhibit_shrinking)
5098 {
5099 /* If a buffer's gap size is more than 10% of the buffer
5100 size, or larger than 2000 bytes, then shrink it
5101 accordingly. Keep a minimum size of 20 bytes. */
5102 int size = min (2000, max (20, (nextb->text->z_byte / 10)));
5103 5259
5104 if (nextb->text->gap_size > size) 5260 if (profiler_memory_running)
5105 { 5261 tot_before = total_bytes_of_live_objects ();
5106 struct buffer *save_current = current_buffer;
5107 current_buffer = nextb;
5108 make_gap (-(nextb->text->gap_size - size));
5109 current_buffer = save_current;
5110 }
5111 }
5112
5113 nextb = nextb->header.next.buffer;
5114 }
5115 }
5116 5262
5117 EMACS_GET_TIME (t1); 5263 start = current_timespec ();
5118 5264
5119 /* In case user calls debug_print during GC, 5265 /* In case user calls debug_print during GC,
5120 don't let that cause a recursive GC. */ 5266 don't let that cause a recursive GC. */
@@ -5122,7 +5268,7 @@ See Info node `(elisp)Garbage Collection'. */)
5122 5268
5123 /* Save what's currently displayed in the echo area. */ 5269 /* Save what's currently displayed in the echo area. */
5124 message_p = push_message (); 5270 message_p = push_message ();
5125 record_unwind_protect (pop_message_unwind, Qnil); 5271 record_unwind_protect_void (pop_message_unwind);
5126 5272
5127 /* Save a copy of the contents of the stack, for debugging. */ 5273 /* Save a copy of the contents of the stack, for debugging. */
5128#if MAX_SAVE_STACK > 0 5274#if MAX_SAVE_STACK > 0
@@ -5144,7 +5290,7 @@ See Info node `(elisp)Garbage Collection'. */)
5144 { 5290 {
5145 if (stack_copy_size < stack_size) 5291 if (stack_copy_size < stack_size)
5146 { 5292 {
5147 stack_copy = (char *) xrealloc (stack_copy, stack_size); 5293 stack_copy = xrealloc (stack_copy, stack_size);
5148 stack_copy_size = stack_size; 5294 stack_copy_size = stack_size;
5149 } 5295 }
5150 memcpy (stack_copy, stack, stack_size); 5296 memcpy (stack_copy, stack, stack_size);
@@ -5155,33 +5301,26 @@ See Info node `(elisp)Garbage Collection'. */)
5155 if (garbage_collection_messages) 5301 if (garbage_collection_messages)
5156 message1_nolog ("Garbage collecting..."); 5302 message1_nolog ("Garbage collecting...");
5157 5303
5158 BLOCK_INPUT; 5304 block_input ();
5159 5305
5160 shrink_regexp_cache (); 5306 shrink_regexp_cache ();
5161 5307
5162 gc_in_progress = 1; 5308 gc_in_progress = 1;
5163 5309
5164 /* clear_marks (); */
5165
5166 /* Mark all the special slots that serve as the roots of accessibility. */ 5310 /* Mark all the special slots that serve as the roots of accessibility. */
5167 5311
5312 mark_buffer (&buffer_defaults);
5313 mark_buffer (&buffer_local_symbols);
5314
5168 for (i = 0; i < staticidx; i++) 5315 for (i = 0; i < staticidx; i++)
5169 mark_object (*staticvec[i]); 5316 mark_object (*staticvec[i]);
5170 5317
5171 for (bind = specpdl; bind != specpdl_ptr; bind++) 5318 mark_specpdl ();
5172 {
5173 mark_object (bind->symbol);
5174 mark_object (bind->old_value);
5175 }
5176 mark_terminals (); 5319 mark_terminals ();
5177 mark_kboards (); 5320 mark_kboards ();
5178 mark_ttys ();
5179 5321
5180#ifdef USE_GTK 5322#ifdef USE_GTK
5181 { 5323 xg_mark_data ();
5182 extern void xg_mark_data (void);
5183 xg_mark_data ();
5184 }
5185#endif 5324#endif
5186 5325
5187#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \ 5326#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
@@ -5210,7 +5349,6 @@ See Info node `(elisp)Garbage Collection'. */)
5210 mark_object (handler->var); 5349 mark_object (handler->var);
5211 } 5350 }
5212 } 5351 }
5213 mark_backtrace ();
5214#endif 5352#endif
5215 5353
5216#ifdef HAVE_WINDOW_SYSTEM 5354#ifdef HAVE_WINDOW_SYSTEM
@@ -5226,48 +5364,42 @@ See Info node `(elisp)Garbage Collection'. */)
5226 Look thru every buffer's undo list 5364 Look thru every buffer's undo list
5227 for elements that update markers that were not marked, 5365 for elements that update markers that were not marked,
5228 and delete them. */ 5366 and delete them. */
5229 { 5367 FOR_EACH_BUFFER (nextb)
5230 register struct buffer *nextb = all_buffers; 5368 {
5231 5369 /* If a buffer's undo list is Qt, that means that undo is
5232 while (nextb) 5370 turned off in that buffer. Calling truncate_undo_list on
5233 { 5371 Qt tends to return NULL, which effectively turns undo back on.
5234 /* If a buffer's undo list is Qt, that means that undo is 5372 So don't call truncate_undo_list if undo_list is Qt. */
5235 turned off in that buffer. Calling truncate_undo_list on 5373 if (! EQ (nextb->INTERNAL_FIELD (undo_list), Qt))
5236 Qt tends to return NULL, which effectively turns undo back on. 5374 {
5237 So don't call truncate_undo_list if undo_list is Qt. */ 5375 Lisp_Object tail, prev;
5238 if (! EQ (nextb->BUFFER_INTERNAL_FIELD (undo_list), Qt)) 5376 tail = nextb->INTERNAL_FIELD (undo_list);
5239 { 5377 prev = Qnil;
5240 Lisp_Object tail, prev; 5378 while (CONSP (tail))
5241 tail = nextb->BUFFER_INTERNAL_FIELD (undo_list); 5379 {
5242 prev = Qnil; 5380 if (CONSP (XCAR (tail))
5243 while (CONSP (tail)) 5381 && MARKERP (XCAR (XCAR (tail)))
5244 { 5382 && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
5245 if (CONSP (XCAR (tail)) 5383 {
5246 && MARKERP (XCAR (XCAR (tail))) 5384 if (NILP (prev))
5247 && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit) 5385 nextb->INTERNAL_FIELD (undo_list) = tail = XCDR (tail);
5248 { 5386 else
5249 if (NILP (prev)) 5387 {
5250 nextb->BUFFER_INTERNAL_FIELD (undo_list) = tail = XCDR (tail); 5388 tail = XCDR (tail);
5251 else 5389 XSETCDR (prev, tail);
5252 { 5390 }
5253 tail = XCDR (tail); 5391 }
5254 XSETCDR (prev, tail); 5392 else
5255 } 5393 {
5256 } 5394 prev = tail;
5257 else 5395 tail = XCDR (tail);
5258 { 5396 }
5259 prev = tail; 5397 }
5260 tail = XCDR (tail); 5398 }
5261 } 5399 /* Now that we have stripped the elements that need not be in the
5262 } 5400 undo_list any more, we can finally mark the list. */
5263 } 5401 mark_object (nextb->INTERNAL_FIELD (undo_list));
5264 /* Now that we have stripped the elements that need not be in the 5402 }
5265 undo_list any more, we can finally mark the list. */
5266 mark_object (nextb->BUFFER_INTERNAL_FIELD (undo_list));
5267
5268 nextb = nextb->header.next.buffer;
5269 }
5270 }
5271 5403
5272 gc_sweep (); 5404 gc_sweep ();
5273 5405
@@ -5281,30 +5413,20 @@ See Info node `(elisp)Garbage Collection'. */)
5281 dump_zombies (); 5413 dump_zombies ();
5282#endif 5414#endif
5283 5415
5284 UNBLOCK_INPUT; 5416 check_cons_list ();
5285
5286 CHECK_CONS_LIST ();
5287 5417
5288 /* clear_marks (); */
5289 gc_in_progress = 0; 5418 gc_in_progress = 0;
5290 5419
5420 unblock_input ();
5421
5291 consing_since_gc = 0; 5422 consing_since_gc = 0;
5292 if (gc_cons_threshold < 10000) 5423 if (gc_cons_threshold < GC_DEFAULT_THRESHOLD / 10)
5293 gc_cons_threshold = 10000; 5424 gc_cons_threshold = GC_DEFAULT_THRESHOLD / 10;
5294 5425
5295 gc_relative_threshold = 0; 5426 gc_relative_threshold = 0;
5296 if (FLOATP (Vgc_cons_percentage)) 5427 if (FLOATP (Vgc_cons_percentage))
5297 { /* Set gc_cons_combined_threshold. */ 5428 { /* Set gc_cons_combined_threshold. */
5298 double tot = 0; 5429 double tot = total_bytes_of_live_objects ();
5299
5300 tot += total_conses * sizeof (struct Lisp_Cons);
5301 tot += total_symbols * sizeof (struct Lisp_Symbol);
5302 tot += total_markers * sizeof (union Lisp_Misc);
5303 tot += total_string_size;
5304 tot += total_vector_size * sizeof (Lisp_Object);
5305 tot += total_floats * sizeof (struct Lisp_Float);
5306 tot += total_intervals * sizeof (struct interval);
5307 tot += total_strings * sizeof (struct Lisp_String);
5308 5430
5309 tot *= XFLOAT_DATA (Vgc_cons_percentage); 5431 tot *= XFLOAT_DATA (Vgc_cons_percentage);
5310 if (0 < tot) 5432 if (0 < tot)
@@ -5325,37 +5447,70 @@ See Info node `(elisp)Garbage Collection'. */)
5325 } 5447 }
5326 5448
5327 unbind_to (count, Qnil); 5449 unbind_to (count, Qnil);
5450 {
5451 Lisp_Object total[11];
5452 int total_size = 10;
5453
5454 total[0] = list4 (Qconses, make_number (sizeof (struct Lisp_Cons)),
5455 bounded_number (total_conses),
5456 bounded_number (total_free_conses));
5457
5458 total[1] = list4 (Qsymbols, make_number (sizeof (struct Lisp_Symbol)),
5459 bounded_number (total_symbols),
5460 bounded_number (total_free_symbols));
5461
5462 total[2] = list4 (Qmiscs, make_number (sizeof (union Lisp_Misc)),
5463 bounded_number (total_markers),
5464 bounded_number (total_free_markers));
5465
5466 total[3] = list4 (Qstrings, make_number (sizeof (struct Lisp_String)),
5467 bounded_number (total_strings),
5468 bounded_number (total_free_strings));
5469
5470 total[4] = list3 (Qstring_bytes, make_number (1),
5471 bounded_number (total_string_bytes));
5472
5473 total[5] = list3 (Qvectors,
5474 make_number (header_size + sizeof (Lisp_Object)),
5475 bounded_number (total_vectors));
5476
5477 total[6] = list4 (Qvector_slots, make_number (word_size),
5478 bounded_number (total_vector_slots),
5479 bounded_number (total_free_vector_slots));
5328 5480
5329 total[0] = Fcons (make_number (total_conses), 5481 total[7] = list4 (Qfloats, make_number (sizeof (struct Lisp_Float)),
5330 make_number (total_free_conses)); 5482 bounded_number (total_floats),
5331 total[1] = Fcons (make_number (total_symbols), 5483 bounded_number (total_free_floats));
5332 make_number (total_free_symbols)); 5484
5333 total[2] = Fcons (make_number (total_markers), 5485 total[8] = list4 (Qintervals, make_number (sizeof (struct interval)),
5334 make_number (total_free_markers)); 5486 bounded_number (total_intervals),
5335 total[3] = make_number (total_string_size); 5487 bounded_number (total_free_intervals));
5336 total[4] = make_number (total_vector_size); 5488
5337 total[5] = Fcons (make_number (total_floats), 5489 total[9] = list3 (Qbuffers, make_number (sizeof (struct buffer)),
5338 make_number (total_free_floats)); 5490 bounded_number (total_buffers));
5339 total[6] = Fcons (make_number (total_intervals), 5491
5340 make_number (total_free_intervals)); 5492#ifdef DOUG_LEA_MALLOC
5341 total[7] = Fcons (make_number (total_strings), 5493 total_size++;
5342 make_number (total_free_strings)); 5494 total[10] = list4 (Qheap, make_number (1024),
5495 bounded_number ((mallinfo ().uordblks + 1023) >> 10),
5496 bounded_number ((mallinfo ().fordblks + 1023) >> 10));
5497#endif
5498 retval = Flist (total_size, total);
5499 }
5343 5500
5344#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES 5501#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5345 { 5502 {
5346 /* Compute average percentage of zombies. */ 5503 /* Compute average percentage of zombies. */
5347 double nlive = 0; 5504 double nlive
5348 5505 = (total_conses + total_symbols + total_markers + total_strings
5349 for (i = 0; i < 7; ++i) 5506 + total_vectors + total_floats + total_intervals + total_buffers);
5350 if (CONSP (total[i]))
5351 nlive += XFASTINT (XCAR (total[i]));
5352 5507
5353 avg_live = (avg_live * ngcs + nlive) / (ngcs + 1); 5508 avg_live = (avg_live * ngcs + nlive) / (ngcs + 1);
5354 max_live = max (nlive, max_live); 5509 max_live = max (nlive, max_live);
5355 avg_zombies = (avg_zombies * ngcs + nzombies) / (ngcs + 1); 5510 avg_zombies = (avg_zombies * ngcs + nzombies) / (ngcs + 1);
5356 max_zombies = max (nzombies, max_zombies); 5511 max_zombies = max (nzombies, max_zombies);
5357 ++ngcs; 5512 ++ngcs;
5358 } 5513 }
5359#endif 5514#endif
5360 5515
5361 if (!NILP (Vpost_gc_hook)) 5516 if (!NILP (Vpost_gc_hook))
@@ -5366,15 +5521,26 @@ See Info node `(elisp)Garbage Collection'. */)
5366 } 5521 }
5367 5522
5368 /* Accumulate statistics. */ 5523 /* Accumulate statistics. */
5369 EMACS_GET_TIME (t2);
5370 EMACS_SUB_TIME (t3, t2, t1);
5371 if (FLOATP (Vgc_elapsed)) 5524 if (FLOATP (Vgc_elapsed))
5372 Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed) + 5525 {
5373 EMACS_SECS (t3) + 5526 struct timespec since_start = timespec_sub (current_timespec (), start);
5374 EMACS_USECS (t3) * 1.0e-6); 5527 Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed)
5528 + timespectod (since_start));
5529 }
5530
5375 gcs_done++; 5531 gcs_done++;
5376 5532
5377 return Flist (sizeof total / sizeof *total, total); 5533 /* Collect profiling data. */
5534 if (profiler_memory_running)
5535 {
5536 size_t swept = 0;
5537 size_t tot_after = total_bytes_of_live_objects ();
5538 if (tot_before > tot_after)
5539 swept = tot_before - tot_after;
5540 malloc_probe (swept);
5541 }
5542
5543 return retval;
5378} 5544}
5379 5545
5380 5546
@@ -5449,15 +5615,15 @@ mark_vectorlike (struct Lisp_Vector *ptr)
5449 ptrdiff_t i; 5615 ptrdiff_t i;
5450 5616
5451 eassert (!VECTOR_MARKED_P (ptr)); 5617 eassert (!VECTOR_MARKED_P (ptr));
5452 VECTOR_MARK (ptr); /* Else mark it */ 5618 VECTOR_MARK (ptr); /* Else mark it. */
5453 if (size & PSEUDOVECTOR_FLAG) 5619 if (size & PSEUDOVECTOR_FLAG)
5454 size &= PSEUDOVECTOR_SIZE_MASK; 5620 size &= PSEUDOVECTOR_SIZE_MASK;
5455 5621
5456 /* Note that this size is not the memory-footprint size, but only 5622 /* Note that this size is not the memory-footprint size, but only
5457 the number of Lisp_Object fields that we should trace. 5623 the number of Lisp_Object fields that we should trace.
5458 The distinction is used e.g. by Lisp_Process which places extra 5624 The distinction is used e.g. by Lisp_Process which places extra
5459 non-Lisp_Object fields at the end of the structure. */ 5625 non-Lisp_Object fields at the end of the structure... */
5460 for (i = 0; i < size; i++) /* and then mark its elements */ 5626 for (i = 0; i < size; i++) /* ...and then mark its elements. */
5461 mark_object (ptr->contents[i]); 5627 mark_object (ptr->contents[i]);
5462} 5628}
5463 5629
@@ -5489,6 +5655,73 @@ mark_char_table (struct Lisp_Vector *ptr)
5489 } 5655 }
5490} 5656}
5491 5657
5658/* Mark the chain of overlays starting at PTR. */
5659
5660static void
5661mark_overlay (struct Lisp_Overlay *ptr)
5662{
5663 for (; ptr && !ptr->gcmarkbit; ptr = ptr->next)
5664 {
5665 ptr->gcmarkbit = 1;
5666 mark_object (ptr->start);
5667 mark_object (ptr->end);
5668 mark_object (ptr->plist);
5669 }
5670}
5671
5672/* Mark Lisp_Objects and special pointers in BUFFER. */
5673
5674static void
5675mark_buffer (struct buffer *buffer)
5676{
5677 /* This is handled much like other pseudovectors... */
5678 mark_vectorlike ((struct Lisp_Vector *) buffer);
5679
5680 /* ...but there are some buffer-specific things. */
5681
5682 MARK_INTERVAL_TREE (buffer_intervals (buffer));
5683
5684 /* For now, we just don't mark the undo_list. It's done later in
5685 a special way just before the sweep phase, and after stripping
5686 some of its elements that are not needed any more. */
5687
5688 mark_overlay (buffer->overlays_before);
5689 mark_overlay (buffer->overlays_after);
5690
5691 /* If this is an indirect buffer, mark its base buffer. */
5692 if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
5693 mark_buffer (buffer->base_buffer);
5694}
5695
5696/* Remove killed buffers or items whose car is a killed buffer from
5697 LIST, and mark other items. Return changed LIST, which is marked. */
5698
5699static Lisp_Object
5700mark_discard_killed_buffers (Lisp_Object list)
5701{
5702 Lisp_Object tail, *prev = &list;
5703
5704 for (tail = list; CONSP (tail) && !CONS_MARKED_P (XCONS (tail));
5705 tail = XCDR (tail))
5706 {
5707 Lisp_Object tem = XCAR (tail);
5708 if (CONSP (tem))
5709 tem = XCAR (tem);
5710 if (BUFFERP (tem) && !BUFFER_LIVE_P (XBUFFER (tem)))
5711 *prev = XCDR (tail);
5712 else
5713 {
5714 CONS_MARK (XCONS (tail));
5715 mark_object (XCAR (tail));
5716 prev = xcdr_addr (tail);
5717 }
5718 }
5719 mark_object (tail);
5720 return list;
5721}
5722
5723/* Determine type of generic Lisp_Object and mark it accordingly. */
5724
5492void 5725void
5493mark_object (Lisp_Object arg) 5726mark_object (Lisp_Object arg)
5494{ 5727{
@@ -5521,7 +5754,7 @@ mark_object (Lisp_Object arg)
5521 do { \ 5754 do { \
5522 m = mem_find (po); \ 5755 m = mem_find (po); \
5523 if (m == MEM_NIL) \ 5756 if (m == MEM_NIL) \
5524 abort (); \ 5757 emacs_abort (); \
5525 } while (0) 5758 } while (0)
5526 5759
5527 /* Check that the object pointed to by PO is live, using predicate 5760 /* Check that the object pointed to by PO is live, using predicate
@@ -5529,7 +5762,7 @@ mark_object (Lisp_Object arg)
5529#define CHECK_LIVE(LIVEP) \ 5762#define CHECK_LIVE(LIVEP) \
5530 do { \ 5763 do { \
5531 if (!LIVEP (m, po)) \ 5764 if (!LIVEP (m, po)) \
5532 abort (); \ 5765 emacs_abort (); \
5533 } while (0) 5766 } while (0)
5534 5767
5535 /* Check both of the above conditions. */ 5768 /* Check both of the above conditions. */
@@ -5546,7 +5779,7 @@ mark_object (Lisp_Object arg)
5546 5779
5547#endif /* not GC_CHECK_MARKED_OBJECTS */ 5780#endif /* not GC_CHECK_MARKED_OBJECTS */
5548 5781
5549 switch (SWITCH_ENUM_CAST (XTYPE (obj))) 5782 switch (XTYPE (obj))
5550 { 5783 {
5551 case Lisp_String: 5784 case Lisp_String:
5552 { 5785 {
@@ -5554,99 +5787,141 @@ mark_object (Lisp_Object arg)
5554 if (STRING_MARKED_P (ptr)) 5787 if (STRING_MARKED_P (ptr))
5555 break; 5788 break;
5556 CHECK_ALLOCATED_AND_LIVE (live_string_p); 5789 CHECK_ALLOCATED_AND_LIVE (live_string_p);
5557 MARK_INTERVAL_TREE (ptr->intervals);
5558 MARK_STRING (ptr); 5790 MARK_STRING (ptr);
5791 MARK_INTERVAL_TREE (ptr->intervals);
5559#ifdef GC_CHECK_STRING_BYTES 5792#ifdef GC_CHECK_STRING_BYTES
5560 /* Check that the string size recorded in the string is the 5793 /* Check that the string size recorded in the string is the
5561 same as the one recorded in the sdata structure. */ 5794 same as the one recorded in the sdata structure. */
5562 CHECK_STRING_BYTES (ptr); 5795 string_bytes (ptr);
5563#endif /* GC_CHECK_STRING_BYTES */ 5796#endif /* GC_CHECK_STRING_BYTES */
5564 } 5797 }
5565 break; 5798 break;
5566 5799
5567 case Lisp_Vectorlike: 5800 case Lisp_Vectorlike:
5568 if (VECTOR_MARKED_P (XVECTOR (obj))) 5801 {
5569 break; 5802 register struct Lisp_Vector *ptr = XVECTOR (obj);
5803 register ptrdiff_t pvectype;
5804
5805 if (VECTOR_MARKED_P (ptr))
5806 break;
5807
5570#ifdef GC_CHECK_MARKED_OBJECTS 5808#ifdef GC_CHECK_MARKED_OBJECTS
5571 m = mem_find (po); 5809 m = mem_find (po);
5572 if (m == MEM_NIL && !SUBRP (obj) 5810 if (m == MEM_NIL && !SUBRP (obj))
5573 && po != &buffer_defaults 5811 emacs_abort ();
5574 && po != &buffer_local_symbols)
5575 abort ();
5576#endif /* GC_CHECK_MARKED_OBJECTS */ 5812#endif /* GC_CHECK_MARKED_OBJECTS */
5577 5813
5578 if (BUFFERP (obj)) 5814 if (ptr->header.size & PSEUDOVECTOR_FLAG)
5579 { 5815 pvectype = ((ptr->header.size & PVEC_TYPE_MASK)
5816 >> PSEUDOVECTOR_AREA_BITS);
5817 else
5818 pvectype = PVEC_NORMAL_VECTOR;
5819
5820 if (pvectype != PVEC_SUBR && pvectype != PVEC_BUFFER)
5821 CHECK_LIVE (live_vector_p);
5822
5823 switch (pvectype)
5824 {
5825 case PVEC_BUFFER:
5580#ifdef GC_CHECK_MARKED_OBJECTS 5826#ifdef GC_CHECK_MARKED_OBJECTS
5581 if (po != &buffer_defaults && po != &buffer_local_symbols)
5582 { 5827 {
5583 struct buffer *b; 5828 struct buffer *b;
5584 for (b = all_buffers; b && b != po; b = b->header.next.buffer) 5829 FOR_EACH_BUFFER (b)
5585 ; 5830 if (b == po)
5831 break;
5586 if (b == NULL) 5832 if (b == NULL)
5587 abort (); 5833 emacs_abort ();
5588 } 5834 }
5589#endif /* GC_CHECK_MARKED_OBJECTS */ 5835#endif /* GC_CHECK_MARKED_OBJECTS */
5590 mark_buffer (obj); 5836 mark_buffer ((struct buffer *) ptr);
5591 } 5837 break;
5592 else if (SUBRP (obj))
5593 break;
5594 else if (COMPILEDP (obj))
5595 /* We could treat this just like a vector, but it is better to
5596 save the COMPILED_CONSTANTS element for last and avoid
5597 recursion there. */
5598 {
5599 register struct Lisp_Vector *ptr = XVECTOR (obj);
5600 int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
5601 int i;
5602 5838
5603 CHECK_LIVE (live_vector_p); 5839 case PVEC_COMPILED:
5604 VECTOR_MARK (ptr); /* Else mark it */ 5840 { /* We could treat this just like a vector, but it is better
5605 for (i = 0; i < size; i++) /* and then mark its elements */ 5841 to save the COMPILED_CONSTANTS element for last and avoid
5842 recursion there. */
5843 int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
5844 int i;
5845
5846 VECTOR_MARK (ptr);
5847 for (i = 0; i < size; i++)
5848 if (i != COMPILED_CONSTANTS)
5849 mark_object (ptr->contents[i]);
5850 if (size > COMPILED_CONSTANTS)
5851 {
5852 obj = ptr->contents[COMPILED_CONSTANTS];
5853 goto loop;
5854 }
5855 }
5856 break;
5857
5858 case PVEC_FRAME:
5859 mark_vectorlike (ptr);
5860 mark_face_cache (((struct frame *) ptr)->face_cache);
5861 break;
5862
5863 case PVEC_WINDOW:
5606 { 5864 {
5607 if (i != COMPILED_CONSTANTS) 5865 struct window *w = (struct window *) ptr;
5608 mark_object (ptr->contents[i]); 5866
5867 mark_vectorlike (ptr);
5868
5869 /* Mark glyph matrices, if any. Marking window
5870 matrices is sufficient because frame matrices
5871 use the same glyph memory. */
5872 if (w->current_matrix)
5873 {
5874 mark_glyph_matrix (w->current_matrix);
5875 mark_glyph_matrix (w->desired_matrix);
5876 }
5877
5878 /* Filter out killed buffers from both buffer lists
5879 in attempt to help GC to reclaim killed buffers faster.
5880 We can do it elsewhere for live windows, but this is the
5881 best place to do it for dead windows. */
5882 wset_prev_buffers
5883 (w, mark_discard_killed_buffers (w->prev_buffers));
5884 wset_next_buffers
5885 (w, mark_discard_killed_buffers (w->next_buffers));
5609 } 5886 }
5610 obj = ptr->contents[COMPILED_CONSTANTS]; 5887 break;
5611 goto loop; 5888
5612 } 5889 case PVEC_HASH_TABLE:
5613 else if (FRAMEP (obj))
5614 {
5615 register struct frame *ptr = XFRAME (obj);
5616 mark_vectorlike (XVECTOR (obj));
5617 mark_face_cache (ptr->face_cache);
5618 }
5619 else if (WINDOWP (obj))
5620 {
5621 register struct Lisp_Vector *ptr = XVECTOR (obj);
5622 struct window *w = XWINDOW (obj);
5623 mark_vectorlike (ptr);
5624 /* Mark glyphs for leaf windows. Marking window matrices is
5625 sufficient because frame matrices use the same glyph
5626 memory. */
5627 if (NILP (w->hchild)
5628 && NILP (w->vchild)
5629 && w->current_matrix)
5630 { 5890 {
5631 mark_glyph_matrix (w->current_matrix); 5891 struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *) ptr;
5632 mark_glyph_matrix (w->desired_matrix); 5892
5893 mark_vectorlike (ptr);
5894 mark_object (h->test.name);
5895 mark_object (h->test.user_hash_function);
5896 mark_object (h->test.user_cmp_function);
5897 /* If hash table is not weak, mark all keys and values.
5898 For weak tables, mark only the vector. */
5899 if (NILP (h->weak))
5900 mark_object (h->key_and_value);
5901 else
5902 VECTOR_MARK (XVECTOR (h->key_and_value));
5633 } 5903 }
5634 } 5904 break;
5635 else if (HASH_TABLE_P (obj)) 5905
5636 { 5906 case PVEC_CHAR_TABLE:
5637 struct Lisp_Hash_Table *h = XHASH_TABLE (obj); 5907 mark_char_table (ptr);
5638 mark_vectorlike ((struct Lisp_Vector *)h); 5908 break;
5639 /* If hash table is not weak, mark all keys and values. 5909
5640 For weak tables, mark only the vector. */ 5910 case PVEC_BOOL_VECTOR:
5641 if (NILP (h->weak)) 5911 /* No Lisp_Objects to mark in a bool vector. */
5642 mark_object (h->key_and_value); 5912 VECTOR_MARK (ptr);
5643 else 5913 break;
5644 VECTOR_MARK (XVECTOR (h->key_and_value)); 5914
5645 } 5915 case PVEC_SUBR:
5646 else if (CHAR_TABLE_P (obj)) 5916 break;
5647 mark_char_table (XVECTOR (obj)); 5917
5648 else 5918 case PVEC_FREE:
5649 mark_vectorlike (XVECTOR (obj)); 5919 emacs_abort ();
5920
5921 default:
5922 mark_vectorlike (ptr);
5923 }
5924 }
5650 break; 5925 break;
5651 5926
5652 case Lisp_Symbol: 5927 case Lisp_Symbol:
@@ -5673,10 +5948,14 @@ mark_object (Lisp_Object arg)
5673 case SYMBOL_LOCALIZED: 5948 case SYMBOL_LOCALIZED:
5674 { 5949 {
5675 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr); 5950 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
5676 /* If the value is forwarded to a buffer or keyboard field, 5951 Lisp_Object where = blv->where;
5677 these are marked when we see the corresponding object. 5952 /* If the value is set up for a killed buffer or deleted
5678 And if it's forwarded to a C variable, either it's not 5953 frame, restore it's global binding. If the value is
5679 a Lisp_Object var, or it's staticpro'd already. */ 5954 forwarded to a C variable, either it's not a Lisp_Object
5955 var, or it's staticpro'd already. */
5956 if ((BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where)))
5957 || (FRAMEP (where) && !FRAME_LIVE_P (XFRAME (where))))
5958 swap_in_global_binding (ptr);
5680 mark_object (blv->where); 5959 mark_object (blv->where);
5681 mark_object (blv->valcell); 5960 mark_object (blv->valcell);
5682 mark_object (blv->defcell); 5961 mark_object (blv->defcell);
@@ -5688,16 +5967,16 @@ mark_object (Lisp_Object arg)
5688 And if it's forwarded to a C variable, either it's not 5967 And if it's forwarded to a C variable, either it's not
5689 a Lisp_Object var, or it's staticpro'd already. */ 5968 a Lisp_Object var, or it's staticpro'd already. */
5690 break; 5969 break;
5691 default: abort (); 5970 default: emacs_abort ();
5692 } 5971 }
5693 if (!PURE_POINTER_P (XSTRING (ptr->xname))) 5972 if (!PURE_POINTER_P (XSTRING (ptr->name)))
5694 MARK_STRING (XSTRING (ptr->xname)); 5973 MARK_STRING (XSTRING (ptr->name));
5695 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname)); 5974 MARK_INTERVAL_TREE (string_intervals (ptr->name));
5696 5975
5697 ptr = ptr->next; 5976 ptr = ptr->next;
5698 if (ptr) 5977 if (ptr)
5699 { 5978 {
5700 ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun */ 5979 ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun. */
5701 XSETSYMBOL (obj, ptrx); 5980 XSETSYMBOL (obj, ptrx);
5702 goto loop; 5981 goto loop;
5703 } 5982 }
@@ -5706,52 +5985,50 @@ mark_object (Lisp_Object arg)
5706 5985
5707 case Lisp_Misc: 5986 case Lisp_Misc:
5708 CHECK_ALLOCATED_AND_LIVE (live_misc_p); 5987 CHECK_ALLOCATED_AND_LIVE (live_misc_p);
5988
5709 if (XMISCANY (obj)->gcmarkbit) 5989 if (XMISCANY (obj)->gcmarkbit)
5710 break; 5990 break;
5711 XMISCANY (obj)->gcmarkbit = 1;
5712 5991
5713 switch (XMISCTYPE (obj)) 5992 switch (XMISCTYPE (obj))
5714 { 5993 {
5715
5716 case Lisp_Misc_Marker: 5994 case Lisp_Misc_Marker:
5717 /* DO NOT mark thru the marker's chain. 5995 /* DO NOT mark thru the marker's chain.
5718 The buffer's markers chain does not preserve markers from gc; 5996 The buffer's markers chain does not preserve markers from gc;
5719 instead, markers are removed from the chain when freed by gc. */ 5997 instead, markers are removed from the chain when freed by gc. */
5998 XMISCANY (obj)->gcmarkbit = 1;
5720 break; 5999 break;
5721 6000
5722 case Lisp_Misc_Save_Value: 6001 case Lisp_Misc_Save_Value:
5723#if GC_MARK_STACK 6002 XMISCANY (obj)->gcmarkbit = 1;
5724 { 6003 {
5725 register struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj); 6004 struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj);
5726 /* If DOGC is set, POINTER is the address of a memory 6005 /* If `save_type' is zero, `data[0].pointer' is the address
5727 area containing INTEGER potential Lisp_Objects. */ 6006 of a memory area containing `data[1].integer' potential
5728 if (ptr->dogc) 6007 Lisp_Objects. */
6008 if (GC_MARK_STACK && ptr->save_type == SAVE_TYPE_MEMORY)
5729 { 6009 {
5730 Lisp_Object *p = (Lisp_Object *) ptr->pointer; 6010 Lisp_Object *p = ptr->data[0].pointer;
5731 ptrdiff_t nelt; 6011 ptrdiff_t nelt;
5732 for (nelt = ptr->integer; nelt > 0; nelt--, p++) 6012 for (nelt = ptr->data[1].integer; nelt > 0; nelt--, p++)
5733 mark_maybe_object (*p); 6013 mark_maybe_object (*p);
5734 } 6014 }
6015 else
6016 {
6017 /* Find Lisp_Objects in `data[N]' slots and mark them. */
6018 int i;
6019 for (i = 0; i < SAVE_VALUE_SLOTS; i++)
6020 if (save_type (ptr, i) == SAVE_OBJECT)
6021 mark_object (ptr->data[i].object);
6022 }
5735 } 6023 }
5736#endif
5737 break; 6024 break;
5738 6025
5739 case Lisp_Misc_Overlay: 6026 case Lisp_Misc_Overlay:
5740 { 6027 mark_overlay (XOVERLAY (obj));
5741 struct Lisp_Overlay *ptr = XOVERLAY (obj);
5742 mark_object (ptr->start);
5743 mark_object (ptr->end);
5744 mark_object (ptr->plist);
5745 if (ptr->next)
5746 {
5747 XSETMISC (obj, ptr->next);
5748 goto loop;
5749 }
5750 }
5751 break; 6028 break;
5752 6029
5753 default: 6030 default:
5754 abort (); 6031 emacs_abort ();
5755 } 6032 }
5756 break; 6033 break;
5757 6034
@@ -5773,7 +6050,7 @@ mark_object (Lisp_Object arg)
5773 obj = ptr->u.cdr; 6050 obj = ptr->u.cdr;
5774 cdr_count++; 6051 cdr_count++;
5775 if (cdr_count == mark_object_loop_halt) 6052 if (cdr_count == mark_object_loop_halt)
5776 abort (); 6053 emacs_abort ();
5777 goto loop; 6054 goto loop;
5778 } 6055 }
5779 6056
@@ -5786,59 +6063,13 @@ mark_object (Lisp_Object arg)
5786 break; 6063 break;
5787 6064
5788 default: 6065 default:
5789 abort (); 6066 emacs_abort ();
5790 } 6067 }
5791 6068
5792#undef CHECK_LIVE 6069#undef CHECK_LIVE
5793#undef CHECK_ALLOCATED 6070#undef CHECK_ALLOCATED
5794#undef CHECK_ALLOCATED_AND_LIVE 6071#undef CHECK_ALLOCATED_AND_LIVE
5795} 6072}
5796
5797/* Mark the pointers in a buffer structure. */
5798
5799static void
5800mark_buffer (Lisp_Object buf)
5801{
5802 register struct buffer *buffer = XBUFFER (buf);
5803 register Lisp_Object *ptr, tmp;
5804 Lisp_Object base_buffer;
5805
5806 eassert (!VECTOR_MARKED_P (buffer));
5807 VECTOR_MARK (buffer);
5808
5809 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
5810
5811 /* For now, we just don't mark the undo_list. It's done later in
5812 a special way just before the sweep phase, and after stripping
5813 some of its elements that are not needed any more. */
5814
5815 if (buffer->overlays_before)
5816 {
5817 XSETMISC (tmp, buffer->overlays_before);
5818 mark_object (tmp);
5819 }
5820 if (buffer->overlays_after)
5821 {
5822 XSETMISC (tmp, buffer->overlays_after);
5823 mark_object (tmp);
5824 }
5825
5826 /* buffer-local Lisp variables start at `undo_list',
5827 tho only the ones from `name' on are GC'd normally. */
5828 for (ptr = &buffer->BUFFER_INTERNAL_FIELD (name);
5829 ptr <= &PER_BUFFER_VALUE (buffer,
5830 PER_BUFFER_VAR_OFFSET (LAST_FIELD_PER_BUFFER));
5831 ptr++)
5832 mark_object (*ptr);
5833
5834 /* If this is an indirect buffer, mark its base buffer. */
5835 if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
5836 {
5837 XSETBUFFER (base_buffer, buffer->base_buffer);
5838 mark_buffer (base_buffer);
5839 }
5840}
5841
5842/* Mark the Lisp pointers in the terminal objects. 6073/* Mark the Lisp pointers in the terminal objects.
5843 Called by Fgarbage_collect. */ 6074 Called by Fgarbage_collect. */
5844 6075
@@ -5865,10 +6096,10 @@ mark_terminals (void)
5865/* Value is non-zero if OBJ will survive the current GC because it's 6096/* Value is non-zero if OBJ will survive the current GC because it's
5866 either marked or does not need to be marked to survive. */ 6097 either marked or does not need to be marked to survive. */
5867 6098
5868int 6099bool
5869survives_gc_p (Lisp_Object obj) 6100survives_gc_p (Lisp_Object obj)
5870{ 6101{
5871 int survives_p; 6102 bool survives_p;
5872 6103
5873 switch (XTYPE (obj)) 6104 switch (XTYPE (obj))
5874 { 6105 {
@@ -5901,7 +6132,7 @@ survives_gc_p (Lisp_Object obj)
5901 break; 6132 break;
5902 6133
5903 default: 6134 default:
5904 abort (); 6135 emacs_abort ();
5905 } 6136 }
5906 6137
5907 return survives_p || PURE_POINTER_P ((void *) XPNTR (obj)); 6138 return survives_p || PURE_POINTER_P ((void *) XPNTR (obj));
@@ -5919,10 +6150,7 @@ gc_sweep (void)
5919 sweep_weak_hash_tables (); 6150 sweep_weak_hash_tables ();
5920 6151
5921 sweep_strings (); 6152 sweep_strings ();
5922#ifdef GC_CHECK_STRING_BYTES 6153 check_string_bytes (!noninteractive);
5923 if (!noninteractive)
5924 check_string_bytes (1);
5925#endif
5926 6154
5927 /* Put all unmarked conses on free list */ 6155 /* Put all unmarked conses on free list */
5928 { 6156 {
@@ -6065,7 +6293,7 @@ gc_sweep (void)
6065 { 6293 {
6066 if (!iblk->intervals[i].gcmarkbit) 6294 if (!iblk->intervals[i].gcmarkbit)
6067 { 6295 {
6068 SET_INTERVAL_PARENT (&iblk->intervals[i], interval_free_list); 6296 set_interval_parent (&iblk->intervals[i], interval_free_list);
6069 interval_free_list = &iblk->intervals[i]; 6297 interval_free_list = &iblk->intervals[i];
6070 this_free++; 6298 this_free++;
6071 } 6299 }
@@ -6116,7 +6344,7 @@ gc_sweep (void)
6116 /* Check if the symbol was created during loadup. In such a case 6344 /* Check if the symbol was created during loadup. In such a case
6117 it might be pointed to by pure bytecode which we don't trace, 6345 it might be pointed to by pure bytecode which we don't trace,
6118 so we conservatively assume that it is live. */ 6346 so we conservatively assume that it is live. */
6119 int pure_p = PURE_POINTER_P (XSTRING (sym->s.xname)); 6347 bool pure_p = PURE_POINTER_P (XSTRING (sym->s.name));
6120 6348
6121 if (!sym->s.gcmarkbit && !pure_p) 6349 if (!sym->s.gcmarkbit && !pure_p)
6122 { 6350 {
@@ -6133,7 +6361,7 @@ gc_sweep (void)
6133 { 6361 {
6134 ++num_used; 6362 ++num_used;
6135 if (!pure_p) 6363 if (!pure_p)
6136 UNMARK_STRING (XSTRING (sym->s.xname)); 6364 UNMARK_STRING (XSTRING (sym->s.name));
6137 sym->s.gcmarkbit = 0; 6365 sym->s.gcmarkbit = 0;
6138 } 6366 }
6139 } 6367 }
@@ -6218,59 +6446,27 @@ gc_sweep (void)
6218 6446
6219 /* Free all unmarked buffers */ 6447 /* Free all unmarked buffers */
6220 { 6448 {
6221 register struct buffer *buffer = all_buffers, *prev = 0, *next; 6449 register struct buffer *buffer, **bprev = &all_buffers;
6222 6450
6223 while (buffer) 6451 total_buffers = 0;
6452 for (buffer = all_buffers; buffer; buffer = *bprev)
6224 if (!VECTOR_MARKED_P (buffer)) 6453 if (!VECTOR_MARKED_P (buffer))
6225 { 6454 {
6226 if (prev) 6455 *bprev = buffer->next;
6227 prev->header.next = buffer->header.next;
6228 else
6229 all_buffers = buffer->header.next.buffer;
6230 next = buffer->header.next.buffer;
6231 lisp_free (buffer); 6456 lisp_free (buffer);
6232 buffer = next;
6233 } 6457 }
6234 else 6458 else
6235 { 6459 {
6236 VECTOR_UNMARK (buffer); 6460 VECTOR_UNMARK (buffer);
6237 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer)); 6461 /* Do not use buffer_(set|get)_intervals here. */
6238 prev = buffer, buffer = buffer->header.next.buffer; 6462 buffer->text->intervals = balance_intervals (buffer->text->intervals);
6463 total_buffers++;
6464 bprev = &buffer->next;
6239 } 6465 }
6240 } 6466 }
6241 6467
6242 /* Free all unmarked vectors */ 6468 sweep_vectors ();
6243 { 6469 check_string_bytes (!noninteractive);
6244 register struct Lisp_Vector *vector = all_vectors, *prev = 0, *next;
6245 total_vector_size = 0;
6246
6247 while (vector)
6248 if (!VECTOR_MARKED_P (vector))
6249 {
6250 if (prev)
6251 prev->header.next = vector->header.next;
6252 else
6253 all_vectors = vector->header.next.vector;
6254 next = vector->header.next.vector;
6255 lisp_free (vector);
6256 vector = next;
6257
6258 }
6259 else
6260 {
6261 VECTOR_UNMARK (vector);
6262 if (vector->header.size & PSEUDOVECTOR_FLAG)
6263 total_vector_size += PSEUDOVECTOR_SIZE_MASK & vector->header.size;
6264 else
6265 total_vector_size += vector->header.size;
6266 prev = vector, vector = vector->header.next.vector;
6267 }
6268 }
6269
6270#ifdef GC_CHECK_STRING_BYTES
6271 if (!noninteractive)
6272 check_string_bytes (1);
6273#endif
6274} 6470}
6275 6471
6276 6472
@@ -6306,18 +6502,15 @@ Frames, windows, buffers, and subprocesses count as vectors
6306 (but the contents of a buffer's text do not count here). */) 6502 (but the contents of a buffer's text do not count here). */)
6307 (void) 6503 (void)
6308{ 6504{
6309 Lisp_Object consed[8]; 6505 return listn (CONSTYPE_HEAP, 8,
6310 6506 bounded_number (cons_cells_consed),
6311 consed[0] = make_number (min (MOST_POSITIVE_FIXNUM, cons_cells_consed)); 6507 bounded_number (floats_consed),
6312 consed[1] = make_number (min (MOST_POSITIVE_FIXNUM, floats_consed)); 6508 bounded_number (vector_cells_consed),
6313 consed[2] = make_number (min (MOST_POSITIVE_FIXNUM, vector_cells_consed)); 6509 bounded_number (symbols_consed),
6314 consed[3] = make_number (min (MOST_POSITIVE_FIXNUM, symbols_consed)); 6510 bounded_number (string_chars_consed),
6315 consed[4] = make_number (min (MOST_POSITIVE_FIXNUM, string_chars_consed)); 6511 bounded_number (misc_objects_consed),
6316 consed[5] = make_number (min (MOST_POSITIVE_FIXNUM, misc_objects_consed)); 6512 bounded_number (intervals_consed),
6317 consed[6] = make_number (min (MOST_POSITIVE_FIXNUM, intervals_consed)); 6513 bounded_number (strings_consed));
6318 consed[7] = make_number (min (MOST_POSITIVE_FIXNUM, strings_consed));
6319
6320 return Flist (8, consed);
6321} 6514}
6322 6515
6323/* Find at most FIND_MAX symbols which have OBJ as their value or 6516/* Find at most FIND_MAX symbols which have OBJ as their value or
@@ -6371,18 +6564,19 @@ which_symbols (Lisp_Object obj, EMACS_INT find_max)
6371} 6564}
6372 6565
6373#ifdef ENABLE_CHECKING 6566#ifdef ENABLE_CHECKING
6374int suppress_checking; 6567
6568bool suppress_checking;
6375 6569
6376void 6570void
6377die (const char *msg, const char *file, int line) 6571die (const char *msg, const char *file, int line)
6378{ 6572{
6379 fprintf (stderr, "\r\n%s:%d: Emacs fatal error: %s\r\n", 6573 fprintf (stderr, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
6380 file, line, msg); 6574 file, line, msg);
6381 abort (); 6575 terminate_due_to_signal (SIGABRT, INT_MAX);
6382} 6576}
6383#endif 6577#endif
6384 6578
6385/* Initialization */ 6579/* Initialization. */
6386 6580
6387void 6581void
6388init_alloc_once (void) 6582init_alloc_once (void)
@@ -6390,48 +6584,22 @@ init_alloc_once (void)
6390 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */ 6584 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6391 purebeg = PUREBEG; 6585 purebeg = PUREBEG;
6392 pure_size = PURESIZE; 6586 pure_size = PURESIZE;
6393 pure_bytes_used = 0;
6394 pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
6395 pure_bytes_used_before_overflow = 0;
6396
6397 /* Initialize the list of free aligned blocks. */
6398 free_ablock = NULL;
6399 6587
6400#if GC_MARK_STACK || defined GC_MALLOC_CHECK 6588#if GC_MARK_STACK || defined GC_MALLOC_CHECK
6401 mem_init (); 6589 mem_init ();
6402 Vdead = make_pure_string ("DEAD", 4, 4, 0); 6590 Vdead = make_pure_string ("DEAD", 4, 4, 0);
6403#endif 6591#endif
6404 6592
6405 all_vectors = 0;
6406 ignore_warnings = 1;
6407#ifdef DOUG_LEA_MALLOC 6593#ifdef DOUG_LEA_MALLOC
6408 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */ 6594 mallopt (M_TRIM_THRESHOLD, 128 * 1024); /* Trim threshold. */
6409 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */ 6595 mallopt (M_MMAP_THRESHOLD, 64 * 1024); /* Mmap threshold. */
6410 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* max. number of mmap'ed areas */ 6596 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* Max. number of mmap'ed areas. */
6411#endif 6597#endif
6412 init_strings (); 6598 init_strings ();
6413 init_cons (); 6599 init_vectors ();
6414 init_symbol ();
6415 init_marker ();
6416 init_float ();
6417 init_intervals ();
6418 init_weak_hash_tables ();
6419
6420#ifdef REL_ALLOC
6421 malloc_hysteresis = 32;
6422#else
6423 malloc_hysteresis = 0;
6424#endif
6425 6600
6426 refill_memory_reserve (); 6601 refill_memory_reserve ();
6427 6602 gc_cons_threshold = GC_DEFAULT_THRESHOLD;
6428 ignore_warnings = 0;
6429 gcprolist = 0;
6430 byte_stack_list = 0;
6431 staticidx = 0;
6432 consing_since_gc = 0;
6433 gc_cons_threshold = 100000 * sizeof (Lisp_Object);
6434 gc_relative_threshold = 0;
6435} 6603}
6436 6604
6437void 6605void
@@ -6518,13 +6686,26 @@ do hash-consing of the objects allocated to pure space. */);
6518 /* We build this in advance because if we wait until we need it, we might 6686 /* We build this in advance because if we wait until we need it, we might
6519 not be able to allocate the memory to hold it. */ 6687 not be able to allocate the memory to hold it. */
6520 Vmemory_signal_data 6688 Vmemory_signal_data
6521 = pure_cons (Qerror, 6689 = listn (CONSTYPE_PURE, 2, Qerror,
6522 pure_cons (make_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil)); 6690 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6523 6691
6524 DEFVAR_LISP ("memory-full", Vmemory_full, 6692 DEFVAR_LISP ("memory-full", Vmemory_full,
6525 doc: /* Non-nil means Emacs cannot get much more Lisp memory. */); 6693 doc: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6526 Vmemory_full = Qnil; 6694 Vmemory_full = Qnil;
6527 6695
6696 DEFSYM (Qconses, "conses");
6697 DEFSYM (Qsymbols, "symbols");
6698 DEFSYM (Qmiscs, "miscs");
6699 DEFSYM (Qstrings, "strings");
6700 DEFSYM (Qvectors, "vectors");
6701 DEFSYM (Qfloats, "floats");
6702 DEFSYM (Qintervals, "intervals");
6703 DEFSYM (Qbuffers, "buffers");
6704 DEFSYM (Qstring_bytes, "string-bytes");
6705 DEFSYM (Qvector_slots, "vector-slots");
6706 DEFSYM (Qheap, "heap");
6707 DEFSYM (Qautomatic_gc, "Automatic GC");
6708
6528 DEFSYM (Qgc_cons_threshold, "gc-cons-threshold"); 6709 DEFSYM (Qgc_cons_threshold, "gc-cons-threshold");
6529 DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots"); 6710 DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots");
6530 6711
@@ -6553,3 +6734,26 @@ The time is in seconds as a floating point value. */);
6553 defsubr (&Sgc_status); 6734 defsubr (&Sgc_status);
6554#endif 6735#endif
6555} 6736}
6737
6738/* When compiled with GCC, GDB might say "No enum type named
6739 pvec_type" if we don't have at least one symbol with that type, and
6740 then xbacktrace could fail. Similarly for the other enums and
6741 their values. Some non-GCC compilers don't like these constructs. */
6742#ifdef __GNUC__
6743union
6744{
6745 enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS;
6746 enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS;
6747 enum char_bits char_bits;
6748 enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE;
6749 enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE;
6750 enum enum_USE_LSB_TAG enum_USE_LSB_TAG;
6751 enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE;
6752 enum Lisp_Bits Lisp_Bits;
6753 enum Lisp_Compiled Lisp_Compiled;
6754 enum maxargs maxargs;
6755 enum MAX_ALLOCA MAX_ALLOCA;
6756 enum More_Lisp_Bits More_Lisp_Bits;
6757 enum pvec_type pvec_type;
6758} const EXTERNALLY_VISIBLE gdb_make_enums_visible = {0};
6759#endif /* __GNUC__ */
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-14 19:01:27 +0000