aboutsummaryrefslogtreecommitdiffstats
path: root/src/alloc.c
diff options
context:
space:
mode:
authorStefan Monnier2022-09-25 16:15:16 -0400
committerStefan Monnier2022-09-25 16:15:16 -0400
commit650c20f1ca4e07591a727e1cfcc74b3363d15985 (patch)
tree85d11f6437cde22f410c25e0e5f71a3131ebd07d /src/alloc.c
parent8869332684c2302b5ba1ead4568bbc7ba1c0183e (diff)
parent4b85ae6a24380fb67a3315eaec9233f17a872473 (diff)
downloademacs-650c20f1ca4e07591a727e1cfcc74b3363d15985.tar.gz
emacs-650c20f1ca4e07591a727e1cfcc74b3363d15985.zip
Merge 'master' into noverlay
Diffstat (limited to 'src/alloc.c')
-rw-r--r--src/alloc.c4532
1 files changed, 2417 insertions, 2115 deletions
diff --git a/src/alloc.c b/src/alloc.c
index 9f72f914e00..20b8981bd66 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -1,7 +1,6 @@
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-2017 Free Software 3Copyright (C) 1985-2022 Free Software Foundation, Inc.
4Foundation, Inc.
5 4
6This file is part of GNU Emacs. 5This file is part of GNU Emacs.
7 6
@@ -21,7 +20,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
21#include <config.h> 20#include <config.h>
22 21
23#include <errno.h> 22#include <errno.h>
24#include <stdio.h> 23#include <stdint.h>
25#include <stdlib.h> 24#include <stdlib.h>
26#include <limits.h> /* For CHAR_BIT. */ 25#include <limits.h> /* For CHAR_BIT. */
27#include <signal.h> /* For SIGABRT, SIGDANGER. */ 26#include <signal.h> /* For SIGABRT, SIGDANGER. */
@@ -31,10 +30,12 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
31#endif 30#endif
32 31
33#include "lisp.h" 32#include "lisp.h"
33#include "bignum.h"
34#include "dispextern.h" 34#include "dispextern.h"
35#include "intervals.h" 35#include "intervals.h"
36#include "puresize.h" 36#include "puresize.h"
37#include "sheap.h" 37#include "sheap.h"
38#include "sysstdio.h"
38#include "systime.h" 39#include "systime.h"
39#include "character.h" 40#include "character.h"
40#include "buffer.h" 41#include "buffer.h"
@@ -42,6 +43,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
42#include "keyboard.h" 43#include "keyboard.h"
43#include "frame.h" 44#include "frame.h"
44#include "blockinput.h" 45#include "blockinput.h"
46#include "pdumper.h"
45#include "termhooks.h" /* For struct terminal. */ 47#include "termhooks.h" /* For struct terminal. */
46#include "itree.h" 48#include "itree.h"
47#ifdef HAVE_WINDOW_SYSTEM 49#ifdef HAVE_WINDOW_SYSTEM
@@ -64,16 +66,14 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
64# include <malloc.h> 66# include <malloc.h>
65#endif 67#endif
66 68
67#if (defined ENABLE_CHECKING \ 69#if (defined ENABLE_CHECKING \
68 && defined HAVE_VALGRIND_VALGRIND_H \ 70 && defined HAVE_VALGRIND_VALGRIND_H && !defined USE_VALGRIND)
69 && !defined USE_VALGRIND)
70# define USE_VALGRIND 1 71# define USE_VALGRIND 1
71#endif 72#endif
72 73
73#if USE_VALGRIND 74#if USE_VALGRIND
74#include <valgrind/valgrind.h> 75#include <valgrind/valgrind.h>
75#include <valgrind/memcheck.h> 76#include <valgrind/memcheck.h>
76static bool valgrind_p;
77#endif 77#endif
78 78
79/* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects. 79/* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
@@ -104,16 +104,65 @@ static bool valgrind_p;
104#include "w32heap.h" /* for sbrk */ 104#include "w32heap.h" /* for sbrk */
105#endif 105#endif
106 106
107#ifdef GNU_LINUX 107/* A type with alignment at least as large as any object that Emacs
108/* The address where the heap starts. */ 108 allocates. This is not max_align_t because some platforms (e.g.,
109void * 109 mingw) have buggy malloc implementations that do not align for
110my_heap_start (void) 110 max_align_t. This union contains types of all GCALIGNED_STRUCT
111{ 111 components visible here. */
112 static void *start; 112union emacs_align_type
113 if (! start) 113{
114 start = sbrk (0); 114 struct frame frame;
115 return start; 115 struct Lisp_Bignum Lisp_Bignum;
116} 116 struct Lisp_Bool_Vector Lisp_Bool_Vector;
117 struct Lisp_Char_Table Lisp_Char_Table;
118 struct Lisp_CondVar Lisp_CondVar;
119 struct Lisp_Finalizer Lisp_Finalizer;
120 struct Lisp_Float Lisp_Float;
121 struct Lisp_Hash_Table Lisp_Hash_Table;
122 struct Lisp_Marker Lisp_Marker;
123 struct Lisp_Misc_Ptr Lisp_Misc_Ptr;
124 struct Lisp_Mutex Lisp_Mutex;
125 struct Lisp_Overlay Lisp_Overlay;
126 struct Lisp_Sub_Char_Table Lisp_Sub_Char_Table;
127 struct Lisp_Subr Lisp_Subr;
128 struct Lisp_Sqlite Lisp_Sqlite;
129 struct Lisp_User_Ptr Lisp_User_Ptr;
130 struct Lisp_Vector Lisp_Vector;
131 struct terminal terminal;
132 struct thread_state thread_state;
133 struct window window;
134
135 /* Omit the following since they would require including process.h
136 etc. In practice their alignments never exceed that of the
137 structs already listed. */
138#if 0
139 struct Lisp_Module_Function Lisp_Module_Function;
140 struct Lisp_Process Lisp_Process;
141 struct save_window_data save_window_data;
142 struct scroll_bar scroll_bar;
143 struct xwidget_view xwidget_view;
144 struct xwidget xwidget;
145#endif
146};
147
148/* MALLOC_SIZE_NEAR (N) is a good number to pass to malloc when
149 allocating a block of memory with size close to N bytes.
150 For best results N should be a power of 2.
151
152 When calculating how much memory to allocate, GNU malloc (SIZE)
153 adds sizeof (size_t) to SIZE for internal overhead, and then rounds
154 up to a multiple of MALLOC_ALIGNMENT. Emacs can improve
155 performance a bit on GNU platforms by arranging for the resulting
156 size to be a power of two. This heuristic is good for glibc 2.26
157 (2017) and later, and does not affect correctness on other
158 platforms. */
159
160#define MALLOC_SIZE_NEAR(n) \
161 (ROUNDUP (max (n, sizeof (size_t)), MALLOC_ALIGNMENT) - sizeof (size_t))
162#ifdef __i386
163enum { MALLOC_ALIGNMENT = 16 };
164#else
165enum { MALLOC_ALIGNMENT = max (2 * sizeof (size_t), alignof (long double)) };
117#endif 166#endif
118 167
119#ifdef DOUG_LEA_MALLOC 168#ifdef DOUG_LEA_MALLOC
@@ -121,7 +170,7 @@ my_heap_start (void)
121/* Specify maximum number of areas to mmap. It would be nice to use a 170/* Specify maximum number of areas to mmap. It would be nice to use a
122 value that explicitly means "no limit". */ 171 value that explicitly means "no limit". */
123 172
124#define MMAP_MAX_AREAS 100000000 173# define MMAP_MAX_AREAS 100000000
125 174
126/* A pointer to the memory allocated that copies that static data 175/* A pointer to the memory allocated that copies that static data
127 inside glibc's malloc. */ 176 inside glibc's malloc. */
@@ -137,9 +186,9 @@ malloc_initialize_hook (void)
137 186
138 if (! initialized) 187 if (! initialized)
139 { 188 {
140#ifdef GNU_LINUX 189# ifdef GNU_LINUX
141 my_heap_start (); 190 my_heap_start ();
142#endif 191# endif
143 malloc_using_checking = getenv ("MALLOC_CHECK_") != NULL; 192 malloc_using_checking = getenv ("MALLOC_CHECK_") != NULL;
144 } 193 }
145 else 194 else
@@ -164,14 +213,13 @@ malloc_initialize_hook (void)
164 213
165 if (malloc_set_state (malloc_state_ptr) != 0) 214 if (malloc_set_state (malloc_state_ptr) != 0)
166 emacs_abort (); 215 emacs_abort ();
167# ifndef XMALLOC_OVERRUN_CHECK
168 alloc_unexec_post (); 216 alloc_unexec_post ();
169# endif
170 } 217 }
171} 218}
172 219
173/* Declare the malloc initialization hook, which runs before 'main' starts. 220/* Declare the malloc initialization hook, which runs before 'main' starts.
174 EXTERNALLY_VISIBLE works around Bug#22522. */ 221 EXTERNALLY_VISIBLE works around Bug#22522. */
222typedef void (*voidfuncptr) (void);
175# ifndef __MALLOC_HOOK_VOLATILE 223# ifndef __MALLOC_HOOK_VOLATILE
176# define __MALLOC_HOOK_VOLATILE 224# define __MALLOC_HOOK_VOLATILE
177# endif 225# endif
@@ -180,7 +228,7 @@ voidfuncptr __MALLOC_HOOK_VOLATILE __malloc_initialize_hook EXTERNALLY_VISIBLE
180 228
181#endif 229#endif
182 230
183#if defined DOUG_LEA_MALLOC || !defined CANNOT_DUMP 231#if defined DOUG_LEA_MALLOC || defined HAVE_UNEXEC
184 232
185/* Allocator-related actions to do just before and after unexec. */ 233/* Allocator-related actions to do just before and after unexec. */
186 234
@@ -192,9 +240,6 @@ alloc_unexec_pre (void)
192 if (!malloc_state_ptr) 240 if (!malloc_state_ptr)
193 fatal ("malloc_get_state: %s", strerror (errno)); 241 fatal ("malloc_get_state: %s", strerror (errno));
194# endif 242# endif
195# ifdef HYBRID_MALLOC
196 bss_sbrk_did_unexec = true;
197# endif
198} 243}
199 244
200void 245void
@@ -203,22 +248,33 @@ alloc_unexec_post (void)
203# ifdef DOUG_LEA_MALLOC 248# ifdef DOUG_LEA_MALLOC
204 free (malloc_state_ptr); 249 free (malloc_state_ptr);
205# endif 250# endif
206# ifdef HYBRID_MALLOC
207 bss_sbrk_did_unexec = false;
208# endif
209} 251}
252
253# ifdef GNU_LINUX
254
255/* The address where the heap starts. */
256void *
257my_heap_start (void)
258{
259 static void *start;
260 if (! start)
261 start = sbrk (0);
262 return start;
263}
264# endif
265
210#endif 266#endif
211 267
212/* Mark, unmark, query mark bit of a Lisp string. S must be a pointer 268/* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
213 to a struct Lisp_String. */ 269 to a struct Lisp_String. */
214 270
215#define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG) 271#define XMARK_STRING(S) ((S)->u.s.size |= ARRAY_MARK_FLAG)
216#define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG) 272#define XUNMARK_STRING(S) ((S)->u.s.size &= ~ARRAY_MARK_FLAG)
217#define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0) 273#define XSTRING_MARKED_P(S) (((S)->u.s.size & ARRAY_MARK_FLAG) != 0)
218 274
219#define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG) 275#define XMARK_VECTOR(V) ((V)->header.size |= ARRAY_MARK_FLAG)
220#define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG) 276#define XUNMARK_VECTOR(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
221#define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0) 277#define XVECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
222 278
223/* Default value of gc_cons_threshold (see below). */ 279/* Default value of gc_cons_threshold (see below). */
224 280
@@ -227,28 +283,45 @@ alloc_unexec_post (void)
227/* Global variables. */ 283/* Global variables. */
228struct emacs_globals globals; 284struct emacs_globals globals;
229 285
230/* Number of bytes of consing done since the last gc. */ 286/* maybe_gc collects garbage if this goes negative. */
231 287
232EMACS_INT consing_since_gc; 288EMACS_INT consing_until_gc;
233 289
234/* Similar minimum, computed from Vgc_cons_percentage. */ 290#ifdef HAVE_PDUMPER
291/* Number of finalizers run: used to loop over GC until we stop
292 generating garbage. */
293int number_finalizers_run;
294#endif
235 295
236EMACS_INT gc_relative_threshold; 296/* True during GC. */
237 297
238/* Minimum number of bytes of consing since GC before next GC, 298bool gc_in_progress;
239 when memory is full. */
240 299
241EMACS_INT memory_full_cons_threshold; 300/* System byte and object counts reported by GC. */
242 301
243/* True during GC. */ 302/* Assume byte counts fit in uintptr_t and object counts fit into
303 intptr_t. */
304typedef uintptr_t byte_ct;
305typedef intptr_t object_ct;
244 306
245bool gc_in_progress; 307/* Large-magnitude value for a threshold count, which fits in EMACS_INT.
308 Using only half the EMACS_INT range avoids overflow hassles.
309 There is no need to fit these counts into fixnums. */
310#define HI_THRESHOLD (EMACS_INT_MAX / 2)
246 311
247/* Number of live and free conses etc. */ 312/* Number of live and free conses etc. counted by the most-recent GC. */
248 313
249static EMACS_INT total_conses, total_markers, total_symbols, total_buffers; 314static struct gcstat
250static EMACS_INT total_free_conses, total_free_markers, total_free_symbols; 315{
251static EMACS_INT total_free_floats, total_floats; 316 object_ct total_conses, total_free_conses;
317 object_ct total_symbols, total_free_symbols;
318 object_ct total_strings, total_free_strings;
319 byte_ct total_string_bytes;
320 object_ct total_vectors, total_vector_slots, total_free_vector_slots;
321 object_ct total_floats, total_free_floats;
322 object_ct total_intervals, total_free_intervals;
323 object_ct total_buffers;
324} gcstat;
252 325
253/* Points to memory space allocated as "spare", to be freed if we run 326/* Points to memory space allocated as "spare", to be freed if we run
254 out of memory. We keep one large block, four cons-blocks, and 327 out of memory. We keep one large block, four cons-blocks, and
@@ -288,20 +361,24 @@ static ptrdiff_t pure_bytes_used_lisp;
288 361
289static ptrdiff_t pure_bytes_used_non_lisp; 362static ptrdiff_t pure_bytes_used_non_lisp;
290 363
364/* If positive, garbage collection is inhibited. Otherwise, zero. */
365
366static intptr_t garbage_collection_inhibited;
367
368/* The GC threshold in bytes, the last time it was calculated
369 from gc-cons-threshold and gc-cons-percentage. */
370static EMACS_INT gc_threshold;
371
291/* If nonzero, this is a warning delivered by malloc and not yet 372/* If nonzero, this is a warning delivered by malloc and not yet
292 displayed. */ 373 displayed. */
293 374
294const char *pending_malloc_warning; 375const char *pending_malloc_warning;
295 376
296#if 0 /* Normally, pointer sanity only on request... */ 377/* Pointer sanity only on request. FIXME: Code depending on
378 SUSPICIOUS_OBJECT_CHECKING is obsolete; remove it entirely. */
297#ifdef ENABLE_CHECKING 379#ifdef ENABLE_CHECKING
298#define SUSPICIOUS_OBJECT_CHECKING 1 380#define SUSPICIOUS_OBJECT_CHECKING 1
299#endif 381#endif
300#endif
301
302/* ... but unconditionally use SUSPICIOUS_OBJECT_CHECKING while the GC
303 bug is unresolved. */
304#define SUSPICIOUS_OBJECT_CHECKING 1
305 382
306#ifdef SUSPICIOUS_OBJECT_CHECKING 383#ifdef SUSPICIOUS_OBJECT_CHECKING
307struct suspicious_free_record 384struct suspicious_free_record
@@ -318,8 +395,8 @@ static int suspicious_free_history_index;
318static void *find_suspicious_object_in_range (void *begin, void *end); 395static void *find_suspicious_object_in_range (void *begin, void *end);
319static void detect_suspicious_free (void *ptr); 396static void detect_suspicious_free (void *ptr);
320#else 397#else
321# define find_suspicious_object_in_range(begin, end) NULL 398# define find_suspicious_object_in_range(begin, end) ((void *) NULL)
322# define detect_suspicious_free(ptr) (void) 399# define detect_suspicious_free(ptr) ((void) 0)
323#endif 400#endif
324 401
325/* Maximum amount of C stack to save when a GC happens. */ 402/* Maximum amount of C stack to save when a GC happens. */
@@ -355,6 +432,7 @@ no_sanitize_memcpy (void *dest, void const *src, size_t size)
355 432
356#endif /* MAX_SAVE_STACK > 0 */ 433#endif /* MAX_SAVE_STACK > 0 */
357 434
435static void unchain_finalizer (struct Lisp_Finalizer *);
358static void mark_terminals (void); 436static void mark_terminals (void);
359static void gc_sweep (void); 437static void gc_sweep (void);
360static Lisp_Object make_pure_vector (ptrdiff_t); 438static Lisp_Object make_pure_vector (ptrdiff_t);
@@ -367,6 +445,12 @@ static void compact_small_strings (void);
367static void free_large_strings (void); 445static void free_large_strings (void);
368extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE; 446extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
369 447
448static bool vector_marked_p (struct Lisp_Vector const *);
449static bool vectorlike_marked_p (union vectorlike_header const *);
450static void set_vectorlike_marked (union vectorlike_header *);
451static bool interval_marked_p (INTERVAL);
452static void set_interval_marked (INTERVAL);
453
370/* When scanning the C stack for live Lisp objects, Emacs keeps track of 454/* When scanning the C stack for live Lisp objects, Emacs keeps track of
371 what memory allocated via lisp_malloc and lisp_align_malloc is intended 455 what memory allocated via lisp_malloc and lisp_align_malloc is intended
372 for what purpose. This enumeration specifies the type of memory. */ 456 for what purpose. This enumeration specifies the type of memory. */
@@ -374,10 +458,8 @@ extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
374enum mem_type 458enum mem_type
375{ 459{
376 MEM_TYPE_NON_LISP, 460 MEM_TYPE_NON_LISP,
377 MEM_TYPE_BUFFER,
378 MEM_TYPE_CONS, 461 MEM_TYPE_CONS,
379 MEM_TYPE_STRING, 462 MEM_TYPE_STRING,
380 MEM_TYPE_MISC,
381 MEM_TYPE_SYMBOL, 463 MEM_TYPE_SYMBOL,
382 MEM_TYPE_FLOAT, 464 MEM_TYPE_FLOAT,
383 /* Since all non-bool pseudovectors are small enough to be 465 /* Since all non-bool pseudovectors are small enough to be
@@ -390,11 +472,11 @@ enum mem_type
390 MEM_TYPE_SPARE 472 MEM_TYPE_SPARE
391}; 473};
392 474
393/* A unique object in pure space used to make some Lisp objects 475static bool
394 on free lists recognizable in O(1). */ 476deadp (Lisp_Object x)
395 477{
396static Lisp_Object Vdead; 478 return BASE_EQ (x, dead_object ());
397#define DEADP(x) EQ (x, Vdead) 479}
398 480
399#ifdef GC_MALLOC_CHECK 481#ifdef GC_MALLOC_CHECK
400 482
@@ -466,35 +548,22 @@ static void mem_delete (struct mem_node *);
466static void mem_delete_fixup (struct mem_node *); 548static void mem_delete_fixup (struct mem_node *);
467static struct mem_node *mem_find (void *); 549static struct mem_node *mem_find (void *);
468 550
469#ifndef DEADP
470# define DEADP(x) 0
471#endif
472
473/* Addresses of staticpro'd variables. Initialize it to a nonzero 551/* Addresses of staticpro'd variables. Initialize it to a nonzero
474 value; otherwise some compilers put it into BSS. */ 552 value if we might unexec; otherwise some compilers put it into
553 BSS. */
475 554
476enum { NSTATICS = 2048 }; 555Lisp_Object const *staticvec[NSTATICS]
477static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag}; 556#ifdef HAVE_UNEXEC
557= {&Vpurify_flag}
558#endif
559 ;
478 560
479/* Index of next unused slot in staticvec. */ 561/* Index of next unused slot in staticvec. */
480 562
481static int staticidx; 563int staticidx;
482 564
483static void *pure_alloc (size_t, int); 565static void *pure_alloc (size_t, int);
484 566
485/* True if N is a power of 2. N should be positive. */
486
487#define POWER_OF_2(n) (((n) & ((n) - 1)) == 0)
488
489/* Return X rounded to the next multiple of Y. Y should be positive,
490 and Y - 1 + X should not overflow. Arguments should not have side
491 effects, as they are evaluated more than once. Tune for Y being a
492 power of 2. */
493
494#define ROUNDUP(x, y) (POWER_OF_2 (y) \
495 ? ((y) - 1 + (x)) & ~ ((y) - 1) \
496 : ((y) - 1 + (x)) - ((y) - 1 + (x)) % (y))
497
498/* Return PTR rounded up to the next multiple of ALIGNMENT. */ 567/* Return PTR rounded up to the next multiple of ALIGNMENT. */
499 568
500static void * 569static void *
@@ -503,47 +572,31 @@ pointer_align (void *ptr, int alignment)
503 return (void *) ROUNDUP ((uintptr_t) ptr, alignment); 572 return (void *) ROUNDUP ((uintptr_t) ptr, alignment);
504} 573}
505 574
506/* Extract the pointer hidden within A, if A is not a symbol. 575/* Extract the pointer hidden within O. */
507 If A is a symbol, extract the hidden pointer's offset from lispsym,
508 converted to void *. */
509
510#define macro_XPNTR_OR_SYMBOL_OFFSET(a) \
511 ((void *) (intptr_t) (USE_LSB_TAG ? XLI (a) - XTYPE (a) : XLI (a) & VALMASK))
512
513/* Extract the pointer hidden within A. */
514 576
515#define macro_XPNTR(a) \ 577static ATTRIBUTE_NO_SANITIZE_UNDEFINED void *
516 ((void *) ((intptr_t) XPNTR_OR_SYMBOL_OFFSET (a) \
517 + (SYMBOLP (a) ? (char *) lispsym : NULL)))
518
519/* For pointer access, define XPNTR and XPNTR_OR_SYMBOL_OFFSET as
520 functions, as functions are cleaner and can be used in debuggers.
521 Also, define them as macros if being compiled with GCC without
522 optimization, for performance in that case. The macro_* names are
523 private to this section of code. */
524
525static ATTRIBUTE_UNUSED void *
526XPNTR_OR_SYMBOL_OFFSET (Lisp_Object a)
527{
528 return macro_XPNTR_OR_SYMBOL_OFFSET (a);
529}
530static ATTRIBUTE_UNUSED void *
531XPNTR (Lisp_Object a) 578XPNTR (Lisp_Object a)
532{ 579{
533 return macro_XPNTR (a); 580 return (BARE_SYMBOL_P (a)
581 ? (char *) lispsym + (XLI (a) - LISP_WORD_TAG (Lisp_Symbol))
582 : (char *) XLP (a) - (XLI (a) & ~VALMASK));
534} 583}
535 584
536#if DEFINE_KEY_OPS_AS_MACROS
537# define XPNTR_OR_SYMBOL_OFFSET(a) macro_XPNTR_OR_SYMBOL_OFFSET (a)
538# define XPNTR(a) macro_XPNTR (a)
539#endif
540
541static void 585static void
542XFLOAT_INIT (Lisp_Object f, double n) 586XFLOAT_INIT (Lisp_Object f, double n)
543{ 587{
544 XFLOAT (f)->u.data = n; 588 XFLOAT (f)->u.data = n;
545} 589}
546 590
591/* Account for allocation of NBYTES in the heap. This is a separate
592 function to avoid hassles with implementation-defined conversion
593 from unsigned to signed types. */
594static void
595tally_consing (ptrdiff_t nbytes)
596{
597 consing_until_gc -= nbytes;
598}
599
547#ifdef DOUG_LEA_MALLOC 600#ifdef DOUG_LEA_MALLOC
548static bool 601static bool
549pointers_fit_in_lispobj_p (void) 602pointers_fit_in_lispobj_p (void)
@@ -559,18 +612,18 @@ mmap_lisp_allowed_p (void)
559 over our address space. We also can't use mmap for lisp objects 612 over our address space. We also can't use mmap for lisp objects
560 if we might dump: unexec doesn't preserve the contents of mmapped 613 if we might dump: unexec doesn't preserve the contents of mmapped
561 regions. */ 614 regions. */
562 return pointers_fit_in_lispobj_p () && !might_dump; 615 return pointers_fit_in_lispobj_p () && !will_dump_with_unexec_p ();
563} 616}
564#endif 617#endif
565 618
566/* Head of a circularly-linked list of extant finalizers. */ 619/* Head of a circularly-linked list of extant finalizers. */
567static struct Lisp_Finalizer finalizers; 620struct Lisp_Finalizer finalizers;
568 621
569/* Head of a circularly-linked list of finalizers that must be invoked 622/* Head of a circularly-linked list of finalizers that must be invoked
570 because we deemed them unreachable. This list must be global, and 623 because we deemed them unreachable. This list must be global, and
571 not a local inside garbage_collect_1, in case we GC again while 624 not a local inside garbage_collect, in case we GC again while
572 running finalizers. */ 625 running finalizers. */
573static struct Lisp_Finalizer doomed_finalizers; 626struct Lisp_Finalizer doomed_finalizers;
574 627
575 628
576/************************************************************************ 629/************************************************************************
@@ -597,7 +650,7 @@ display_malloc_warning (void)
597 call3 (intern ("display-warning"), 650 call3 (intern ("display-warning"),
598 intern ("alloc"), 651 intern ("alloc"),
599 build_string (pending_malloc_warning), 652 build_string (pending_malloc_warning),
600 intern ("emergency")); 653 intern (":emergency"));
601 pending_malloc_warning = 0; 654 pending_malloc_warning = 0;
602} 655}
603 656
@@ -628,175 +681,22 @@ buffer_memory_full (ptrdiff_t nbytes)
628#define COMMON_MULTIPLE(a, b) \ 681#define COMMON_MULTIPLE(a, b) \
629 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b)) 682 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
630 683
631#ifndef XMALLOC_OVERRUN_CHECK 684/* Alignment needed for memory blocks that are allocated via malloc
632#define XMALLOC_OVERRUN_CHECK_OVERHEAD 0 685 and that contain Lisp objects. On typical hosts malloc already
633#else 686 aligns sufficiently, but extra work is needed on oddball hosts
634 687 where Emacs would crash if malloc returned a non-GCALIGNED pointer. */
635/* Check for overrun in malloc'ed buffers by wrapping a header and trailer 688enum { LISP_ALIGNMENT = alignof (union { union emacs_align_type x;
636 around each block. 689 GCALIGNED_UNION_MEMBER }) };
637 690verify (LISP_ALIGNMENT % GCALIGNMENT == 0);
638 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes 691
639 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original 692/* True if malloc (N) is known to return storage suitably aligned for
640 block size in little-endian order. The trailer consists of 693 Lisp objects whenever N is a multiple of LISP_ALIGNMENT. In
641 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes. 694 practice this is true whenever alignof (max_align_t) is also a
642 695 multiple of LISP_ALIGNMENT. This works even for buggy platforms
643 The header is used to detect whether this block has been allocated 696 like MinGW circa 2020, where alignof (max_align_t) is 16 even though
644 through these functions, as some low-level libc functions may 697 the malloc alignment is only 8, and where Emacs still works because
645 bypass the malloc hooks. */ 698 it never does anything that requires an alignment of 16. */
646 699enum { MALLOC_IS_LISP_ALIGNED = alignof (max_align_t) % LISP_ALIGNMENT == 0 };
647#define XMALLOC_OVERRUN_CHECK_SIZE 16
648#define XMALLOC_OVERRUN_CHECK_OVERHEAD \
649 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
650
651#define XMALLOC_BASE_ALIGNMENT alignof (max_align_t)
652
653#define XMALLOC_HEADER_ALIGNMENT \
654 COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
655
656/* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
657 hold a size_t value and (2) the header size is a multiple of the
658 alignment that Emacs needs for C types and for USE_LSB_TAG. */
659#define XMALLOC_OVERRUN_SIZE_SIZE \
660 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
661 + XMALLOC_HEADER_ALIGNMENT - 1) \
662 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
663 - XMALLOC_OVERRUN_CHECK_SIZE)
664
665static char const xmalloc_overrun_check_header[XMALLOC_OVERRUN_CHECK_SIZE] =
666 { '\x9a', '\x9b', '\xae', '\xaf',
667 '\xbf', '\xbe', '\xce', '\xcf',
668 '\xea', '\xeb', '\xec', '\xed',
669 '\xdf', '\xde', '\x9c', '\x9d' };
670
671static char const xmalloc_overrun_check_trailer[XMALLOC_OVERRUN_CHECK_SIZE] =
672 { '\xaa', '\xab', '\xac', '\xad',
673 '\xba', '\xbb', '\xbc', '\xbd',
674 '\xca', '\xcb', '\xcc', '\xcd',
675 '\xda', '\xdb', '\xdc', '\xdd' };
676
677/* Insert and extract the block size in the header. */
678
679static void
680xmalloc_put_size (unsigned char *ptr, size_t size)
681{
682 int i;
683 for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
684 {
685 *--ptr = size & ((1 << CHAR_BIT) - 1);
686 size >>= CHAR_BIT;
687 }
688}
689
690static size_t
691xmalloc_get_size (unsigned char *ptr)
692{
693 size_t size = 0;
694 int i;
695 ptr -= XMALLOC_OVERRUN_SIZE_SIZE;
696 for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
697 {
698 size <<= CHAR_BIT;
699 size += *ptr++;
700 }
701 return size;
702}
703
704
705/* Like malloc, but wraps allocated block with header and trailer. */
706
707static void *
708overrun_check_malloc (size_t size)
709{
710 register unsigned char *val;
711 if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
712 emacs_abort ();
713
714 val = malloc (size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
715 if (val)
716 {
717 memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
718 val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
719 xmalloc_put_size (val, size);
720 memcpy (val + size, xmalloc_overrun_check_trailer,
721 XMALLOC_OVERRUN_CHECK_SIZE);
722 }
723 return val;
724}
725
726
727/* Like realloc, but checks old block for overrun, and wraps new block
728 with header and trailer. */
729
730static void *
731overrun_check_realloc (void *block, size_t size)
732{
733 register unsigned char *val = (unsigned char *) block;
734 if (SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD < size)
735 emacs_abort ();
736
737 if (val
738 && memcmp (xmalloc_overrun_check_header,
739 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
740 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
741 {
742 size_t osize = xmalloc_get_size (val);
743 if (memcmp (xmalloc_overrun_check_trailer, val + osize,
744 XMALLOC_OVERRUN_CHECK_SIZE))
745 emacs_abort ();
746 memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
747 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
748 memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
749 }
750
751 val = realloc (val, size + XMALLOC_OVERRUN_CHECK_OVERHEAD);
752
753 if (val)
754 {
755 memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
756 val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
757 xmalloc_put_size (val, size);
758 memcpy (val + size, xmalloc_overrun_check_trailer,
759 XMALLOC_OVERRUN_CHECK_SIZE);
760 }
761 return val;
762}
763
764/* Like free, but checks block for overrun. */
765
766static void
767overrun_check_free (void *block)
768{
769 unsigned char *val = (unsigned char *) block;
770
771 if (val
772 && memcmp (xmalloc_overrun_check_header,
773 val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
774 XMALLOC_OVERRUN_CHECK_SIZE) == 0)
775 {
776 size_t osize = xmalloc_get_size (val);
777 if (memcmp (xmalloc_overrun_check_trailer, val + osize,
778 XMALLOC_OVERRUN_CHECK_SIZE))
779 emacs_abort ();
780#ifdef XMALLOC_CLEAR_FREE_MEMORY
781 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
782 memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_OVERHEAD);
783#else
784 memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
785 val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
786 memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
787#endif
788 }
789
790 free (val);
791}
792
793#undef malloc
794#undef realloc
795#undef free
796#define malloc overrun_check_malloc
797#define realloc overrun_check_realloc
798#define free overrun_check_free
799#endif
800 700
801/* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol 701/* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
802 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger. 702 BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
@@ -818,7 +718,11 @@ static void
818malloc_unblock_input (void) 718malloc_unblock_input (void)
819{ 719{
820 if (block_input_in_memory_allocators) 720 if (block_input_in_memory_allocators)
821 unblock_input (); 721 {
722 int err = errno;
723 unblock_input ();
724 errno = err;
725 }
822} 726}
823# define MALLOC_BLOCK_INPUT malloc_block_input () 727# define MALLOC_BLOCK_INPUT malloc_block_input ()
824# define MALLOC_UNBLOCK_INPUT malloc_unblock_input () 728# define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
@@ -833,7 +737,7 @@ malloc_unblock_input (void)
833 malloc_probe (size); \ 737 malloc_probe (size); \
834 } while (0) 738 } while (0)
835 739
836static void *lmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); 740static void *lmalloc (size_t, bool) ATTRIBUTE_MALLOC_SIZE ((1));
837static void *lrealloc (void *, size_t); 741static void *lrealloc (void *, size_t);
838 742
839/* Like malloc but check for no memory and block interrupt input. */ 743/* Like malloc but check for no memory and block interrupt input. */
@@ -844,10 +748,10 @@ xmalloc (size_t size)
844 void *val; 748 void *val;
845 749
846 MALLOC_BLOCK_INPUT; 750 MALLOC_BLOCK_INPUT;
847 val = lmalloc (size); 751 val = lmalloc (size, false);
848 MALLOC_UNBLOCK_INPUT; 752 MALLOC_UNBLOCK_INPUT;
849 753
850 if (!val && size) 754 if (!val)
851 memory_full (size); 755 memory_full (size);
852 MALLOC_PROBE (size); 756 MALLOC_PROBE (size);
853 return val; 757 return val;
@@ -861,17 +765,16 @@ xzalloc (size_t size)
861 void *val; 765 void *val;
862 766
863 MALLOC_BLOCK_INPUT; 767 MALLOC_BLOCK_INPUT;
864 val = lmalloc (size); 768 val = lmalloc (size, true);
865 MALLOC_UNBLOCK_INPUT; 769 MALLOC_UNBLOCK_INPUT;
866 770
867 if (!val && size) 771 if (!val)
868 memory_full (size); 772 memory_full (size);
869 memset (val, 0, size);
870 MALLOC_PROBE (size); 773 MALLOC_PROBE (size);
871 return val; 774 return val;
872} 775}
873 776
874/* Like realloc but check for no memory and block interrupt input.. */ 777/* Like realloc but check for no memory and block interrupt input. */
875 778
876void * 779void *
877xrealloc (void *block, size_t size) 780xrealloc (void *block, size_t size)
@@ -879,15 +782,15 @@ xrealloc (void *block, size_t size)
879 void *val; 782 void *val;
880 783
881 MALLOC_BLOCK_INPUT; 784 MALLOC_BLOCK_INPUT;
882 /* We must call malloc explicitly when BLOCK is 0, since some 785 /* Call lmalloc when BLOCK is null, for the benefit of long-obsolete
883 reallocs don't do this. */ 786 platforms lacking support for realloc (NULL, size). */
884 if (! block) 787 if (! block)
885 val = lmalloc (size); 788 val = lmalloc (size, false);
886 else 789 else
887 val = lrealloc (block, size); 790 val = lrealloc (block, size);
888 MALLOC_UNBLOCK_INPUT; 791 MALLOC_UNBLOCK_INPUT;
889 792
890 if (!val && size) 793 if (!val)
891 memory_full (size); 794 memory_full (size);
892 MALLOC_PROBE (size); 795 MALLOC_PROBE (size);
893 return val; 796 return val;
@@ -901,6 +804,8 @@ xfree (void *block)
901{ 804{
902 if (!block) 805 if (!block)
903 return; 806 return;
807 if (pdumper_object_p (block))
808 return;
904 MALLOC_BLOCK_INPUT; 809 MALLOC_BLOCK_INPUT;
905 free (block); 810 free (block);
906 MALLOC_UNBLOCK_INPUT; 811 MALLOC_UNBLOCK_INPUT;
@@ -1076,7 +981,7 @@ void *lisp_malloc_loser EXTERNALLY_VISIBLE;
1076#endif 981#endif
1077 982
1078static void * 983static void *
1079lisp_malloc (size_t nbytes, enum mem_type type) 984lisp_malloc (size_t nbytes, bool clearit, enum mem_type type)
1080{ 985{
1081 register void *val; 986 register void *val;
1082 987
@@ -1086,7 +991,7 @@ lisp_malloc (size_t nbytes, enum mem_type type)
1086 allocated_mem_type = type; 991 allocated_mem_type = type;
1087#endif 992#endif
1088 993
1089 val = lmalloc (nbytes); 994 val = lmalloc (nbytes, clearit);
1090 995
1091#if ! USE_LSB_TAG 996#if ! USE_LSB_TAG
1092 /* If the memory just allocated cannot be addressed thru a Lisp 997 /* If the memory just allocated cannot be addressed thru a Lisp
@@ -1111,7 +1016,7 @@ lisp_malloc (size_t nbytes, enum mem_type type)
1111#endif 1016#endif
1112 1017
1113 MALLOC_UNBLOCK_INPUT; 1018 MALLOC_UNBLOCK_INPUT;
1114 if (!val && nbytes) 1019 if (!val)
1115 memory_full (nbytes); 1020 memory_full (nbytes);
1116 MALLOC_PROBE (nbytes); 1021 MALLOC_PROBE (nbytes);
1117 return val; 1022 return val;
@@ -1123,10 +1028,16 @@ lisp_malloc (size_t nbytes, enum mem_type type)
1123static void 1028static void
1124lisp_free (void *block) 1029lisp_free (void *block)
1125{ 1030{
1031 if (pdumper_object_p (block))
1032 return;
1033
1126 MALLOC_BLOCK_INPUT; 1034 MALLOC_BLOCK_INPUT;
1035#ifndef GC_MALLOC_CHECK
1036 struct mem_node *m = mem_find (block);
1037#endif
1127 free (block); 1038 free (block);
1128#ifndef GC_MALLOC_CHECK 1039#ifndef GC_MALLOC_CHECK
1129 mem_delete (mem_find (block)); 1040 mem_delete (m);
1130#endif 1041#endif
1131 MALLOC_UNBLOCK_INPUT; 1042 MALLOC_UNBLOCK_INPUT;
1132} 1043}
@@ -1141,11 +1052,10 @@ lisp_free (void *block)
1141verify (POWER_OF_2 (BLOCK_ALIGN)); 1052verify (POWER_OF_2 (BLOCK_ALIGN));
1142 1053
1143/* Use aligned_alloc if it or a simple substitute is available. 1054/* Use aligned_alloc if it or a simple substitute is available.
1144 Address sanitization breaks aligned allocation, as of gcc 4.8.2 and 1055 Aligned allocation is incompatible with unexmacosx.c, so don't use
1145 clang 3.3 anyway. Aligned allocation is incompatible with 1056 it on Darwin if HAVE_UNEXEC. */
1146 unexmacosx.c, so don't use it on Darwin. */
1147 1057
1148#if ! ADDRESS_SANITIZER && !defined DARWIN_OS 1058#if ! (defined DARWIN_OS && defined HAVE_UNEXEC)
1149# if (defined HAVE_ALIGNED_ALLOC \ 1059# if (defined HAVE_ALIGNED_ALLOC \
1150 || (defined HYBRID_MALLOC \ 1060 || (defined HYBRID_MALLOC \
1151 ? defined HAVE_POSIX_MEMALIGN \ 1061 ? defined HAVE_POSIX_MEMALIGN \
@@ -1161,9 +1071,11 @@ aligned_alloc (size_t alignment, size_t size)
1161 Verify this for all arguments this function is given. */ 1071 Verify this for all arguments this function is given. */
1162 verify (BLOCK_ALIGN % sizeof (void *) == 0 1072 verify (BLOCK_ALIGN % sizeof (void *) == 0
1163 && POWER_OF_2 (BLOCK_ALIGN / sizeof (void *))); 1073 && POWER_OF_2 (BLOCK_ALIGN / sizeof (void *)));
1164 verify (GCALIGNMENT % sizeof (void *) == 0 1074 verify (MALLOC_IS_LISP_ALIGNED
1165 && POWER_OF_2 (GCALIGNMENT / sizeof (void *))); 1075 || (LISP_ALIGNMENT % sizeof (void *) == 0
1166 eassert (alignment == BLOCK_ALIGN || alignment == GCALIGNMENT); 1076 && POWER_OF_2 (LISP_ALIGNMENT / sizeof (void *))));
1077 eassert (alignment == BLOCK_ALIGN
1078 || (!MALLOC_IS_LISP_ALIGNED && alignment == LISP_ALIGNMENT));
1167 1079
1168 void *p; 1080 void *p;
1169 return posix_memalign (&p, alignment, size) == 0 ? p : 0; 1081 return posix_memalign (&p, alignment, size) == 0 ? p : 0;
@@ -1395,43 +1307,31 @@ lisp_align_free (void *block)
1395 MALLOC_UNBLOCK_INPUT; 1307 MALLOC_UNBLOCK_INPUT;
1396} 1308}
1397 1309
1398#if !defined __GNUC__ && !defined __alignof__
1399# define __alignof__(type) alignof (type)
1400#endif
1401
1402/* True if malloc (N) is known to return a multiple of GCALIGNMENT
1403 whenever N is also a multiple. In practice this is true if
1404 __alignof__ (max_align_t) is a multiple as well, assuming
1405 GCALIGNMENT is 8; other values of GCALIGNMENT have not been looked
1406 into. Use __alignof__ if available, as otherwise
1407 MALLOC_IS_GC_ALIGNED would be false on GCC x86 even though the
1408 alignment is OK there.
1409
1410 This is a macro, not an enum constant, for portability to HP-UX
1411 10.20 cc and AIX 3.2.5 xlc. */
1412#define MALLOC_IS_GC_ALIGNED \
1413 (GCALIGNMENT == 8 && __alignof__ (max_align_t) % GCALIGNMENT == 0)
1414
1415/* True if a malloc-returned pointer P is suitably aligned for SIZE, 1310/* True if a malloc-returned pointer P is suitably aligned for SIZE,
1416 where Lisp alignment may be needed if SIZE is Lisp-aligned. */ 1311 where Lisp object alignment may be needed if SIZE is a multiple of
1312 LISP_ALIGNMENT. */
1417 1313
1418static bool 1314static bool
1419laligned (void *p, size_t size) 1315laligned (void *p, size_t size)
1420{ 1316{
1421 return (MALLOC_IS_GC_ALIGNED || (intptr_t) p % GCALIGNMENT == 0 1317 return (MALLOC_IS_LISP_ALIGNED || (intptr_t) p % LISP_ALIGNMENT == 0
1422 || size % GCALIGNMENT != 0); 1318 || size % LISP_ALIGNMENT != 0);
1423} 1319}
1424 1320
1425/* Like malloc and realloc except that if SIZE is Lisp-aligned, make 1321/* Like malloc and realloc except return null only on failure,
1426 sure the result is too, if necessary by reallocating (typically 1322 the result is Lisp-aligned if SIZE is, and lrealloc's pointer
1427 with larger and larger sizes) until the allocator returns a 1323 argument must be nonnull. Code allocating C heap memory
1428 Lisp-aligned pointer. Code that needs to allocate C heap memory
1429 for a Lisp object should use one of these functions to obtain a 1324 for a Lisp object should use one of these functions to obtain a
1430 pointer P; that way, if T is an enum Lisp_Type value and L == 1325 pointer P; that way, if T is an enum Lisp_Type value and L ==
1431 make_lisp_ptr (P, T), then XPNTR (L) == P and XTYPE (L) == T. 1326 make_lisp_ptr (P, T), then XPNTR (L) == P and XTYPE (L) == T.
1432 1327
1328 If CLEARIT, arrange for the allocated memory to be cleared.
1329 This might use calloc, as calloc can be faster than malloc+memset.
1330
1433 On typical modern platforms these functions' loops do not iterate. 1331 On typical modern platforms these functions' loops do not iterate.
1434 On now-rare (and perhaps nonexistent) platforms, the loops in 1332 On now-rare (and perhaps nonexistent) platforms, the code can loop,
1333 reallocating (typically with larger and larger sizes) until the
1334 allocator returns a Lisp-aligned pointer. This loop in
1435 theory could repeat forever. If an infinite loop is possible on a 1335 theory could repeat forever. If an infinite loop is possible on a
1436 platform, a build would surely loop and the builder can then send 1336 platform, a build would surely loop and the builder can then send
1437 us a bug report. Adding a counter to try to detect any such loop 1337 us a bug report. Adding a counter to try to detect any such loop
@@ -1439,20 +1339,30 @@ laligned (void *p, size_t size)
1439 that's never really exercised) for little benefit. */ 1339 that's never really exercised) for little benefit. */
1440 1340
1441static void * 1341static void *
1442lmalloc (size_t size) 1342lmalloc (size_t size, bool clearit)
1443{ 1343{
1444#if USE_ALIGNED_ALLOC 1344#ifdef USE_ALIGNED_ALLOC
1445 if (! MALLOC_IS_GC_ALIGNED && size % GCALIGNMENT == 0) 1345 if (! MALLOC_IS_LISP_ALIGNED && size % LISP_ALIGNMENT == 0)
1446 return aligned_alloc (GCALIGNMENT, size); 1346 {
1347 void *p = aligned_alloc (LISP_ALIGNMENT, size);
1348 if (p)
1349 {
1350 if (clearit)
1351 memclear (p, size);
1352 }
1353 else if (! (MALLOC_0_IS_NONNULL || size))
1354 return aligned_alloc (LISP_ALIGNMENT, LISP_ALIGNMENT);
1355 return p;
1356 }
1447#endif 1357#endif
1448 1358
1449 while (true) 1359 while (true)
1450 { 1360 {
1451 void *p = malloc (size); 1361 void *p = clearit ? calloc (1, size) : malloc (size);
1452 if (laligned (p, size)) 1362 if (laligned (p, size) && (MALLOC_0_IS_NONNULL || size || p))
1453 return p; 1363 return p;
1454 free (p); 1364 free (p);
1455 size_t bigger = size + GCALIGNMENT; 1365 size_t bigger = size + LISP_ALIGNMENT;
1456 if (size < bigger) 1366 if (size < bigger)
1457 size = bigger; 1367 size = bigger;
1458 } 1368 }
@@ -1464,9 +1374,9 @@ lrealloc (void *p, size_t size)
1464 while (true) 1374 while (true)
1465 { 1375 {
1466 p = realloc (p, size); 1376 p = realloc (p, size);
1467 if (laligned (p, size)) 1377 if (laligned (p, size) && (size || p))
1468 return p; 1378 return p;
1469 size_t bigger = size + GCALIGNMENT; 1379 size_t bigger = size + LISP_ALIGNMENT;
1470 if (size < bigger) 1380 if (size < bigger)
1471 size = bigger; 1381 size = bigger;
1472 } 1382 }
@@ -1477,11 +1387,11 @@ lrealloc (void *p, size_t size)
1477 Interval Allocation 1387 Interval Allocation
1478 ***********************************************************************/ 1388 ***********************************************************************/
1479 1389
1480/* Number of intervals allocated in an interval_block structure. 1390/* Number of intervals allocated in an interval_block structure. */
1481 The 1020 is 1024 minus malloc overhead. */
1482 1391
1483#define INTERVAL_BLOCK_SIZE \ 1392enum { INTERVAL_BLOCK_SIZE
1484 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval)) 1393 = ((MALLOC_SIZE_NEAR (1024) - sizeof (struct interval_block *))
1394 / sizeof (struct interval)) };
1485 1395
1486/* Intervals are allocated in chunks in the form of an interval_block 1396/* Intervals are allocated in chunks in the form of an interval_block
1487 structure. */ 1397 structure. */
@@ -1503,10 +1413,6 @@ static struct interval_block *interval_block;
1503 1413
1504static int interval_block_index = INTERVAL_BLOCK_SIZE; 1414static int interval_block_index = INTERVAL_BLOCK_SIZE;
1505 1415
1506/* Number of free and live intervals. */
1507
1508static EMACS_INT total_free_intervals, total_intervals;
1509
1510/* List of free intervals. */ 1416/* List of free intervals. */
1511 1417
1512static INTERVAL interval_free_list; 1418static INTERVAL interval_free_list;
@@ -1530,21 +1436,19 @@ make_interval (void)
1530 if (interval_block_index == INTERVAL_BLOCK_SIZE) 1436 if (interval_block_index == INTERVAL_BLOCK_SIZE)
1531 { 1437 {
1532 struct interval_block *newi 1438 struct interval_block *newi
1533 = lisp_malloc (sizeof *newi, MEM_TYPE_NON_LISP); 1439 = lisp_malloc (sizeof *newi, false, MEM_TYPE_NON_LISP);
1534 1440
1535 newi->next = interval_block; 1441 newi->next = interval_block;
1536 interval_block = newi; 1442 interval_block = newi;
1537 interval_block_index = 0; 1443 interval_block_index = 0;
1538 total_free_intervals += INTERVAL_BLOCK_SIZE;
1539 } 1444 }
1540 val = &interval_block->intervals[interval_block_index++]; 1445 val = &interval_block->intervals[interval_block_index++];
1541 } 1446 }
1542 1447
1543 MALLOC_UNBLOCK_INPUT; 1448 MALLOC_UNBLOCK_INPUT;
1544 1449
1545 consing_since_gc += sizeof (struct interval); 1450 tally_consing (sizeof (struct interval));
1546 intervals_consed++; 1451 intervals_consed++;
1547 total_free_intervals--;
1548 RESET_INTERVAL (val); 1452 RESET_INTERVAL (val);
1549 val->gcmarkbit = 0; 1453 val->gcmarkbit = 0;
1550 return val; 1454 return val;
@@ -1554,22 +1458,23 @@ make_interval (void)
1554/* Mark Lisp objects in interval I. */ 1458/* Mark Lisp objects in interval I. */
1555 1459
1556static void 1460static void
1557mark_interval (INTERVAL i, void *dummy) 1461mark_interval_tree_1 (INTERVAL i, void *dummy)
1558{ 1462{
1559 /* Intervals should never be shared. So, if extra internal checking is 1463 /* Intervals should never be shared. So, if extra internal checking is
1560 enabled, GC aborts if it seems to have visited an interval twice. */ 1464 enabled, GC aborts if it seems to have visited an interval twice. */
1561 eassert (!i->gcmarkbit); 1465 eassert (!interval_marked_p (i));
1562 i->gcmarkbit = 1; 1466 set_interval_marked (i);
1563 mark_object (i->plist); 1467 mark_object (i->plist);
1564} 1468}
1565 1469
1566/* Mark the interval tree rooted in I. */ 1470/* Mark the interval tree rooted in I. */
1567 1471
1568#define MARK_INTERVAL_TREE(i) \ 1472static void
1569 do { \ 1473mark_interval_tree (INTERVAL i)
1570 if (i && !i->gcmarkbit) \ 1474{
1571 traverse_intervals_noorder (i, mark_interval, NULL); \ 1475 if (i && !interval_marked_p (i))
1572 } while (0) 1476 traverse_intervals_noorder (i, mark_interval_tree_1, NULL);
1477}
1573 1478
1574/*********************************************************************** 1479/***********************************************************************
1575 String Allocation 1480 String Allocation
@@ -1598,19 +1503,16 @@ mark_interval (INTERVAL i, void *dummy)
1598 longer used, can be easily recognized, and it's easy to compact the 1503 longer used, can be easily recognized, and it's easy to compact the
1599 sblocks of small strings which we do in compact_small_strings. */ 1504 sblocks of small strings which we do in compact_small_strings. */
1600 1505
1601/* Size in bytes of an sblock structure used for small strings. This 1506/* Size in bytes of an sblock structure used for small strings. */
1602 is 8192 minus malloc overhead. */
1603 1507
1604#define SBLOCK_SIZE 8188 1508enum { SBLOCK_SIZE = MALLOC_SIZE_NEAR (8192) };
1605 1509
1606/* Strings larger than this are considered large strings. String data 1510/* Strings larger than this are considered large strings. String data
1607 for large strings is allocated from individual sblocks. */ 1511 for large strings is allocated from individual sblocks. */
1608 1512
1609#define LARGE_STRING_BYTES 1024 1513#define LARGE_STRING_BYTES 1024
1610 1514
1611/* The SDATA typedef is a struct or union describing string memory 1515/* The layout of a nonnull string. */
1612 sub-allocated from an sblock. This is where the contents of Lisp
1613 strings are stored. */
1614 1516
1615struct sdata 1517struct sdata
1616{ 1518{
@@ -1629,13 +1531,8 @@ struct sdata
1629 unsigned char data[FLEXIBLE_ARRAY_MEMBER]; 1531 unsigned char data[FLEXIBLE_ARRAY_MEMBER];
1630}; 1532};
1631 1533
1632#ifdef GC_CHECK_STRING_BYTES 1534/* A union describing string memory sub-allocated from an sblock.
1633 1535 This is where the contents of Lisp strings are stored. */
1634typedef struct sdata sdata;
1635#define SDATA_NBYTES(S) (S)->nbytes
1636#define SDATA_DATA(S) (S)->data
1637
1638#else
1639 1536
1640typedef union 1537typedef union
1641{ 1538{
@@ -1663,8 +1560,6 @@ typedef union
1663#define SDATA_NBYTES(S) (S)->n.nbytes 1560#define SDATA_NBYTES(S) (S)->n.nbytes
1664#define SDATA_DATA(S) ((struct sdata *) (S))->data 1561#define SDATA_DATA(S) ((struct sdata *) (S))->data
1665 1562
1666#endif /* not GC_CHECK_STRING_BYTES */
1667
1668enum { SDATA_DATA_OFFSET = offsetof (struct sdata, data) }; 1563enum { SDATA_DATA_OFFSET = offsetof (struct sdata, data) };
1669 1564
1670/* Structure describing a block of memory which is sub-allocated to 1565/* Structure describing a block of memory which is sub-allocated to
@@ -1685,11 +1580,11 @@ struct sblock
1685 sdata data[FLEXIBLE_ARRAY_MEMBER]; 1580 sdata data[FLEXIBLE_ARRAY_MEMBER];
1686}; 1581};
1687 1582
1688/* Number of Lisp strings in a string_block structure. The 1020 is 1583/* Number of Lisp strings in a string_block structure. */
1689 1024 minus malloc overhead. */
1690 1584
1691#define STRING_BLOCK_SIZE \ 1585enum { STRING_BLOCK_SIZE
1692 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String)) 1586 = ((MALLOC_SIZE_NEAR (1024) - sizeof (struct string_block *))
1587 / sizeof (struct Lisp_String)) };
1693 1588
1694/* Structure describing a block from which Lisp_String structures 1589/* Structure describing a block from which Lisp_String structures
1695 are allocated. */ 1590 are allocated. */
@@ -1719,71 +1614,50 @@ static struct string_block *string_blocks;
1719 1614
1720static struct Lisp_String *string_free_list; 1615static struct Lisp_String *string_free_list;
1721 1616
1722/* Number of live and free Lisp_Strings. */
1723
1724static EMACS_INT total_strings, total_free_strings;
1725
1726/* Number of bytes used by live strings. */
1727
1728static EMACS_INT total_string_bytes;
1729
1730/* Given a pointer to a Lisp_String S which is on the free-list 1617/* Given a pointer to a Lisp_String S which is on the free-list
1731 string_free_list, return a pointer to its successor in the 1618 string_free_list, return a pointer to its successor in the
1732 free-list. */ 1619 free-list. */
1733 1620
1734#define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S)) 1621#define NEXT_FREE_LISP_STRING(S) ((S)->u.next)
1735 1622
1736/* Return a pointer to the sdata structure belonging to Lisp string S. 1623/* Return a pointer to the sdata structure belonging to Lisp string S.
1737 S must be live, i.e. S->data must not be null. S->data is actually 1624 S must be live, i.e. S->data must not be null. S->data is actually
1738 a pointer to the `u.data' member of its sdata structure; the 1625 a pointer to the `u.data' member of its sdata structure; the
1739 structure starts at a constant offset in front of that. */ 1626 structure starts at a constant offset in front of that. */
1740 1627
1741#define SDATA_OF_STRING(S) ((sdata *) ((S)->data - SDATA_DATA_OFFSET)) 1628#define SDATA_OF_STRING(S) ((sdata *) ((S)->u.s.data - SDATA_DATA_OFFSET))
1742 1629
1743 1630
1744#ifdef GC_CHECK_STRING_OVERRUN 1631#ifdef GC_CHECK_STRING_OVERRUN
1745 1632
1746/* We check for overrun in string data blocks by appending a small 1633/* Check for overrun in string data blocks by appending a small
1747 "cookie" after each allocated string data block, and check for the 1634 "cookie" after each allocated string data block, and check for the
1748 presence of this cookie during GC. */ 1635 presence of this cookie during GC. */
1749 1636# define GC_STRING_OVERRUN_COOKIE_SIZE ROUNDUP (4, alignof (sdata))
1750#define GC_STRING_OVERRUN_COOKIE_SIZE 4
1751static char const string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] = 1637static char const string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
1752 { '\xde', '\xad', '\xbe', '\xef' }; 1638 { '\xde', '\xad', '\xbe', '\xef', /* Perhaps some zeros here. */ };
1753 1639
1754#else 1640#else
1755#define GC_STRING_OVERRUN_COOKIE_SIZE 0 1641# define GC_STRING_OVERRUN_COOKIE_SIZE 0
1756#endif 1642#endif
1757 1643
1758/* Value is the size of an sdata structure large enough to hold NBYTES 1644/* Return the size of an sdata structure large enough to hold N bytes
1759 bytes of string data. The value returned includes a terminating 1645 of string data. This counts the sdata structure, the N bytes, a
1760 NUL byte, the size of the sdata structure, and padding. */ 1646 terminating NUL byte, and alignment padding. */
1761
1762#ifdef GC_CHECK_STRING_BYTES
1763
1764#define SDATA_SIZE(NBYTES) FLEXSIZEOF (struct sdata, data, NBYTES)
1765 1647
1766#else /* not GC_CHECK_STRING_BYTES */ 1648static ptrdiff_t
1767 1649sdata_size (ptrdiff_t n)
1768/* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is 1650{
1769 less than the size of that member. The 'max' is not needed when 1651 /* Reserve space for the nbytes union member even when N + 1 is less
1770 SDATA_DATA_OFFSET is a multiple of FLEXALIGNOF (struct sdata), 1652 than the size of that member. */
1771 because then the alignment code reserves enough space. */ 1653 ptrdiff_t unaligned_size = max (SDATA_DATA_OFFSET + n + 1,
1772 1654 sizeof (sdata));
1773#define SDATA_SIZE(NBYTES) \ 1655 int sdata_align = max (FLEXALIGNOF (struct sdata), alignof (sdata));
1774 ((SDATA_DATA_OFFSET \ 1656 return (unaligned_size + sdata_align - 1) & ~(sdata_align - 1);
1775 + (SDATA_DATA_OFFSET % FLEXALIGNOF (struct sdata) == 0 \ 1657}
1776 ? NBYTES \
1777 : max (NBYTES, FLEXALIGNOF (struct sdata) - 1)) \
1778 + 1 \
1779 + FLEXALIGNOF (struct sdata) - 1) \
1780 & ~(FLEXALIGNOF (struct sdata) - 1))
1781
1782#endif /* not GC_CHECK_STRING_BYTES */
1783 1658
1784/* Extra bytes to allocate for each string. */ 1659/* Extra bytes to allocate for each string. */
1785 1660#define GC_STRING_EXTRA GC_STRING_OVERRUN_COOKIE_SIZE
1786#define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1787 1661
1788/* Exact bound on the number of bytes in a string, not counting the 1662/* Exact bound on the number of bytes in a string, not counting the
1789 terminating null. A string cannot contain more bytes than 1663 terminating null. A string cannot contain more bytes than
@@ -1792,7 +1666,7 @@ static char const string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
1792 calculating a value to be passed to malloc. */ 1666 calculating a value to be passed to malloc. */
1793static ptrdiff_t const STRING_BYTES_MAX = 1667static ptrdiff_t const STRING_BYTES_MAX =
1794 min (STRING_BYTES_BOUND, 1668 min (STRING_BYTES_BOUND,
1795 ((SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD 1669 ((SIZE_MAX
1796 - GC_STRING_EXTRA 1670 - GC_STRING_EXTRA
1797 - offsetof (struct sblock, data) 1671 - offsetof (struct sblock, data)
1798 - SDATA_DATA_OFFSET) 1672 - SDATA_DATA_OFFSET)
@@ -1804,7 +1678,9 @@ static void
1804init_strings (void) 1678init_strings (void)
1805{ 1679{
1806 empty_unibyte_string = make_pure_string ("", 0, 0, 0); 1680 empty_unibyte_string = make_pure_string ("", 0, 0, 0);
1681 staticpro (&empty_unibyte_string);
1807 empty_multibyte_string = make_pure_string ("", 0, 0, 1); 1682 empty_multibyte_string = make_pure_string ("", 0, 0, 1);
1683 staticpro (&empty_multibyte_string);
1808} 1684}
1809 1685
1810 1686
@@ -1819,9 +1695,10 @@ ptrdiff_t
1819string_bytes (struct Lisp_String *s) 1695string_bytes (struct Lisp_String *s)
1820{ 1696{
1821 ptrdiff_t nbytes = 1697 ptrdiff_t nbytes =
1822 (s->size_byte < 0 ? s->size & ~ARRAY_MARK_FLAG : s->size_byte); 1698 (s->u.s.size_byte < 0 ? s->u.s.size & ~ARRAY_MARK_FLAG : s->u.s.size_byte);
1823 1699
1824 if (!PURE_P (s) && s->data && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s))) 1700 if (!PURE_P (s) && !pdumper_object_p (s) && s->u.s.data
1701 && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
1825 emacs_abort (); 1702 emacs_abort ();
1826 return nbytes; 1703 return nbytes;
1827} 1704}
@@ -1831,21 +1708,14 @@ string_bytes (struct Lisp_String *s)
1831static void 1708static void
1832check_sblock (struct sblock *b) 1709check_sblock (struct sblock *b)
1833{ 1710{
1834 sdata *from, *end, *from_end; 1711 sdata *end = b->next_free;
1835
1836 end = b->next_free;
1837 1712
1838 for (from = b->data; from < end; from = from_end) 1713 for (sdata *from = b->data; from < end; )
1839 { 1714 {
1840 /* Compute the next FROM here because copying below may 1715 ptrdiff_t nbytes = sdata_size (from->string
1841 overwrite data we need to compute it. */ 1716 ? string_bytes (from->string)
1842 ptrdiff_t nbytes; 1717 : SDATA_NBYTES (from));
1843 1718 from = (sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
1844 /* Check that the string size recorded in the string is the
1845 same as the one recorded in the sdata structure. */
1846 nbytes = SDATA_SIZE (from->string ? string_bytes (from->string)
1847 : SDATA_NBYTES (from));
1848 from_end = (sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
1849 } 1719 }
1850} 1720}
1851 1721
@@ -1917,7 +1787,7 @@ allocate_string (void)
1917 add all the Lisp_Strings in it to the free-list. */ 1787 add all the Lisp_Strings in it to the free-list. */
1918 if (string_free_list == NULL) 1788 if (string_free_list == NULL)
1919 { 1789 {
1920 struct string_block *b = lisp_malloc (sizeof *b, MEM_TYPE_STRING); 1790 struct string_block *b = lisp_malloc (sizeof *b, false, MEM_TYPE_STRING);
1921 int i; 1791 int i;
1922 1792
1923 b->next = string_blocks; 1793 b->next = string_blocks;
@@ -1927,12 +1797,10 @@ allocate_string (void)
1927 { 1797 {
1928 s = b->strings + i; 1798 s = b->strings + i;
1929 /* Every string on a free list should have NULL data pointer. */ 1799 /* Every string on a free list should have NULL data pointer. */
1930 s->data = NULL; 1800 s->u.s.data = NULL;
1931 NEXT_FREE_LISP_STRING (s) = string_free_list; 1801 NEXT_FREE_LISP_STRING (s) = string_free_list;
1932 string_free_list = s; 1802 string_free_list = s;
1933 } 1803 }
1934
1935 total_free_strings += STRING_BLOCK_SIZE;
1936 } 1804 }
1937 1805
1938 check_string_free_list (); 1806 check_string_free_list ();
@@ -1943,10 +1811,8 @@ allocate_string (void)
1943 1811
1944 MALLOC_UNBLOCK_INPUT; 1812 MALLOC_UNBLOCK_INPUT;
1945 1813
1946 --total_free_strings;
1947 ++total_strings;
1948 ++strings_consed; 1814 ++strings_consed;
1949 consing_since_gc += sizeof *s; 1815 tally_consing (sizeof *s);
1950 1816
1951#ifdef GC_CHECK_STRING_BYTES 1817#ifdef GC_CHECK_STRING_BYTES
1952 if (!noninteractive) 1818 if (!noninteractive)
@@ -1966,36 +1832,31 @@ allocate_string (void)
1966 1832
1967 1833
1968/* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes, 1834/* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1969 plus a NUL byte at the end. Allocate an sdata structure for S, and 1835 plus a NUL byte at the end. Allocate an sdata structure DATA for
1970 set S->data to its `u.data' member. Store a NUL byte at the end of 1836 S, and set S->u.s.data to SDATA->u.data. Store a NUL byte at the
1971 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free 1837 end of S->u.s.data. Set S->u.s.size to NCHARS and S->u.s.size_byte
1972 S->data if it was initially non-null. */ 1838 to NBYTES. Free S->u.s.data if it was initially non-null.
1973 1839
1974void 1840 If CLEARIT, also clear the other bytes of S->u.s.data. */
1841
1842static void
1975allocate_string_data (struct Lisp_String *s, 1843allocate_string_data (struct Lisp_String *s,
1976 EMACS_INT nchars, EMACS_INT nbytes) 1844 EMACS_INT nchars, EMACS_INT nbytes, bool clearit,
1845 bool immovable)
1977{ 1846{
1978 sdata *data, *old_data; 1847 sdata *data;
1979 struct sblock *b; 1848 struct sblock *b;
1980 ptrdiff_t needed, old_nbytes;
1981 1849
1982 if (STRING_BYTES_MAX < nbytes) 1850 if (STRING_BYTES_MAX < nbytes)
1983 string_overflow (); 1851 string_overflow ();
1984 1852
1985 /* Determine the number of bytes needed to store NBYTES bytes 1853 /* Determine the number of bytes needed to store NBYTES bytes
1986 of string data. */ 1854 of string data. */
1987 needed = SDATA_SIZE (nbytes); 1855 ptrdiff_t needed = sdata_size (nbytes);
1988 if (s->data)
1989 {
1990 old_data = SDATA_OF_STRING (s);
1991 old_nbytes = STRING_BYTES (s);
1992 }
1993 else
1994 old_data = NULL;
1995 1856
1996 MALLOC_BLOCK_INPUT; 1857 MALLOC_BLOCK_INPUT;
1997 1858
1998 if (nbytes > LARGE_STRING_BYTES) 1859 if (nbytes > LARGE_STRING_BYTES || immovable)
1999 { 1860 {
2000 size_t size = FLEXSIZEOF (struct sblock, data, needed); 1861 size_t size = FLEXSIZEOF (struct sblock, data, needed);
2001 1862
@@ -2004,7 +1865,7 @@ allocate_string_data (struct Lisp_String *s,
2004 mallopt (M_MMAP_MAX, 0); 1865 mallopt (M_MMAP_MAX, 0);
2005#endif 1866#endif
2006 1867
2007 b = lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP); 1868 b = lisp_malloc (size + GC_STRING_EXTRA, clearit, MEM_TYPE_NON_LISP);
2008 1869
2009#ifdef DOUG_LEA_MALLOC 1870#ifdef DOUG_LEA_MALLOC
2010 if (!mmap_lisp_allowed_p ()) 1871 if (!mmap_lisp_allowed_p ())
@@ -2016,56 +1877,101 @@ allocate_string_data (struct Lisp_String *s,
2016 b->next_free = data; 1877 b->next_free = data;
2017 large_sblocks = b; 1878 large_sblocks = b;
2018 } 1879 }
2019 else if (current_sblock == NULL
2020 || (((char *) current_sblock + SBLOCK_SIZE
2021 - (char *) current_sblock->next_free)
2022 < (needed + GC_STRING_EXTRA)))
2023 {
2024 /* Not enough room in the current sblock. */
2025 b = lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
2026 data = b->data;
2027 b->next = NULL;
2028 b->next_free = data;
2029
2030 if (current_sblock)
2031 current_sblock->next = b;
2032 else
2033 oldest_sblock = b;
2034 current_sblock = b;
2035 }
2036 else 1880 else
2037 { 1881 {
2038 b = current_sblock; 1882 b = current_sblock;
1883
1884 if (b == NULL
1885 || (SBLOCK_SIZE - GC_STRING_EXTRA
1886 < (char *) b->next_free - (char *) b + needed))
1887 {
1888 /* Not enough room in the current sblock. */
1889 b = lisp_malloc (SBLOCK_SIZE, false, MEM_TYPE_NON_LISP);
1890 data = b->data;
1891 b->next = NULL;
1892 b->next_free = data;
1893
1894 if (current_sblock)
1895 current_sblock->next = b;
1896 else
1897 oldest_sblock = b;
1898 current_sblock = b;
1899 }
1900
2039 data = b->next_free; 1901 data = b->next_free;
1902 if (clearit)
1903 memset (SDATA_DATA (data), 0, nbytes);
2040 } 1904 }
2041 1905
2042 data->string = s; 1906 data->string = s;
2043 b->next_free = (sdata *) ((char *) data + needed + GC_STRING_EXTRA); 1907 b->next_free = (sdata *) ((char *) data + needed + GC_STRING_EXTRA);
1908 eassert ((uintptr_t) b->next_free % alignof (sdata) == 0);
2044 1909
2045 MALLOC_UNBLOCK_INPUT; 1910 MALLOC_UNBLOCK_INPUT;
2046 1911
2047 s->data = SDATA_DATA (data); 1912 s->u.s.data = SDATA_DATA (data);
2048#ifdef GC_CHECK_STRING_BYTES 1913#ifdef GC_CHECK_STRING_BYTES
2049 SDATA_NBYTES (data) = nbytes; 1914 SDATA_NBYTES (data) = nbytes;
2050#endif 1915#endif
2051 s->size = nchars; 1916 s->u.s.size = nchars;
2052 s->size_byte = nbytes; 1917 s->u.s.size_byte = nbytes;
2053 s->data[nbytes] = '\0'; 1918 s->u.s.data[nbytes] = '\0';
2054#ifdef GC_CHECK_STRING_OVERRUN 1919#ifdef GC_CHECK_STRING_OVERRUN
2055 memcpy ((char *) data + needed, string_overrun_cookie, 1920 memcpy ((char *) data + needed, string_overrun_cookie,
2056 GC_STRING_OVERRUN_COOKIE_SIZE); 1921 GC_STRING_OVERRUN_COOKIE_SIZE);
2057#endif 1922#endif
2058 1923
2059 /* Note that Faset may call to this function when S has already data 1924 tally_consing (needed);
2060 assigned. In this case, mark data as free by setting it's string 1925}
2061 back-pointer to null, and record the size of the data in it. */ 1926
2062 if (old_data) 1927/* Reallocate multibyte STRING data when a single character is replaced.
1928 The character is at byte offset CIDX_BYTE in the string.
1929 The character being replaced is CLEN bytes long,
1930 and the character that will replace it is NEW_CLEN bytes long.
1931 Return the address where the caller should store the new character. */
1932
1933unsigned char *
1934resize_string_data (Lisp_Object string, ptrdiff_t cidx_byte,
1935 int clen, int new_clen)
1936{
1937 eassume (STRING_MULTIBYTE (string));
1938 sdata *old_sdata = SDATA_OF_STRING (XSTRING (string));
1939 ptrdiff_t nchars = SCHARS (string);
1940 ptrdiff_t nbytes = SBYTES (string);
1941 ptrdiff_t new_nbytes = nbytes + (new_clen - clen);
1942 unsigned char *data = SDATA (string);
1943 unsigned char *new_charaddr;
1944
1945 if (sdata_size (nbytes) == sdata_size (new_nbytes))
1946 {
1947 /* No need to reallocate, as the size change falls within the
1948 alignment slop. */
1949 XSTRING (string)->u.s.size_byte = new_nbytes;
1950#ifdef GC_CHECK_STRING_BYTES
1951 SDATA_NBYTES (old_sdata) = new_nbytes;
1952#endif
1953 new_charaddr = data + cidx_byte;
1954 memmove (new_charaddr + new_clen, new_charaddr + clen,
1955 nbytes - (cidx_byte + (clen - 1)));
1956 }
1957 else
2063 { 1958 {
2064 SDATA_NBYTES (old_data) = old_nbytes; 1959 allocate_string_data (XSTRING (string), nchars, new_nbytes, false, false);
2065 old_data->string = NULL; 1960 unsigned char *new_data = SDATA (string);
1961 new_charaddr = new_data + cidx_byte;
1962 memcpy (new_charaddr + new_clen, data + cidx_byte + clen,
1963 nbytes - (cidx_byte + clen));
1964 memcpy (new_data, data, cidx_byte);
1965
1966 /* Mark old string data as free by setting its string back-pointer
1967 to null, and record the size of the data in it. */
1968 SDATA_NBYTES (old_sdata) = nbytes;
1969 old_sdata->string = NULL;
2066 } 1970 }
2067 1971
2068 consing_since_gc += needed; 1972 clear_string_char_byte_cache ();
1973
1974 return new_charaddr;
2069} 1975}
2070 1976
2071 1977
@@ -2079,8 +1985,8 @@ sweep_strings (void)
2079 struct string_block *live_blocks = NULL; 1985 struct string_block *live_blocks = NULL;
2080 1986
2081 string_free_list = NULL; 1987 string_free_list = NULL;
2082 total_strings = total_free_strings = 0; 1988 gcstat.total_strings = gcstat.total_free_strings = 0;
2083 total_string_bytes = 0; 1989 gcstat.total_string_bytes = 0;
2084 1990
2085 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */ 1991 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2086 for (b = string_blocks; b; b = next) 1992 for (b = string_blocks; b; b = next)
@@ -2094,19 +2000,19 @@ sweep_strings (void)
2094 { 2000 {
2095 struct Lisp_String *s = b->strings + i; 2001 struct Lisp_String *s = b->strings + i;
2096 2002
2097 if (s->data) 2003 if (s->u.s.data)
2098 { 2004 {
2099 /* String was not on free-list before. */ 2005 /* String was not on free-list before. */
2100 if (STRING_MARKED_P (s)) 2006 if (XSTRING_MARKED_P (s))
2101 { 2007 {
2102 /* String is live; unmark it and its intervals. */ 2008 /* String is live; unmark it and its intervals. */
2103 UNMARK_STRING (s); 2009 XUNMARK_STRING (s);
2104 2010
2105 /* Do not use string_(set|get)_intervals here. */ 2011 /* Do not use string_(set|get)_intervals here. */
2106 s->intervals = balance_intervals (s->intervals); 2012 s->u.s.intervals = balance_intervals (s->u.s.intervals);
2107 2013
2108 ++total_strings; 2014 gcstat.total_strings++;
2109 total_string_bytes += STRING_BYTES (s); 2015 gcstat.total_string_bytes += STRING_BYTES (s);
2110 } 2016 }
2111 else 2017 else
2112 { 2018 {
@@ -2126,7 +2032,7 @@ sweep_strings (void)
2126 2032
2127 /* Reset the strings's `data' member so that we 2033 /* Reset the strings's `data' member so that we
2128 know it's free. */ 2034 know it's free. */
2129 s->data = NULL; 2035 s->u.s.data = NULL;
2130 2036
2131 /* Put the string on the free-list. */ 2037 /* Put the string on the free-list. */
2132 NEXT_FREE_LISP_STRING (s) = string_free_list; 2038 NEXT_FREE_LISP_STRING (s) = string_free_list;
@@ -2146,14 +2052,14 @@ sweep_strings (void)
2146 /* Free blocks that contain free Lisp_Strings only, except 2052 /* Free blocks that contain free Lisp_Strings only, except
2147 the first two of them. */ 2053 the first two of them. */
2148 if (nfree == STRING_BLOCK_SIZE 2054 if (nfree == STRING_BLOCK_SIZE
2149 && total_free_strings > STRING_BLOCK_SIZE) 2055 && gcstat.total_free_strings > STRING_BLOCK_SIZE)
2150 { 2056 {
2151 lisp_free (b); 2057 lisp_free (b);
2152 string_free_list = free_list_before; 2058 string_free_list = free_list_before;
2153 } 2059 }
2154 else 2060 else
2155 { 2061 {
2156 total_free_strings += nfree; 2062 gcstat.total_free_strings += nfree;
2157 b->next = live_blocks; 2063 b->next = live_blocks;
2158 live_blocks = b; 2064 live_blocks = b;
2159 } 2065 }
@@ -2234,9 +2140,9 @@ compact_small_strings (void)
2234 nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from); 2140 nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from);
2235 eassert (nbytes <= LARGE_STRING_BYTES); 2141 eassert (nbytes <= LARGE_STRING_BYTES);
2236 2142
2237 nbytes = SDATA_SIZE (nbytes); 2143 ptrdiff_t size = sdata_size (nbytes);
2238 sdata *from_end = (sdata *) ((char *) from 2144 sdata *from_end = (sdata *) ((char *) from
2239 + nbytes + GC_STRING_EXTRA); 2145 + size + GC_STRING_EXTRA);
2240 2146
2241#ifdef GC_CHECK_STRING_OVERRUN 2147#ifdef GC_CHECK_STRING_OVERRUN
2242 if (memcmp (string_overrun_cookie, 2148 if (memcmp (string_overrun_cookie,
@@ -2250,22 +2156,22 @@ compact_small_strings (void)
2250 { 2156 {
2251 /* If TB is full, proceed with the next sblock. */ 2157 /* If TB is full, proceed with the next sblock. */
2252 sdata *to_end = (sdata *) ((char *) to 2158 sdata *to_end = (sdata *) ((char *) to
2253 + nbytes + GC_STRING_EXTRA); 2159 + size + GC_STRING_EXTRA);
2254 if (to_end > tb_end) 2160 if (to_end > tb_end)
2255 { 2161 {
2256 tb->next_free = to; 2162 tb->next_free = to;
2257 tb = tb->next; 2163 tb = tb->next;
2258 tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE); 2164 tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
2259 to = tb->data; 2165 to = tb->data;
2260 to_end = (sdata *) ((char *) to + nbytes + GC_STRING_EXTRA); 2166 to_end = (sdata *) ((char *) to + size + GC_STRING_EXTRA);
2261 } 2167 }
2262 2168
2263 /* Copy, and update the string's `data' pointer. */ 2169 /* Copy, and update the string's `data' pointer. */
2264 if (from != to) 2170 if (from != to)
2265 { 2171 {
2266 eassert (tb != b || to < from); 2172 eassert (tb != b || to < from);
2267 memmove (to, from, nbytes + GC_STRING_EXTRA); 2173 memmove (to, from, size + GC_STRING_EXTRA);
2268 to->string->data = SDATA_DATA (to); 2174 to->string->u.s.data = SDATA_DATA (to);
2269 } 2175 }
2270 2176
2271 /* Advance past the sdata we copied to. */ 2177 /* Advance past the sdata we copied to. */
@@ -2299,25 +2205,31 @@ string_overflow (void)
2299 error ("Maximum string size exceeded"); 2205 error ("Maximum string size exceeded");
2300} 2206}
2301 2207
2302DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0, 2208static Lisp_Object make_clear_string (EMACS_INT, bool);
2209static Lisp_Object make_clear_multibyte_string (EMACS_INT, EMACS_INT, bool);
2210
2211DEFUN ("make-string", Fmake_string, Smake_string, 2, 3, 0,
2303 doc: /* Return a newly created string of length LENGTH, with INIT in each element. 2212 doc: /* Return a newly created string of length LENGTH, with INIT in each element.
2304LENGTH must be an integer. 2213LENGTH must be an integer.
2305INIT must be an integer that represents a character. */) 2214INIT must be an integer that represents a character.
2306 (Lisp_Object length, Lisp_Object init) 2215If optional argument MULTIBYTE is non-nil, the result will be
2216a multibyte string even if INIT is an ASCII character. */)
2217 (Lisp_Object length, Lisp_Object init, Lisp_Object multibyte)
2307{ 2218{
2308 register Lisp_Object val; 2219 Lisp_Object val;
2309 int c;
2310 EMACS_INT nbytes; 2220 EMACS_INT nbytes;
2311 2221
2312 CHECK_NATNUM (length); 2222 CHECK_FIXNAT (length);
2313 CHECK_CHARACTER (init); 2223 CHECK_CHARACTER (init);
2314 2224
2315 c = XFASTINT (init); 2225 int c = XFIXNAT (init);
2316 if (ASCII_CHAR_P (c)) 2226 bool clearit = !c;
2227
2228 if (ASCII_CHAR_P (c) && NILP (multibyte))
2317 { 2229 {
2318 nbytes = XINT (length); 2230 nbytes = XFIXNUM (length);
2319 val = make_uninit_string (nbytes); 2231 val = make_clear_string (nbytes, clearit);
2320 if (nbytes) 2232 if (nbytes && !clearit)
2321 { 2233 {
2322 memset (SDATA (val), c, nbytes); 2234 memset (SDATA (val), c, nbytes);
2323 SDATA (val)[nbytes] = 0; 2235 SDATA (val)[nbytes] = 0;
@@ -2327,27 +2239,28 @@ INIT must be an integer that represents a character. */)
2327 { 2239 {
2328 unsigned char str[MAX_MULTIBYTE_LENGTH]; 2240 unsigned char str[MAX_MULTIBYTE_LENGTH];
2329 ptrdiff_t len = CHAR_STRING (c, str); 2241 ptrdiff_t len = CHAR_STRING (c, str);
2330 EMACS_INT string_len = XINT (length); 2242 EMACS_INT string_len = XFIXNUM (length);
2331 unsigned char *p, *beg, *end;
2332 2243
2333 if (INT_MULTIPLY_WRAPV (len, string_len, &nbytes)) 2244 if (INT_MULTIPLY_WRAPV (len, string_len, &nbytes))
2334 string_overflow (); 2245 string_overflow ();
2335 val = make_uninit_multibyte_string (string_len, nbytes); 2246 val = make_clear_multibyte_string (string_len, nbytes, clearit);
2336 for (beg = SDATA (val), p = beg, end = beg + nbytes; p < end; p += len) 2247 if (!clearit)
2337 { 2248 {
2338 /* First time we just copy `str' to the data of `val'. */ 2249 unsigned char *beg = SDATA (val), *end = beg + nbytes;
2339 if (p == beg) 2250 for (unsigned char *p = beg; p < end; p += len)
2340 memcpy (p, str, len);
2341 else
2342 { 2251 {
2343 /* Next time we copy largest possible chunk from 2252 /* First time we just copy STR to the data of VAL. */
2344 initialized to uninitialized part of `val'. */ 2253 if (p == beg)
2345 len = min (p - beg, end - p); 2254 memcpy (p, str, len);
2346 memcpy (p, beg, len); 2255 else
2256 {
2257 /* Next time we copy largest possible chunk from
2258 initialized to uninitialized part of VAL. */
2259 len = min (p - beg, end - p);
2260 memcpy (p, beg, len);
2261 }
2347 } 2262 }
2348 } 2263 }
2349 if (nbytes)
2350 *p = 0;
2351 } 2264 }
2352 2265
2353 return val; 2266 return val;
@@ -2383,6 +2296,8 @@ make_uninit_bool_vector (EMACS_INT nbits)
2383 EMACS_INT needed_elements = ((bool_header_size - header_size + word_bytes 2296 EMACS_INT needed_elements = ((bool_header_size - header_size + word_bytes
2384 + word_size - 1) 2297 + word_size - 1)
2385 / word_size); 2298 / word_size);
2299 if (PTRDIFF_MAX < needed_elements)
2300 memory_full (SIZE_MAX);
2386 struct Lisp_Bool_Vector *p 2301 struct Lisp_Bool_Vector *p
2387 = (struct Lisp_Bool_Vector *) allocate_vector (needed_elements); 2302 = (struct Lisp_Bool_Vector *) allocate_vector (needed_elements);
2388 XSETVECTOR (val, p); 2303 XSETVECTOR (val, p);
@@ -2403,14 +2318,14 @@ LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2403{ 2318{
2404 Lisp_Object val; 2319 Lisp_Object val;
2405 2320
2406 CHECK_NATNUM (length); 2321 CHECK_FIXNAT (length);
2407 val = make_uninit_bool_vector (XFASTINT (length)); 2322 val = make_uninit_bool_vector (XFIXNAT (length));
2408 return bool_vector_fill (val, init); 2323 return bool_vector_fill (val, init);
2409} 2324}
2410 2325
2411DEFUN ("bool-vector", Fbool_vector, Sbool_vector, 0, MANY, 0, 2326DEFUN ("bool-vector", Fbool_vector, Sbool_vector, 0, MANY, 0,
2412 doc: /* Return a new bool-vector with specified arguments as elements. 2327 doc: /* Return a new bool-vector with specified arguments as elements.
2413Any number of arguments, even zero arguments, are allowed. 2328Allows any number of arguments, including zero.
2414usage: (bool-vector &rest OBJECTS) */) 2329usage: (bool-vector &rest OBJECTS) */)
2415 (ptrdiff_t nargs, Lisp_Object *args) 2330 (ptrdiff_t nargs, Lisp_Object *args)
2416{ 2331{
@@ -2515,26 +2430,37 @@ make_specified_string (const char *contents,
2515 2430
2516 2431
2517/* Return a unibyte Lisp_String set up to hold LENGTH characters 2432/* Return a unibyte Lisp_String set up to hold LENGTH characters
2518 occupying LENGTH bytes. */ 2433 occupying LENGTH bytes. If CLEARIT, clear its contents to null
2434 bytes; otherwise, the contents are uninitialized. */
2519 2435
2520Lisp_Object 2436static Lisp_Object
2521make_uninit_string (EMACS_INT length) 2437make_clear_string (EMACS_INT length, bool clearit)
2522{ 2438{
2523 Lisp_Object val; 2439 Lisp_Object val;
2524 2440
2525 if (!length) 2441 if (!length)
2526 return empty_unibyte_string; 2442 return empty_unibyte_string;
2527 val = make_uninit_multibyte_string (length, length); 2443 val = make_clear_multibyte_string (length, length, clearit);
2528 STRING_SET_UNIBYTE (val); 2444 STRING_SET_UNIBYTE (val);
2529 return val; 2445 return val;
2530} 2446}
2531 2447
2448/* Return a unibyte Lisp_String set up to hold LENGTH characters
2449 occupying LENGTH bytes. */
2450
2451Lisp_Object
2452make_uninit_string (EMACS_INT length)
2453{
2454 return make_clear_string (length, false);
2455}
2456
2532 2457
2533/* Return a multibyte Lisp_String set up to hold NCHARS characters 2458/* Return a multibyte Lisp_String set up to hold NCHARS characters
2534 which occupy NBYTES bytes. */ 2459 which occupy NBYTES bytes. If CLEARIT, clear its contents to null
2460 bytes; otherwise, the contents are uninitialized. */
2535 2461
2536Lisp_Object 2462static Lisp_Object
2537make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes) 2463make_clear_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes, bool clearit)
2538{ 2464{
2539 Lisp_Object string; 2465 Lisp_Object string;
2540 struct Lisp_String *s; 2466 struct Lisp_String *s;
@@ -2545,13 +2471,22 @@ make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes)
2545 return empty_multibyte_string; 2471 return empty_multibyte_string;
2546 2472
2547 s = allocate_string (); 2473 s = allocate_string ();
2548 s->intervals = NULL; 2474 s->u.s.intervals = NULL;
2549 allocate_string_data (s, nchars, nbytes); 2475 allocate_string_data (s, nchars, nbytes, clearit, false);
2550 XSETSTRING (string, s); 2476 XSETSTRING (string, s);
2551 string_chars_consed += nbytes; 2477 string_chars_consed += nbytes;
2552 return string; 2478 return string;
2553} 2479}
2554 2480
2481/* Return a multibyte Lisp_String set up to hold NCHARS characters
2482 which occupy NBYTES bytes. */
2483
2484Lisp_Object
2485make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes)
2486{
2487 return make_clear_multibyte_string (nchars, nbytes, false);
2488}
2489
2555/* Print arguments to BUF according to a FORMAT, then return 2490/* Print arguments to BUF according to a FORMAT, then return
2556 a Lisp_String initialized with the data from BUF. */ 2491 a Lisp_String initialized with the data from BUF. */
2557 2492
@@ -2567,6 +2502,29 @@ make_formatted_string (char *buf, const char *format, ...)
2567 return make_string (buf, length); 2502 return make_string (buf, length);
2568} 2503}
2569 2504
2505/* Pin a unibyte string in place so that it won't move during GC. */
2506void
2507pin_string (Lisp_Object string)
2508{
2509 eassert (STRINGP (string) && !STRING_MULTIBYTE (string));
2510 struct Lisp_String *s = XSTRING (string);
2511 ptrdiff_t size = STRING_BYTES (s);
2512 unsigned char *data = s->u.s.data;
2513
2514 if (!(size > LARGE_STRING_BYTES
2515 || PURE_P (data) || pdumper_object_p (data)
2516 || s->u.s.size_byte == -3))
2517 {
2518 eassert (s->u.s.size_byte == -1);
2519 sdata *old_sdata = SDATA_OF_STRING (s);
2520 allocate_string_data (s, size, size, false, true);
2521 memcpy (s->u.s.data, data, size);
2522 old_sdata->string = NULL;
2523 SDATA_NBYTES (old_sdata) = size;
2524 }
2525 s->u.s.size_byte = -3;
2526}
2527
2570 2528
2571/*********************************************************************** 2529/***********************************************************************
2572 Float Allocation 2530 Float Allocation
@@ -2597,7 +2555,8 @@ make_formatted_string (char *buf, const char *format, ...)
2597 &= ~((bits_word) 1 << ((n) % BITS_PER_BITS_WORD))) 2555 &= ~((bits_word) 1 << ((n) % BITS_PER_BITS_WORD)))
2598 2556
2599#define FLOAT_BLOCK(fptr) \ 2557#define FLOAT_BLOCK(fptr) \
2600 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1))) 2558 (eassert (!pdumper_object_p (fptr)), \
2559 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1))))
2601 2560
2602#define FLOAT_INDEX(fptr) \ 2561#define FLOAT_INDEX(fptr) \
2603 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float)) 2562 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
@@ -2610,13 +2569,13 @@ struct float_block
2610 struct float_block *next; 2569 struct float_block *next;
2611}; 2570};
2612 2571
2613#define FLOAT_MARKED_P(fptr) \ 2572#define XFLOAT_MARKED_P(fptr) \
2614 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr))) 2573 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2615 2574
2616#define FLOAT_MARK(fptr) \ 2575#define XFLOAT_MARK(fptr) \
2617 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr))) 2576 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2618 2577
2619#define FLOAT_UNMARK(fptr) \ 2578#define XFLOAT_UNMARK(fptr) \
2620 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr))) 2579 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2621 2580
2622/* Current float_block. */ 2581/* Current float_block. */
@@ -2642,8 +2601,6 @@ make_float (double float_value)
2642 2601
2643 if (float_free_list) 2602 if (float_free_list)
2644 { 2603 {
2645 /* We use the data field for chaining the free list
2646 so that we won't use the same field that has the mark bit. */
2647 XSETFLOAT (val, float_free_list); 2604 XSETFLOAT (val, float_free_list);
2648 float_free_list = float_free_list->u.chain; 2605 float_free_list = float_free_list->u.chain;
2649 } 2606 }
@@ -2657,7 +2614,6 @@ make_float (double float_value)
2657 memset (new->gcmarkbits, 0, sizeof new->gcmarkbits); 2614 memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
2658 float_block = new; 2615 float_block = new;
2659 float_block_index = 0; 2616 float_block_index = 0;
2660 total_free_floats += FLOAT_BLOCK_SIZE;
2661 } 2617 }
2662 XSETFLOAT (val, &float_block->floats[float_block_index]); 2618 XSETFLOAT (val, &float_block->floats[float_block_index]);
2663 float_block_index++; 2619 float_block_index++;
@@ -2666,10 +2622,9 @@ make_float (double float_value)
2666 MALLOC_UNBLOCK_INPUT; 2622 MALLOC_UNBLOCK_INPUT;
2667 2623
2668 XFLOAT_INIT (val, float_value); 2624 XFLOAT_INIT (val, float_value);
2669 eassert (!FLOAT_MARKED_P (XFLOAT (val))); 2625 eassert (!XFLOAT_MARKED_P (XFLOAT (val)));
2670 consing_since_gc += sizeof (struct Lisp_Float); 2626 tally_consing (sizeof (struct Lisp_Float));
2671 floats_consed++; 2627 floats_consed++;
2672 total_free_floats--;
2673 return val; 2628 return val;
2674} 2629}
2675 2630
@@ -2691,7 +2646,8 @@ make_float (double float_value)
2691 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1)) 2646 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2692 2647
2693#define CONS_BLOCK(fptr) \ 2648#define CONS_BLOCK(fptr) \
2694 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1))) 2649 (eassert (!pdumper_object_p (fptr)), \
2650 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1))))
2695 2651
2696#define CONS_INDEX(fptr) \ 2652#define CONS_INDEX(fptr) \
2697 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons)) 2653 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
@@ -2704,15 +2660,20 @@ struct cons_block
2704 struct cons_block *next; 2660 struct cons_block *next;
2705}; 2661};
2706 2662
2707#define CONS_MARKED_P(fptr) \ 2663#define XCONS_MARKED_P(fptr) \
2708 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr))) 2664 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2709 2665
2710#define CONS_MARK(fptr) \ 2666#define XMARK_CONS(fptr) \
2711 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr))) 2667 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2712 2668
2713#define CONS_UNMARK(fptr) \ 2669#define XUNMARK_CONS(fptr) \
2714 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr))) 2670 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2715 2671
2672/* Minimum number of bytes of consing since GC before next GC,
2673 when memory is full. */
2674
2675enum { memory_full_cons_threshold = sizeof (struct cons_block) };
2676
2716/* Current cons_block. */ 2677/* Current cons_block. */
2717 2678
2718static struct cons_block *cons_block; 2679static struct cons_block *cons_block;
@@ -2730,11 +2691,11 @@ static struct Lisp_Cons *cons_free_list;
2730void 2691void
2731free_cons (struct Lisp_Cons *ptr) 2692free_cons (struct Lisp_Cons *ptr)
2732{ 2693{
2733 ptr->u.chain = cons_free_list; 2694 ptr->u.s.u.chain = cons_free_list;
2734 ptr->car = Vdead; 2695 ptr->u.s.car = dead_object ();
2735 cons_free_list = ptr; 2696 cons_free_list = ptr;
2736 consing_since_gc -= sizeof *ptr; 2697 ptrdiff_t nbytes = sizeof *ptr;
2737 total_free_conses++; 2698 tally_consing (-nbytes);
2738} 2699}
2739 2700
2740DEFUN ("cons", Fcons, Scons, 2, 2, 0, 2701DEFUN ("cons", Fcons, Scons, 2, 2, 0,
@@ -2747,10 +2708,8 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
2747 2708
2748 if (cons_free_list) 2709 if (cons_free_list)
2749 { 2710 {
2750 /* We use the cdr for chaining the free list
2751 so that we won't use the same field that has the mark bit. */
2752 XSETCONS (val, cons_free_list); 2711 XSETCONS (val, cons_free_list);
2753 cons_free_list = cons_free_list->u.chain; 2712 cons_free_list = cons_free_list->u.s.u.chain;
2754 } 2713 }
2755 else 2714 else
2756 { 2715 {
@@ -2762,7 +2721,6 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
2762 new->next = cons_block; 2721 new->next = cons_block;
2763 cons_block = new; 2722 cons_block = new;
2764 cons_block_index = 0; 2723 cons_block_index = 0;
2765 total_free_conses += CONS_BLOCK_SIZE;
2766 } 2724 }
2767 XSETCONS (val, &cons_block->conses[cons_block_index]); 2725 XSETCONS (val, &cons_block->conses[cons_block_index]);
2768 cons_block_index++; 2726 cons_block_index++;
@@ -2772,25 +2730,12 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0,
2772 2730
2773 XSETCAR (val, car); 2731 XSETCAR (val, car);
2774 XSETCDR (val, cdr); 2732 XSETCDR (val, cdr);
2775 eassert (!CONS_MARKED_P (XCONS (val))); 2733 eassert (!XCONS_MARKED_P (XCONS (val)));
2776 consing_since_gc += sizeof (struct Lisp_Cons); 2734 consing_until_gc -= sizeof (struct Lisp_Cons);
2777 total_free_conses--;
2778 cons_cells_consed++; 2735 cons_cells_consed++;
2779 return val; 2736 return val;
2780} 2737}
2781 2738
2782#ifdef GC_CHECK_CONS_LIST
2783/* Get an error now if there's any junk in the cons free list. */
2784void
2785check_cons_list (void)
2786{
2787 struct Lisp_Cons *tail = cons_free_list;
2788
2789 while (tail)
2790 tail = tail->u.chain;
2791}
2792#endif
2793
2794/* Make a list of 1, 2, 3, 4 or 5 specified objects. */ 2739/* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2795 2740
2796Lisp_Object 2741Lisp_Object
@@ -2812,56 +2757,63 @@ list3 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
2812 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil))); 2757 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
2813} 2758}
2814 2759
2815
2816Lisp_Object 2760Lisp_Object
2817list4 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4) 2761list4 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4)
2818{ 2762{
2819 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil)))); 2763 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil))));
2820} 2764}
2821 2765
2822
2823Lisp_Object 2766Lisp_Object
2824list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5) 2767list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4,
2768 Lisp_Object arg5)
2825{ 2769{
2826 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, 2770 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
2827 Fcons (arg5, Qnil))))); 2771 Fcons (arg5, Qnil)))));
2828} 2772}
2829 2773
2830/* Make a list of COUNT Lisp_Objects, where ARG is the 2774/* Make a list of COUNT Lisp_Objects, where ARG is the first one.
2831 first one. Allocate conses from pure space if TYPE 2775 Use CONS to construct the pairs. AP has any remaining args. */
2832 is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */ 2776static Lisp_Object
2833 2777cons_listn (ptrdiff_t count, Lisp_Object arg,
2834Lisp_Object 2778 Lisp_Object (*cons) (Lisp_Object, Lisp_Object), va_list ap)
2835listn (enum constype type, ptrdiff_t count, Lisp_Object arg, ...)
2836{ 2779{
2837 Lisp_Object (*cons) (Lisp_Object, Lisp_Object);
2838 switch (type)
2839 {
2840 case CONSTYPE_PURE: cons = pure_cons; break;
2841 case CONSTYPE_HEAP: cons = Fcons; break;
2842 default: emacs_abort ();
2843 }
2844
2845 eassume (0 < count); 2780 eassume (0 < count);
2846 Lisp_Object val = cons (arg, Qnil); 2781 Lisp_Object val = cons (arg, Qnil);
2847 Lisp_Object tail = val; 2782 Lisp_Object tail = val;
2848
2849 va_list ap;
2850 va_start (ap, arg);
2851 for (ptrdiff_t i = 1; i < count; i++) 2783 for (ptrdiff_t i = 1; i < count; i++)
2852 { 2784 {
2853 Lisp_Object elem = cons (va_arg (ap, Lisp_Object), Qnil); 2785 Lisp_Object elem = cons (va_arg (ap, Lisp_Object), Qnil);
2854 XSETCDR (tail, elem); 2786 XSETCDR (tail, elem);
2855 tail = elem; 2787 tail = elem;
2856 } 2788 }
2789 return val;
2790}
2791
2792/* Make a list of COUNT Lisp_Objects, where ARG1 is the first one. */
2793Lisp_Object
2794listn (ptrdiff_t count, Lisp_Object arg1, ...)
2795{
2796 va_list ap;
2797 va_start (ap, arg1);
2798 Lisp_Object val = cons_listn (count, arg1, Fcons, ap);
2857 va_end (ap); 2799 va_end (ap);
2800 return val;
2801}
2858 2802
2803/* Make a pure list of COUNT Lisp_Objects, where ARG1 is the first one. */
2804Lisp_Object
2805pure_listn (ptrdiff_t count, Lisp_Object arg1, ...)
2806{
2807 va_list ap;
2808 va_start (ap, arg1);
2809 Lisp_Object val = cons_listn (count, arg1, pure_cons, ap);
2810 va_end (ap);
2859 return val; 2811 return val;
2860} 2812}
2861 2813
2862DEFUN ("list", Flist, Slist, 0, MANY, 0, 2814DEFUN ("list", Flist, Slist, 0, MANY, 0,
2863 doc: /* Return a newly created list with specified arguments as elements. 2815 doc: /* Return a newly created list with specified arguments as elements.
2864Any number of arguments, even zero arguments, are allowed. 2816Allows any number of arguments, including zero.
2865usage: (list &rest OBJECTS) */) 2817usage: (list &rest OBJECTS) */)
2866 (ptrdiff_t nargs, Lisp_Object *args) 2818 (ptrdiff_t nargs, Lisp_Object *args)
2867{ 2819{
@@ -2882,9 +2834,9 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
2882 (Lisp_Object length, Lisp_Object init) 2834 (Lisp_Object length, Lisp_Object init)
2883{ 2835{
2884 Lisp_Object val = Qnil; 2836 Lisp_Object val = Qnil;
2885 CHECK_NATNUM (length); 2837 CHECK_FIXNAT (length);
2886 2838
2887 for (EMACS_INT size = XFASTINT (length); 0 < size; size--) 2839 for (EMACS_INT size = XFIXNAT (length); 0 < size; size--)
2888 { 2840 {
2889 val = Fcons (init, val); 2841 val = Fcons (init, val);
2890 rarely_quit (size); 2842 rarely_quit (size);
@@ -2907,7 +2859,7 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
2907static struct Lisp_Vector * 2859static struct Lisp_Vector *
2908next_vector (struct Lisp_Vector *v) 2860next_vector (struct Lisp_Vector *v)
2909{ 2861{
2910 return XUNTAG (v->contents[0], Lisp_Int0); 2862 return XUNTAG (v->contents[0], Lisp_Int0, struct Lisp_Vector);
2911} 2863}
2912 2864
2913static void 2865static void
@@ -2920,17 +2872,10 @@ set_next_vector (struct Lisp_Vector *v, struct Lisp_Vector *p)
2920 for the most common cases; it's not required to be a power of two, but 2872 for the most common cases; it's not required to be a power of two, but
2921 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */ 2873 it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
2922 2874
2923#define VECTOR_BLOCK_SIZE 4096 2875enum { VECTOR_BLOCK_SIZE = 4096 };
2924 2876
2925enum 2877/* Vector size requests are a multiple of this. */
2926 { 2878enum { roundup_size = COMMON_MULTIPLE (LISP_ALIGNMENT, word_size) };
2927 /* Alignment of struct Lisp_Vector objects. */
2928 vector_alignment = COMMON_MULTIPLE (FLEXALIGNOF (struct Lisp_Vector),
2929 GCALIGNMENT),
2930
2931 /* Vector size requests are a multiple of this. */
2932 roundup_size = COMMON_MULTIPLE (vector_alignment, word_size)
2933 };
2934 2879
2935/* Verify assumptions described above. */ 2880/* Verify assumptions described above. */
2936verify (VECTOR_BLOCK_SIZE % roundup_size == 0); 2881verify (VECTOR_BLOCK_SIZE % roundup_size == 0);
@@ -2943,22 +2888,21 @@ verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS));
2943 2888
2944/* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */ 2889/* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
2945 2890
2946#define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *))) 2891enum {VECTOR_BLOCK_BYTES = VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *))};
2947 2892
2948/* Size of the minimal vector allocated from block. */ 2893/* Size of the minimal vector allocated from block. */
2949 2894
2950#define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object)) 2895enum { VBLOCK_BYTES_MIN = vroundup_ct (header_size + sizeof (Lisp_Object)) };
2951 2896
2952/* Size of the largest vector allocated from block. */ 2897/* Size of the largest vector allocated from block. */
2953 2898
2954#define VBLOCK_BYTES_MAX \ 2899enum { VBLOCK_BYTES_MAX = vroundup_ct ((VECTOR_BLOCK_BYTES / 2) - word_size) };
2955 vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
2956 2900
2957/* We maintain one free list for each possible block-allocated 2901/* We maintain one free list for each possible block-allocated
2958 vector size, and this is the number of free lists we have. */ 2902 vector size, and this is the number of free lists we have. */
2959 2903
2960#define VECTOR_MAX_FREE_LIST_INDEX \ 2904enum { VECTOR_MAX_FREE_LIST_INDEX =
2961 ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1) 2905 (VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1 };
2962 2906
2963/* Common shortcut to advance vector pointer over a block data. */ 2907/* Common shortcut to advance vector pointer over a block data. */
2964 2908
@@ -2997,7 +2941,7 @@ struct large_vector
2997 2941
2998enum 2942enum
2999{ 2943{
3000 large_vector_offset = ROUNDUP (sizeof (struct large_vector), vector_alignment) 2944 large_vector_offset = ROUNDUP (sizeof (struct large_vector), LISP_ALIGNMENT)
3001}; 2945};
3002 2946
3003static struct Lisp_Vector * 2947static struct Lisp_Vector *
@@ -3032,14 +2976,6 @@ static struct large_vector *large_vectors;
3032 2976
3033Lisp_Object zero_vector; 2977Lisp_Object zero_vector;
3034 2978
3035/* Number of live vectors. */
3036
3037static EMACS_INT total_vectors;
3038
3039/* Total size of live and free vectors, in Lisp_Object units. */
3040
3041static EMACS_INT total_vector_slots, total_free_vector_slots;
3042
3043/* Common shortcut to setup vector on a free list. */ 2979/* Common shortcut to setup vector on a free list. */
3044 2980
3045static void 2981static void
@@ -3053,7 +2989,6 @@ setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes)
3053 eassert (vindex < VECTOR_MAX_FREE_LIST_INDEX); 2989 eassert (vindex < VECTOR_MAX_FREE_LIST_INDEX);
3054 set_next_vector (v, vector_free_lists[vindex]); 2990 set_next_vector (v, vector_free_lists[vindex]);
3055 vector_free_lists[vindex] = v; 2991 vector_free_lists[vindex] = v;
3056 total_free_vector_slots += nbytes / word_size;
3057} 2992}
3058 2993
3059/* Get a new vector block. */ 2994/* Get a new vector block. */
@@ -3079,19 +3014,20 @@ static void
3079init_vectors (void) 3014init_vectors (void)
3080{ 3015{
3081 zero_vector = make_pure_vector (0); 3016 zero_vector = make_pure_vector (0);
3017 staticpro (&zero_vector);
3082} 3018}
3083 3019
3084/* Allocate vector from a vector block. */ 3020/* Allocate vector from a vector block. */
3085 3021
3086static struct Lisp_Vector * 3022static struct Lisp_Vector *
3087allocate_vector_from_block (size_t nbytes) 3023allocate_vector_from_block (ptrdiff_t nbytes)
3088{ 3024{
3089 struct Lisp_Vector *vector; 3025 struct Lisp_Vector *vector;
3090 struct vector_block *block; 3026 struct vector_block *block;
3091 size_t index, restbytes; 3027 size_t index, restbytes;
3092 3028
3093 eassert (VBLOCK_BYTES_MIN <= nbytes && nbytes <= VBLOCK_BYTES_MAX); 3029 eassume (VBLOCK_BYTES_MIN <= nbytes && nbytes <= VBLOCK_BYTES_MAX);
3094 eassert (nbytes % roundup_size == 0); 3030 eassume (nbytes % roundup_size == 0);
3095 3031
3096 /* First, try to allocate from a free list 3032 /* First, try to allocate from a free list
3097 containing vectors of the requested size. */ 3033 containing vectors of the requested size. */
@@ -3100,7 +3036,6 @@ allocate_vector_from_block (size_t nbytes)
3100 { 3036 {
3101 vector = vector_free_lists[index]; 3037 vector = vector_free_lists[index];
3102 vector_free_lists[index] = next_vector (vector); 3038 vector_free_lists[index] = next_vector (vector);
3103 total_free_vector_slots -= nbytes / word_size;
3104 return vector; 3039 return vector;
3105 } 3040 }
3106 3041
@@ -3114,7 +3049,6 @@ allocate_vector_from_block (size_t nbytes)
3114 /* This vector is larger than requested. */ 3049 /* This vector is larger than requested. */
3115 vector = vector_free_lists[index]; 3050 vector = vector_free_lists[index];
3116 vector_free_lists[index] = next_vector (vector); 3051 vector_free_lists[index] = next_vector (vector);
3117 total_free_vector_slots -= nbytes / word_size;
3118 3052
3119 /* Excess bytes are used for the smaller vector, 3053 /* Excess bytes are used for the smaller vector,
3120 which should be set on an appropriate free list. */ 3054 which should be set on an appropriate free list. */
@@ -3149,17 +3083,17 @@ allocate_vector_from_block (size_t nbytes)
3149 3083
3150/* Return the memory footprint of V in bytes. */ 3084/* Return the memory footprint of V in bytes. */
3151 3085
3152static ptrdiff_t 3086ptrdiff_t
3153vector_nbytes (struct Lisp_Vector *v) 3087vectorlike_nbytes (const union vectorlike_header *hdr)
3154{ 3088{
3155 ptrdiff_t size = v->header.size & ~ARRAY_MARK_FLAG; 3089 ptrdiff_t size = hdr->size & ~ARRAY_MARK_FLAG;
3156 ptrdiff_t nwords; 3090 ptrdiff_t nwords;
3157 3091
3158 if (size & PSEUDOVECTOR_FLAG) 3092 if (size & PSEUDOVECTOR_FLAG)
3159 { 3093 {
3160 if (PSEUDOVECTOR_TYPEP (&v->header, PVEC_BOOL_VECTOR)) 3094 if (PSEUDOVECTOR_TYPEP (hdr, PVEC_BOOL_VECTOR))
3161 { 3095 {
3162 struct Lisp_Bool_Vector *bv = (struct Lisp_Bool_Vector *) v; 3096 struct Lisp_Bool_Vector *bv = (struct Lisp_Bool_Vector *) hdr;
3163 ptrdiff_t word_bytes = (bool_vector_words (bv->size) 3097 ptrdiff_t word_bytes = (bool_vector_words (bv->size)
3164 * sizeof (bits_word)); 3098 * sizeof (bits_word));
3165 ptrdiff_t boolvec_bytes = bool_header_size + word_bytes; 3099 ptrdiff_t boolvec_bytes = bool_header_size + word_bytes;
@@ -3176,35 +3110,94 @@ vector_nbytes (struct Lisp_Vector *v)
3176 return vroundup (header_size + word_size * nwords); 3110 return vroundup (header_size + word_size * nwords);
3177} 3111}
3178 3112
3113/* Convert a pseudovector pointer P to its underlying struct T pointer.
3114 Verify that the struct is small, since cleanup_vector is called
3115 only on small vector-like objects. */
3116
3117#define PSEUDOVEC_STRUCT(p, t) \
3118 verify_expr ((header_size + VECSIZE (struct t) * word_size \
3119 <= VBLOCK_BYTES_MAX), \
3120 (struct t *) (p))
3121
3179/* Release extra resources still in use by VECTOR, which may be any 3122/* Release extra resources still in use by VECTOR, which may be any
3180 vector-like object. */ 3123 small vector-like object. */
3181 3124
3182static void 3125static void
3183cleanup_vector (struct Lisp_Vector *vector) 3126cleanup_vector (struct Lisp_Vector *vector)
3184{ 3127{
3185 detect_suspicious_free (vector); 3128 detect_suspicious_free (vector);
3186 if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FONT)
3187 && ((vector->header.size & PSEUDOVECTOR_SIZE_MASK)
3188 == FONT_OBJECT_MAX))
3189 {
3190 struct font_driver const *drv = ((struct font *) vector)->driver;
3191 3129
3192 /* The font driver might sometimes be NULL, e.g. if Emacs was 3130 if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_BIGNUM))
3193 interrupted before it had time to set it up. */ 3131 mpz_clear (PSEUDOVEC_STRUCT (vector, Lisp_Bignum)->value);
3194 if (drv) 3132 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_OVERLAY))
3133 {
3134 struct Lisp_Overlay *ol = PSEUDOVEC_STRUCT (vector, Lisp_Overlay);
3135 xfree (ol->interval);
3136 }
3137 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FINALIZER))
3138 unchain_finalizer (PSEUDOVEC_STRUCT (vector, Lisp_Finalizer));
3139 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FONT))
3140 {
3141 if ((vector->header.size & PSEUDOVECTOR_SIZE_MASK) == FONT_OBJECT_MAX)
3195 { 3142 {
3196 /* Attempt to catch subtle bugs like Bug#16140. */ 3143 struct font *font = PSEUDOVEC_STRUCT (vector, font);
3197 eassert (valid_font_driver (drv)); 3144 struct font_driver const *drv = font->driver;
3198 drv->close ((struct font *) vector); 3145
3146 /* The font driver might sometimes be NULL, e.g. if Emacs was
3147 interrupted before it had time to set it up. */
3148 if (drv)
3149 {
3150 /* Attempt to catch subtle bugs like Bug#16140. */
3151 eassert (valid_font_driver (drv));
3152 drv->close_font (font);
3153 }
3199 } 3154 }
3200 } 3155 }
3201 3156 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD))
3202 if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD)) 3157 finalize_one_thread (PSEUDOVEC_STRUCT (vector, thread_state));
3203 finalize_one_thread ((struct thread_state *) vector);
3204 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX)) 3158 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX))
3205 finalize_one_mutex ((struct Lisp_Mutex *) vector); 3159 finalize_one_mutex (PSEUDOVEC_STRUCT (vector, Lisp_Mutex));
3206 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR)) 3160 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR))
3207 finalize_one_condvar ((struct Lisp_CondVar *) vector); 3161 finalize_one_condvar (PSEUDOVEC_STRUCT (vector, Lisp_CondVar));
3162 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MARKER))
3163 {
3164 /* sweep_buffer should already have unchained this from its buffer. */
3165 eassert (! PSEUDOVEC_STRUCT (vector, Lisp_Marker)->buffer);
3166 }
3167 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_USER_PTR))
3168 {
3169 struct Lisp_User_Ptr *uptr = PSEUDOVEC_STRUCT (vector, Lisp_User_Ptr);
3170 if (uptr->finalizer)
3171 uptr->finalizer (uptr->p);
3172 }
3173#ifdef HAVE_MODULES
3174 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MODULE_FUNCTION))
3175 {
3176 ATTRIBUTE_MAY_ALIAS struct Lisp_Module_Function *function
3177 = (struct Lisp_Module_Function *) vector;
3178 module_finalize_function (function);
3179 }
3180#endif
3181#ifdef HAVE_NATIVE_COMP
3182 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_NATIVE_COMP_UNIT))
3183 {
3184 struct Lisp_Native_Comp_Unit *cu =
3185 PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit);
3186 unload_comp_unit (cu);
3187 }
3188 else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_SUBR))
3189 {
3190 struct Lisp_Subr *subr =
3191 PSEUDOVEC_STRUCT (vector, Lisp_Subr);
3192 if (!NILP (subr->native_comp_u))
3193 {
3194 /* FIXME Alternative and non invasive solution to this
3195 cast? */
3196 xfree ((char *)subr->symbol_name);
3197 xfree (subr->native_c_name);
3198 }
3199 }
3200#endif
3208} 3201}
3209 3202
3210/* Reclaim space used by unmarked vectors. */ 3203/* Reclaim space used by unmarked vectors. */
@@ -3217,48 +3210,43 @@ sweep_vectors (void)
3217 struct large_vector *lv, **lvprev = &large_vectors; 3210 struct large_vector *lv, **lvprev = &large_vectors;
3218 struct Lisp_Vector *vector, *next; 3211 struct Lisp_Vector *vector, *next;
3219 3212
3220 total_vectors = total_vector_slots = total_free_vector_slots = 0; 3213 gcstat.total_vectors = 0;
3214 gcstat.total_vector_slots = gcstat.total_free_vector_slots = 0;
3221 memset (vector_free_lists, 0, sizeof (vector_free_lists)); 3215 memset (vector_free_lists, 0, sizeof (vector_free_lists));
3222 3216
3223 /* Looking through vector blocks. */ 3217 /* Looking through vector blocks. */
3224 3218
3225 for (block = vector_blocks; block; block = *bprev) 3219 for (block = vector_blocks; block; block = *bprev)
3226 { 3220 {
3227 bool free_this_block = 0; 3221 bool free_this_block = false;
3228 ptrdiff_t nbytes;
3229 3222
3230 for (vector = (struct Lisp_Vector *) block->data; 3223 for (vector = (struct Lisp_Vector *) block->data;
3231 VECTOR_IN_BLOCK (vector, block); vector = next) 3224 VECTOR_IN_BLOCK (vector, block); vector = next)
3232 { 3225 {
3233 if (VECTOR_MARKED_P (vector)) 3226 if (XVECTOR_MARKED_P (vector))
3234 { 3227 {
3235 VECTOR_UNMARK (vector); 3228 XUNMARK_VECTOR (vector);
3236 total_vectors++; 3229 gcstat.total_vectors++;
3237 nbytes = vector_nbytes (vector); 3230 ptrdiff_t nbytes = vector_nbytes (vector);
3238 total_vector_slots += nbytes / word_size; 3231 gcstat.total_vector_slots += nbytes / word_size;
3239 next = ADVANCE (vector, nbytes); 3232 next = ADVANCE (vector, nbytes);
3240 } 3233 }
3241 else 3234 else
3242 { 3235 {
3243 ptrdiff_t total_bytes; 3236 ptrdiff_t total_bytes = 0;
3244
3245 cleanup_vector (vector);
3246 nbytes = vector_nbytes (vector);
3247 total_bytes = nbytes;
3248 next = ADVANCE (vector, nbytes);
3249 3237
3250 /* While NEXT is not marked, try to coalesce with VECTOR, 3238 /* While NEXT is not marked, try to coalesce with VECTOR,
3251 thus making VECTOR of the largest possible size. */ 3239 thus making VECTOR of the largest possible size. */
3252 3240
3253 while (VECTOR_IN_BLOCK (next, block)) 3241 next = vector;
3242 do
3254 { 3243 {
3255 if (VECTOR_MARKED_P (next))
3256 break;
3257 cleanup_vector (next); 3244 cleanup_vector (next);
3258 nbytes = vector_nbytes (next); 3245 ptrdiff_t nbytes = vector_nbytes (next);
3259 total_bytes += nbytes; 3246 total_bytes += nbytes;
3260 next = ADVANCE (next, nbytes); 3247 next = ADVANCE (next, nbytes);
3261 } 3248 }
3249 while (VECTOR_IN_BLOCK (next, block) && !vector_marked_p (next));
3262 3250
3263 eassert (total_bytes % roundup_size == 0); 3251 eassert (total_bytes % roundup_size == 0);
3264 3252
@@ -3266,9 +3254,12 @@ sweep_vectors (void)
3266 && !VECTOR_IN_BLOCK (next, block)) 3254 && !VECTOR_IN_BLOCK (next, block))
3267 /* This block should be freed because all of its 3255 /* This block should be freed because all of its
3268 space was coalesced into the only free vector. */ 3256 space was coalesced into the only free vector. */
3269 free_this_block = 1; 3257 free_this_block = true;
3270 else 3258 else
3271 setup_on_free_list (vector, total_bytes); 3259 {
3260 setup_on_free_list (vector, total_bytes);
3261 gcstat.total_free_vector_slots += total_bytes / word_size;
3262 }
3272 } 3263 }
3273 } 3264 }
3274 3265
@@ -3289,15 +3280,14 @@ sweep_vectors (void)
3289 for (lv = large_vectors; lv; lv = *lvprev) 3280 for (lv = large_vectors; lv; lv = *lvprev)
3290 { 3281 {
3291 vector = large_vector_vec (lv); 3282 vector = large_vector_vec (lv);
3292 if (VECTOR_MARKED_P (vector)) 3283 if (XVECTOR_MARKED_P (vector))
3293 { 3284 {
3294 VECTOR_UNMARK (vector); 3285 XUNMARK_VECTOR (vector);
3295 total_vectors++; 3286 gcstat.total_vectors++;
3296 if (vector->header.size & PSEUDOVECTOR_FLAG) 3287 gcstat.total_vector_slots
3297 total_vector_slots += vector_nbytes (vector) / word_size; 3288 += (vector->header.size & PSEUDOVECTOR_FLAG
3298 else 3289 ? vector_nbytes (vector) / word_size
3299 total_vector_slots 3290 : header_size / word_size + vector->header.size);
3300 += header_size / word_size + vector->header.size;
3301 lvprev = &lv->next; 3291 lvprev = &lv->next;
3302 } 3292 }
3303 else 3293 else
@@ -3308,51 +3298,58 @@ sweep_vectors (void)
3308 } 3298 }
3309} 3299}
3310 3300
3301/* Maximum number of elements in a vector. This is a macro so that it
3302 can be used in an integer constant expression. */
3303
3304#define VECTOR_ELTS_MAX \
3305 ((ptrdiff_t) \
3306 min (((min (PTRDIFF_MAX, SIZE_MAX) - header_size - large_vector_offset) \
3307 / word_size), \
3308 MOST_POSITIVE_FIXNUM))
3309
3311/* Value is a pointer to a newly allocated Lisp_Vector structure 3310/* Value is a pointer to a newly allocated Lisp_Vector structure
3312 with room for LEN Lisp_Objects. */ 3311 with room for LEN Lisp_Objects. LEN must be positive and
3312 at most VECTOR_ELTS_MAX. */
3313 3313
3314static struct Lisp_Vector * 3314static struct Lisp_Vector *
3315allocate_vectorlike (ptrdiff_t len) 3315allocate_vectorlike (ptrdiff_t len, bool clearit)
3316{ 3316{
3317 eassert (0 < len && len <= VECTOR_ELTS_MAX);
3318 ptrdiff_t nbytes = header_size + len * word_size;
3317 struct Lisp_Vector *p; 3319 struct Lisp_Vector *p;
3318 3320
3319 MALLOC_BLOCK_INPUT; 3321 MALLOC_BLOCK_INPUT;
3320 3322
3321 if (len == 0)
3322 p = XVECTOR (zero_vector);
3323 else
3324 {
3325 size_t nbytes = header_size + len * word_size;
3326
3327#ifdef DOUG_LEA_MALLOC 3323#ifdef DOUG_LEA_MALLOC
3328 if (!mmap_lisp_allowed_p ()) 3324 if (!mmap_lisp_allowed_p ())
3329 mallopt (M_MMAP_MAX, 0); 3325 mallopt (M_MMAP_MAX, 0);
3330#endif 3326#endif
3331 3327
3332 if (nbytes <= VBLOCK_BYTES_MAX) 3328 if (nbytes <= VBLOCK_BYTES_MAX)
3333 p = allocate_vector_from_block (vroundup (nbytes)); 3329 {
3334 else 3330 p = allocate_vector_from_block (vroundup (nbytes));
3335 { 3331 if (clearit)
3336 struct large_vector *lv 3332 memclear (p, nbytes);
3337 = lisp_malloc ((large_vector_offset + header_size 3333 }
3338 + len * word_size), 3334 else
3339 MEM_TYPE_VECTORLIKE); 3335 {
3340 lv->next = large_vectors; 3336 struct large_vector *lv = lisp_malloc (large_vector_offset + nbytes,
3341 large_vectors = lv; 3337 clearit, MEM_TYPE_VECTORLIKE);
3342 p = large_vector_vec (lv); 3338 lv->next = large_vectors;
3343 } 3339 large_vectors = lv;
3340 p = large_vector_vec (lv);
3341 }
3344 3342
3345#ifdef DOUG_LEA_MALLOC 3343#ifdef DOUG_LEA_MALLOC
3346 if (!mmap_lisp_allowed_p ()) 3344 if (!mmap_lisp_allowed_p ())
3347 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); 3345 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
3348#endif 3346#endif
3349 3347
3350 if (find_suspicious_object_in_range (p, (char *) p + nbytes)) 3348 if (find_suspicious_object_in_range (p, (char *) p + nbytes))
3351 emacs_abort (); 3349 emacs_abort ();
3352 3350
3353 consing_since_gc += nbytes; 3351 tally_consing (nbytes);
3354 vector_cells_consed += len; 3352 vector_cells_consed += len;
3355 }
3356 3353
3357 MALLOC_UNBLOCK_INPUT; 3354 MALLOC_UNBLOCK_INPUT;
3358 3355
@@ -3360,22 +3357,37 @@ allocate_vectorlike (ptrdiff_t len)
3360} 3357}
3361 3358
3362 3359
3363/* Allocate a vector with LEN slots. */ 3360/* Allocate a vector with LEN slots. If CLEARIT, clear its slots;
3361 otherwise the vector's slots are uninitialized. */
3364 3362
3365struct Lisp_Vector * 3363static struct Lisp_Vector *
3366allocate_vector (EMACS_INT len) 3364allocate_clear_vector (ptrdiff_t len, bool clearit)
3367{ 3365{
3368 struct Lisp_Vector *v; 3366 if (len == 0)
3369 ptrdiff_t nbytes_max = min (PTRDIFF_MAX, SIZE_MAX); 3367 return XVECTOR (zero_vector);
3370 3368 if (VECTOR_ELTS_MAX < len)
3371 if (min ((nbytes_max - header_size) / word_size, MOST_POSITIVE_FIXNUM) < len)
3372 memory_full (SIZE_MAX); 3369 memory_full (SIZE_MAX);
3373 v = allocate_vectorlike (len); 3370 struct Lisp_Vector *v = allocate_vectorlike (len, clearit);
3374 if (len) 3371 v->header.size = len;
3375 v->header.size = len;
3376 return v; 3372 return v;
3377} 3373}
3378 3374
3375/* Allocate a vector with LEN uninitialized slots. */
3376
3377struct Lisp_Vector *
3378allocate_vector (ptrdiff_t len)
3379{
3380 return allocate_clear_vector (len, false);
3381}
3382
3383/* Allocate a vector with LEN nil slots. */
3384
3385struct Lisp_Vector *
3386allocate_nil_vector (ptrdiff_t len)
3387{
3388 return allocate_clear_vector (len, true);
3389}
3390
3379 3391
3380/* Allocate other vector-like structures. */ 3392/* Allocate other vector-like structures. */
3381 3393
@@ -3383,14 +3395,16 @@ struct Lisp_Vector *
3383allocate_pseudovector (int memlen, int lisplen, 3395allocate_pseudovector (int memlen, int lisplen,
3384 int zerolen, enum pvec_type tag) 3396 int zerolen, enum pvec_type tag)
3385{ 3397{
3386 struct Lisp_Vector *v = allocate_vectorlike (memlen);
3387
3388 /* Catch bogus values. */ 3398 /* Catch bogus values. */
3399 enum { size_max = (1 << PSEUDOVECTOR_SIZE_BITS) - 1 };
3400 enum { rest_max = (1 << PSEUDOVECTOR_REST_BITS) - 1 };
3401 verify (size_max + rest_max <= VECTOR_ELTS_MAX);
3389 eassert (0 <= tag && tag <= PVEC_FONT); 3402 eassert (0 <= tag && tag <= PVEC_FONT);
3390 eassert (0 <= lisplen && lisplen <= zerolen && zerolen <= memlen); 3403 eassert (0 <= lisplen && lisplen <= zerolen && zerolen <= memlen);
3391 eassert (memlen - lisplen <= (1 << PSEUDOVECTOR_REST_BITS) - 1); 3404 eassert (lisplen <= size_max);
3392 eassert (lisplen <= PSEUDOVECTOR_SIZE_MASK); 3405 eassert (memlen <= size_max + rest_max);
3393 3406
3407 struct Lisp_Vector *v = allocate_vectorlike (memlen, false);
3394 /* Only the first LISPLEN slots will be traced normally by the GC. */ 3408 /* Only the first LISPLEN slots will be traced normally by the GC. */
3395 memclear (v->contents, zerolen * word_size); 3409 memclear (v->contents, zerolen * word_size);
3396 XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen); 3410 XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen);
@@ -3400,12 +3414,10 @@ allocate_pseudovector (int memlen, int lisplen,
3400struct buffer * 3414struct buffer *
3401allocate_buffer (void) 3415allocate_buffer (void)
3402{ 3416{
3403 struct buffer *b = lisp_malloc (sizeof *b, MEM_TYPE_BUFFER); 3417 struct buffer *b
3404 3418 = ALLOCATE_PSEUDOVECTOR (struct buffer, cursor_in_non_selected_windows_,
3419 PVEC_BUFFER);
3405 BUFFER_PVEC_INIT (b); 3420 BUFFER_PVEC_INIT (b);
3406 /* Put B on the chain of all buffers including killed ones. */
3407 b->next = all_buffers;
3408 all_buffers = b;
3409 /* Note that the rest fields of B are not initialized. */ 3421 /* Note that the rest fields of B are not initialized. */
3410 return b; 3422 return b;
3411} 3423}
@@ -3420,7 +3432,7 @@ allocate_record (EMACS_INT count)
3420 if (count > PSEUDOVECTOR_SIZE_MASK) 3432 if (count > PSEUDOVECTOR_SIZE_MASK)
3421 error ("Attempt to allocate a record of %"pI"d slots; max is %d", 3433 error ("Attempt to allocate a record of %"pI"d slots; max is %d",
3422 count, PSEUDOVECTOR_SIZE_MASK); 3434 count, PSEUDOVECTOR_SIZE_MASK);
3423 struct Lisp_Vector *p = allocate_vectorlike (count); 3435 struct Lisp_Vector *p = allocate_vectorlike (count, false);
3424 p->header.size = count; 3436 p->header.size = count;
3425 XSETPVECTYPE (p, PVEC_RECORD); 3437 XSETPVECTYPE (p, PVEC_RECORD);
3426 return p; 3438 return p;
@@ -3434,8 +3446,8 @@ symbol or a type descriptor. SLOTS is the number of non-type slots,
3434each initialized to INIT. */) 3446each initialized to INIT. */)
3435 (Lisp_Object type, Lisp_Object slots, Lisp_Object init) 3447 (Lisp_Object type, Lisp_Object slots, Lisp_Object init)
3436{ 3448{
3437 CHECK_NATNUM (slots); 3449 CHECK_FIXNAT (slots);
3438 EMACS_INT size = XFASTINT (slots) + 1; 3450 EMACS_INT size = XFIXNAT (slots) + 1;
3439 struct Lisp_Vector *p = allocate_record (size); 3451 struct Lisp_Vector *p = allocate_record (size);
3440 p->contents[0] = type; 3452 p->contents[0] = type;
3441 for (ptrdiff_t i = 1; i < size; i++) 3453 for (ptrdiff_t i = 1; i < size; i++)
@@ -3463,16 +3475,27 @@ DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
3463See also the function `vector'. */) 3475See also the function `vector'. */)
3464 (Lisp_Object length, Lisp_Object init) 3476 (Lisp_Object length, Lisp_Object init)
3465{ 3477{
3466 CHECK_NATNUM (length); 3478 CHECK_TYPE (FIXNATP (length) && XFIXNAT (length) <= PTRDIFF_MAX,
3467 struct Lisp_Vector *p = allocate_vector (XFASTINT (length)); 3479 Qwholenump, length);
3468 for (ptrdiff_t i = 0; i < XFASTINT (length); i++) 3480 return make_vector (XFIXNAT (length), init);
3469 p->contents[i] = init; 3481}
3482
3483/* Return a new vector of length LENGTH with each element being INIT. */
3484
3485Lisp_Object
3486make_vector (ptrdiff_t length, Lisp_Object init)
3487{
3488 bool clearit = NIL_IS_ZERO && NILP (init);
3489 struct Lisp_Vector *p = allocate_clear_vector (length, clearit);
3490 if (!clearit)
3491 for (ptrdiff_t i = 0; i < length; i++)
3492 p->contents[i] = init;
3470 return make_lisp_ptr (p, Lisp_Vectorlike); 3493 return make_lisp_ptr (p, Lisp_Vectorlike);
3471} 3494}
3472 3495
3473DEFUN ("vector", Fvector, Svector, 0, MANY, 0, 3496DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
3474 doc: /* Return a newly created vector with specified arguments as elements. 3497 doc: /* Return a newly created vector with specified arguments as elements.
3475Any number of arguments, even zero arguments, are allowed. 3498Allows any number of arguments, including zero.
3476usage: (vector &rest OBJECTS) */) 3499usage: (vector &rest OBJECTS) */)
3477 (ptrdiff_t nargs, Lisp_Object *args) 3500 (ptrdiff_t nargs, Lisp_Object *args)
3478{ 3501{
@@ -3482,23 +3505,6 @@ usage: (vector &rest OBJECTS) */)
3482 return val; 3505 return val;
3483} 3506}
3484 3507
3485void
3486make_byte_code (struct Lisp_Vector *v)
3487{
3488 /* Don't allow the global zero_vector to become a byte code object. */
3489 eassert (0 < v->header.size);
3490
3491 if (v->header.size > 1 && STRINGP (v->contents[1])
3492 && STRING_MULTIBYTE (v->contents[1]))
3493 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3494 earlier because they produced a raw 8-bit string for byte-code
3495 and now such a byte-code string is loaded as multibyte while
3496 raw 8-bit characters converted to multibyte form. Thus, now we
3497 must convert them back to the original unibyte form. */
3498 v->contents[1] = Fstring_as_unibyte (v->contents[1]);
3499 XSETPVECTYPE (v, PVEC_COMPILED);
3500}
3501
3502DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, 3508DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
3503 doc: /* Create a byte-code object with specified arguments as elements. 3509 doc: /* Create a byte-code object with specified arguments as elements.
3504The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant 3510The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
@@ -3517,8 +3523,16 @@ stack before executing the byte-code.
3517usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) 3523usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3518 (ptrdiff_t nargs, Lisp_Object *args) 3524 (ptrdiff_t nargs, Lisp_Object *args)
3519{ 3525{
3520 Lisp_Object val = make_uninit_vector (nargs); 3526 if (! ((FIXNUMP (args[COMPILED_ARGLIST])
3521 struct Lisp_Vector *p = XVECTOR (val); 3527 || CONSP (args[COMPILED_ARGLIST])
3528 || NILP (args[COMPILED_ARGLIST]))
3529 && STRINGP (args[COMPILED_BYTECODE])
3530 && !STRING_MULTIBYTE (args[COMPILED_BYTECODE])
3531 && VECTORP (args[COMPILED_CONSTANTS])
3532 && FIXNATP (args[COMPILED_STACK_DEPTH])))
3533 error ("Invalid byte-code object");
3534
3535 pin_string (args[COMPILED_BYTECODE]); // Bytecode must be immovable.
3522 3536
3523 /* We used to purecopy everything here, if purify-flag was set. This worked 3537 /* We used to purecopy everything here, if purify-flag was set. This worked
3524 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be 3538 OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
@@ -3527,40 +3541,60 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT
3527 copied into pure space, including its free variables, which is sometimes 3541 copied into pure space, including its free variables, which is sometimes
3528 just wasteful and other times plainly wrong (e.g. those free vars may want 3542 just wasteful and other times plainly wrong (e.g. those free vars may want
3529 to be setcar'd). */ 3543 to be setcar'd). */
3530 3544 Lisp_Object val = Fvector (nargs, args);
3531 memcpy (p->contents, args, nargs * sizeof *args); 3545 XSETPVECTYPE (XVECTOR (val), PVEC_COMPILED);
3532 make_byte_code (p);
3533 XSETCOMPILED (val, p);
3534 return val; 3546 return val;
3535} 3547}
3536 3548
3549DEFUN ("make-closure", Fmake_closure, Smake_closure, 1, MANY, 0,
3550 doc: /* Create a byte-code closure from PROTOTYPE and CLOSURE-VARS.
3551Return a copy of PROTOTYPE, a byte-code object, with CLOSURE-VARS
3552replacing the elements in the beginning of the constant-vector.
3553usage: (make-closure PROTOTYPE &rest CLOSURE-VARS) */)
3554 (ptrdiff_t nargs, Lisp_Object *args)
3555{
3556 Lisp_Object protofun = args[0];
3557 CHECK_TYPE (COMPILEDP (protofun), Qbyte_code_function_p, protofun);
3558
3559 /* Create a copy of the constant vector, filling it with the closure
3560 variables in the beginning. (The overwritten part should just
3561 contain placeholder values.) */
3562 Lisp_Object proto_constvec = AREF (protofun, COMPILED_CONSTANTS);
3563 ptrdiff_t constsize = ASIZE (proto_constvec);
3564 ptrdiff_t nvars = nargs - 1;
3565 if (nvars > constsize)
3566 error ("Closure vars do not fit in constvec");
3567 Lisp_Object constvec = make_uninit_vector (constsize);
3568 memcpy (XVECTOR (constvec)->contents, args + 1, nvars * word_size);
3569 memcpy (XVECTOR (constvec)->contents + nvars,
3570 XVECTOR (proto_constvec)->contents + nvars,
3571 (constsize - nvars) * word_size);
3572
3573 /* Return a copy of the prototype function with the new constant vector. */
3574 ptrdiff_t protosize = PVSIZE (protofun);
3575 struct Lisp_Vector *v = allocate_vectorlike (protosize, false);
3576 v->header = XVECTOR (protofun)->header;
3577 memcpy (v->contents, XVECTOR (protofun)->contents, protosize * word_size);
3578 v->contents[COMPILED_CONSTANTS] = constvec;
3579 return make_lisp_ptr (v, Lisp_Vectorlike);
3580}
3537 3581
3538 3582
3539/*********************************************************************** 3583/***********************************************************************
3540 Symbol Allocation 3584 Symbol Allocation
3541 ***********************************************************************/ 3585 ***********************************************************************/
3542 3586
3543/* Like struct Lisp_Symbol, but padded so that the size is a multiple
3544 of the required alignment. */
3545
3546union aligned_Lisp_Symbol
3547{
3548 struct Lisp_Symbol s;
3549 unsigned char c[(sizeof (struct Lisp_Symbol) + GCALIGNMENT - 1)
3550 & -GCALIGNMENT];
3551};
3552
3553/* Each symbol_block is just under 1020 bytes long, since malloc 3587/* Each symbol_block is just under 1020 bytes long, since malloc
3554 really allocates in units of powers of two and uses 4 bytes for its 3588 really allocates in units of powers of two and uses 4 bytes for its
3555 own overhead. */ 3589 own overhead. */
3556 3590
3557#define SYMBOL_BLOCK_SIZE \ 3591#define SYMBOL_BLOCK_SIZE \
3558 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol)) 3592 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
3559 3593
3560struct symbol_block 3594struct symbol_block
3561{ 3595{
3562 /* Place `symbols' first, to preserve alignment. */ 3596 /* Place `symbols' first, to preserve alignment. */
3563 union aligned_Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE]; 3597 struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
3564 struct symbol_block *next; 3598 struct symbol_block *next;
3565}; 3599};
3566 3600
@@ -3584,24 +3618,24 @@ static struct Lisp_Symbol *symbol_free_list;
3584static void 3618static void
3585set_symbol_name (Lisp_Object sym, Lisp_Object name) 3619set_symbol_name (Lisp_Object sym, Lisp_Object name)
3586{ 3620{
3587 XSYMBOL (sym)->name = name; 3621 XBARE_SYMBOL (sym)->u.s.name = name;
3588} 3622}
3589 3623
3590void 3624void
3591init_symbol (Lisp_Object val, Lisp_Object name) 3625init_symbol (Lisp_Object val, Lisp_Object name)
3592{ 3626{
3593 struct Lisp_Symbol *p = XSYMBOL (val); 3627 struct Lisp_Symbol *p = XBARE_SYMBOL (val);
3594 set_symbol_name (val, name); 3628 set_symbol_name (val, name);
3595 set_symbol_plist (val, Qnil); 3629 set_symbol_plist (val, Qnil);
3596 p->redirect = SYMBOL_PLAINVAL; 3630 p->u.s.redirect = SYMBOL_PLAINVAL;
3597 SET_SYMBOL_VAL (p, Qunbound); 3631 SET_SYMBOL_VAL (p, Qunbound);
3598 set_symbol_function (val, Qnil); 3632 set_symbol_function (val, Qnil);
3599 set_symbol_next (val, NULL); 3633 set_symbol_next (val, NULL);
3600 p->gcmarkbit = false; 3634 p->u.s.gcmarkbit = false;
3601 p->interned = SYMBOL_UNINTERNED; 3635 p->u.s.interned = SYMBOL_UNINTERNED;
3602 p->trapped_write = SYMBOL_UNTRAPPED_WRITE; 3636 p->u.s.trapped_write = SYMBOL_UNTRAPPED_WRITE;
3603 p->declared_special = false; 3637 p->u.s.declared_special = false;
3604 p->pinned = false; 3638 p->u.s.pinned = false;
3605} 3639}
3606 3640
3607DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, 3641DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
@@ -3618,255 +3652,88 @@ Its value is void, and its function definition and property list are nil. */)
3618 if (symbol_free_list) 3652 if (symbol_free_list)
3619 { 3653 {
3620 XSETSYMBOL (val, symbol_free_list); 3654 XSETSYMBOL (val, symbol_free_list);
3621 symbol_free_list = symbol_free_list->next; 3655 symbol_free_list = symbol_free_list->u.s.next;
3622 } 3656 }
3623 else 3657 else
3624 { 3658 {
3625 if (symbol_block_index == SYMBOL_BLOCK_SIZE) 3659 if (symbol_block_index == SYMBOL_BLOCK_SIZE)
3626 { 3660 {
3627 struct symbol_block *new 3661 struct symbol_block *new
3628 = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL); 3662 = lisp_malloc (sizeof *new, false, MEM_TYPE_SYMBOL);
3629 new->next = symbol_block; 3663 new->next = symbol_block;
3630 symbol_block = new; 3664 symbol_block = new;
3631 symbol_block_index = 0; 3665 symbol_block_index = 0;
3632 total_free_symbols += SYMBOL_BLOCK_SIZE;
3633 } 3666 }
3634 XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index].s); 3667 XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]);
3635 symbol_block_index++; 3668 symbol_block_index++;
3636 } 3669 }
3637 3670
3638 MALLOC_UNBLOCK_INPUT; 3671 MALLOC_UNBLOCK_INPUT;
3639 3672
3640 init_symbol (val, name); 3673 init_symbol (val, name);
3641 consing_since_gc += sizeof (struct Lisp_Symbol); 3674 tally_consing (sizeof (struct Lisp_Symbol));
3642 symbols_consed++; 3675 symbols_consed++;
3643 total_free_symbols--;
3644 return val; 3676 return val;
3645} 3677}
3646 3678
3647 3679
3648 3680
3649/***********************************************************************
3650 Marker (Misc) Allocation
3651 ***********************************************************************/
3652
3653/* Like union Lisp_Misc, but padded so that its size is a multiple of
3654 the required alignment. */
3655
3656union aligned_Lisp_Misc
3657{
3658 union Lisp_Misc m;
3659 unsigned char c[(sizeof (union Lisp_Misc) + GCALIGNMENT - 1)
3660 & -GCALIGNMENT];
3661};
3662
3663/* Allocation of markers and other objects that share that structure.
3664 Works like allocation of conses. */
3665
3666#define MARKER_BLOCK_SIZE \
3667 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3668
3669struct marker_block
3670{
3671 /* Place `markers' first, to preserve alignment. */
3672 union aligned_Lisp_Misc markers[MARKER_BLOCK_SIZE];
3673 struct marker_block *next;
3674};
3675
3676static struct marker_block *marker_block;
3677static int marker_block_index = MARKER_BLOCK_SIZE;
3678
3679static union Lisp_Misc *marker_free_list;
3680
3681/* Return a newly allocated Lisp_Misc object of specified TYPE. */
3682
3683static Lisp_Object
3684allocate_misc (enum Lisp_Misc_Type type)
3685{
3686 Lisp_Object val;
3687
3688 MALLOC_BLOCK_INPUT;
3689
3690 if (marker_free_list)
3691 {
3692 XSETMISC (val, marker_free_list);
3693 marker_free_list = marker_free_list->u_free.chain;
3694 }
3695 else
3696 {
3697 if (marker_block_index == MARKER_BLOCK_SIZE)
3698 {
3699 struct marker_block *new = lisp_malloc (sizeof *new, MEM_TYPE_MISC);
3700 new->next = marker_block;
3701 marker_block = new;
3702 marker_block_index = 0;
3703 total_free_markers += MARKER_BLOCK_SIZE;
3704 }
3705 XSETMISC (val, &marker_block->markers[marker_block_index].m);
3706 marker_block_index++;
3707 }
3708
3709 MALLOC_UNBLOCK_INPUT;
3710
3711 --total_free_markers;
3712 consing_since_gc += sizeof (union Lisp_Misc);
3713 misc_objects_consed++;
3714 XMISCANY (val)->type = type;
3715 XMISCANY (val)->gcmarkbit = 0;
3716 return val;
3717}
3718
3719/* Free a Lisp_Misc object. */
3720
3721void
3722free_misc (Lisp_Object misc)
3723{
3724 XMISCANY (misc)->type = Lisp_Misc_Free;
3725 XMISC (misc)->u_free.chain = marker_free_list;
3726 marker_free_list = XMISC (misc);
3727 consing_since_gc -= sizeof (union Lisp_Misc);
3728 total_free_markers++;
3729}
3730
3731/* Verify properties of Lisp_Save_Value's representation
3732 that are assumed here and elsewhere. */
3733
3734verify (SAVE_UNUSED == 0);
3735verify (((SAVE_INTEGER | SAVE_POINTER | SAVE_FUNCPOINTER | SAVE_OBJECT)
3736 >> SAVE_SLOT_BITS)
3737 == 0);
3738
3739/* Return Lisp_Save_Value objects for the various combinations
3740 that callers need. */
3741
3742Lisp_Object
3743make_save_int_int_int (ptrdiff_t a, ptrdiff_t b, ptrdiff_t c)
3744{
3745 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3746 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3747 p->save_type = SAVE_TYPE_INT_INT_INT;
3748 p->data[0].integer = a;
3749 p->data[1].integer = b;
3750 p->data[2].integer = c;
3751 return val;
3752}
3753
3754Lisp_Object
3755make_save_obj_obj_obj_obj (Lisp_Object a, Lisp_Object b, Lisp_Object c,
3756 Lisp_Object d)
3757{
3758 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3759 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3760 p->save_type = SAVE_TYPE_OBJ_OBJ_OBJ_OBJ;
3761 p->data[0].object = a;
3762 p->data[1].object = b;
3763 p->data[2].object = c;
3764 p->data[3].object = d;
3765 return val;
3766}
3767
3768Lisp_Object 3681Lisp_Object
3769make_save_ptr (void *a) 3682make_misc_ptr (void *a)
3770{ 3683{
3771 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); 3684 struct Lisp_Misc_Ptr *p = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Misc_Ptr,
3772 struct Lisp_Save_Value *p = XSAVE_VALUE (val); 3685 PVEC_MISC_PTR);
3773 p->save_type = SAVE_POINTER; 3686 p->pointer = a;
3774 p->data[0].pointer = a; 3687 return make_lisp_ptr (p, Lisp_Vectorlike);
3775 return val;
3776}
3777
3778Lisp_Object
3779make_save_ptr_int (void *a, ptrdiff_t b)
3780{
3781 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3782 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3783 p->save_type = SAVE_TYPE_PTR_INT;
3784 p->data[0].pointer = a;
3785 p->data[1].integer = b;
3786 return val;
3787} 3688}
3788 3689
3690/* Return a new symbol with position with the specified SYMBOL and POSITION. */
3789Lisp_Object 3691Lisp_Object
3790make_save_ptr_ptr (void *a, void *b) 3692build_symbol_with_pos (Lisp_Object symbol, Lisp_Object position)
3791{ 3693{
3792 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); 3694 Lisp_Object val;
3793 struct Lisp_Save_Value *p = XSAVE_VALUE (val); 3695 struct Lisp_Symbol_With_Pos *p
3794 p->save_type = SAVE_TYPE_PTR_PTR; 3696 = (struct Lisp_Symbol_With_Pos *) allocate_vector (2);
3795 p->data[0].pointer = a; 3697 XSETVECTOR (val, p);
3796 p->data[1].pointer = b; 3698 XSETPVECTYPESIZE (XVECTOR (val), PVEC_SYMBOL_WITH_POS, 2, 0);
3797 return val; 3699 p->sym = symbol;
3798} 3700 p->pos = position;
3799
3800Lisp_Object
3801make_save_funcptr_ptr_obj (void (*a) (void), void *b, Lisp_Object c)
3802{
3803 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3804 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3805 p->save_type = SAVE_TYPE_FUNCPTR_PTR_OBJ;
3806 p->data[0].funcpointer = a;
3807 p->data[1].pointer = b;
3808 p->data[2].object = c;
3809 return val;
3810}
3811
3812/* Return a Lisp_Save_Value object that represents an array A
3813 of N Lisp objects. */
3814 3701
3815Lisp_Object
3816make_save_memory (Lisp_Object *a, ptrdiff_t n)
3817{
3818 Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
3819 struct Lisp_Save_Value *p = XSAVE_VALUE (val);
3820 p->save_type = SAVE_TYPE_MEMORY;
3821 p->data[0].pointer = a;
3822 p->data[1].integer = n;
3823 return val; 3702 return val;
3824} 3703}
3825 3704
3826/* Free a Lisp_Save_Value object. Do not use this function 3705/* Return a new overlay with specified START, END and PLIST. */
3827 if SAVE contains pointer other than returned by xmalloc. */
3828
3829void
3830free_save_value (Lisp_Object save)
3831{
3832 xfree (XSAVE_POINTER (save, 0));
3833 free_misc (save);
3834}
3835
3836/* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
3837 3706
3838Lisp_Object 3707Lisp_Object
3839build_overlay (ptrdiff_t begin, ptrdiff_t end, 3708build_overlay (ptrdiff_t begin, ptrdiff_t end,
3840 bool front_advance, bool rear_advance, 3709 bool front_advance, bool rear_advance,
3841 Lisp_Object plist) 3710 Lisp_Object plist)
3842{ 3711{
3843 Lisp_Object ov = allocate_misc (Lisp_Misc_Overlay); 3712 struct Lisp_Overlay *p = ALLOCATE_PSEUDOVECTOR (struct Lisp_Overlay, plist,
3713 PVEC_OVERLAY);
3714 Lisp_Object overlay = make_lisp_ptr (p, Lisp_Vectorlike);
3844 struct interval_node *node = xmalloc (sizeof (*node)); 3715 struct interval_node *node = xmalloc (sizeof (*node));
3845
3846 interval_node_init (node, begin, end, front_advance, 3716 interval_node_init (node, begin, end, front_advance,
3847 rear_advance, ov); 3717 rear_advance, overlay);
3848 XOVERLAY (ov)->interval = node; 3718 p->interval = node;
3849 XOVERLAY (ov)->buffer = NULL; 3719 p->buffer = NULL;
3850 set_overlay_plist (ov, plist); 3720 set_overlay_plist (overlay, plist);
3851 return ov; 3721 return overlay;
3852} 3722}
3853 3723
3854DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, 3724DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
3855 doc: /* Return a newly allocated marker which does not point at any place. */) 3725 doc: /* Return a newly allocated marker which does not point at any place. */)
3856 (void) 3726 (void)
3857{ 3727{
3858 register Lisp_Object val; 3728 struct Lisp_Marker *p = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Marker,
3859 register struct Lisp_Marker *p; 3729 PVEC_MARKER);
3860
3861 val = allocate_misc (Lisp_Misc_Marker);
3862 p = XMARKER (val);
3863 p->buffer = 0; 3730 p->buffer = 0;
3864 p->bytepos = 0; 3731 p->bytepos = 0;
3865 p->charpos = 0; 3732 p->charpos = 0;
3866 p->next = NULL; 3733 p->next = NULL;
3867 p->insertion_type = 0; 3734 p->insertion_type = 0;
3868 p->need_adjustment = 0; 3735 p->need_adjustment = 0;
3869 return val; 3736 return make_lisp_ptr (p, Lisp_Vectorlike);
3870} 3737}
3871 3738
3872/* Return a newly allocated marker which points into BUF 3739/* Return a newly allocated marker which points into BUF
@@ -3875,17 +3742,14 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
3875Lisp_Object 3742Lisp_Object
3876build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos) 3743build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos)
3877{ 3744{
3878 Lisp_Object obj;
3879 struct Lisp_Marker *m;
3880
3881 /* No dead buffers here. */ 3745 /* No dead buffers here. */
3882 eassert (BUFFER_LIVE_P (buf)); 3746 eassert (BUFFER_LIVE_P (buf));
3883 3747
3884 /* Every character is at least one byte. */ 3748 /* Every character is at least one byte. */
3885 eassert (charpos <= bytepos); 3749 eassert (charpos <= bytepos);
3886 3750
3887 obj = allocate_misc (Lisp_Misc_Marker); 3751 struct Lisp_Marker *m = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Marker,
3888 m = XMARKER (obj); 3752 PVEC_MARKER);
3889 m->buffer = buf; 3753 m->buffer = buf;
3890 m->charpos = charpos; 3754 m->charpos = charpos;
3891 m->bytepos = bytepos; 3755 m->bytepos = bytepos;
@@ -3893,16 +3757,7 @@ build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos)
3893 m->need_adjustment = 0; 3757 m->need_adjustment = 0;
3894 m->next = BUF_MARKERS (buf); 3758 m->next = BUF_MARKERS (buf);
3895 BUF_MARKERS (buf) = m; 3759 BUF_MARKERS (buf) = m;
3896 return obj; 3760 return make_lisp_ptr (m, Lisp_Vectorlike);
3897}
3898
3899/* Put MARKER back on the free list after using it temporarily. */
3900
3901void
3902free_marker (Lisp_Object marker)
3903{
3904 unchain_marker (XMARKER (marker));
3905 free_misc (marker);
3906} 3761}
3907 3762
3908 3763
@@ -3910,7 +3765,7 @@ free_marker (Lisp_Object marker)
3910 elements. If all the arguments are characters that can fit 3765 elements. If all the arguments are characters that can fit
3911 in a string of events, make a string; otherwise, make a vector. 3766 in a string of events, make a string; otherwise, make a vector.
3912 3767
3913 Any number of arguments, even zero arguments, are allowed. */ 3768 Allows any number of arguments, including zero. */
3914 3769
3915Lisp_Object 3770Lisp_Object
3916make_event_array (ptrdiff_t nargs, Lisp_Object *args) 3771make_event_array (ptrdiff_t nargs, Lisp_Object *args)
@@ -3921,8 +3776,8 @@ make_event_array (ptrdiff_t nargs, Lisp_Object *args)
3921 /* The things that fit in a string 3776 /* The things that fit in a string
3922 are characters that are in 0...127, 3777 are characters that are in 0...127,
3923 after discarding the meta bit and all the bits above it. */ 3778 after discarding the meta bit and all the bits above it. */
3924 if (!INTEGERP (args[i]) 3779 if (!FIXNUMP (args[i])
3925 || (XINT (args[i]) & ~(-CHAR_META)) >= 0200) 3780 || (XFIXNUM (args[i]) & ~(-CHAR_META)) >= 0200)
3926 return Fvector (nargs, args); 3781 return Fvector (nargs, args);
3927 3782
3928 /* Since the loop exited, we know that all the things in it are 3783 /* Since the loop exited, we know that all the things in it are
@@ -3930,12 +3785,12 @@ make_event_array (ptrdiff_t nargs, Lisp_Object *args)
3930 { 3785 {
3931 Lisp_Object result; 3786 Lisp_Object result;
3932 3787
3933 result = Fmake_string (make_number (nargs), make_number (0)); 3788 result = Fmake_string (make_fixnum (nargs), make_fixnum (0), Qnil);
3934 for (i = 0; i < nargs; i++) 3789 for (i = 0; i < nargs; i++)
3935 { 3790 {
3936 SSET (result, i, XINT (args[i])); 3791 SSET (result, i, XFIXNUM (args[i]));
3937 /* Move the meta bit to the right place for a string char. */ 3792 /* Move the meta bit to the right place for a string char. */
3938 if (XINT (args[i]) & CHAR_META) 3793 if (XFIXNUM (args[i]) & CHAR_META)
3939 SSET (result, i, SREF (result, i) | 0x80); 3794 SSET (result, i, SREF (result, i) | 0x80);
3940 } 3795 }
3941 3796
@@ -3948,14 +3803,11 @@ make_event_array (ptrdiff_t nargs, Lisp_Object *args)
3948Lisp_Object 3803Lisp_Object
3949make_user_ptr (void (*finalizer) (void *), void *p) 3804make_user_ptr (void (*finalizer) (void *), void *p)
3950{ 3805{
3951 Lisp_Object obj; 3806 struct Lisp_User_Ptr *uptr
3952 struct Lisp_User_Ptr *uptr; 3807 = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_User_Ptr, PVEC_USER_PTR);
3953
3954 obj = allocate_misc (Lisp_Misc_User_Ptr);
3955 uptr = XUSER_PTR (obj);
3956 uptr->finalizer = finalizer; 3808 uptr->finalizer = finalizer;
3957 uptr->p = p; 3809 uptr->p = p;
3958 return obj; 3810 return make_lisp_ptr (uptr, Lisp_Vectorlike);
3959} 3811}
3960#endif 3812#endif
3961 3813
@@ -3998,7 +3850,7 @@ mark_finalizer_list (struct Lisp_Finalizer *head)
3998 finalizer != head; 3850 finalizer != head;
3999 finalizer = finalizer->next) 3851 finalizer = finalizer->next)
4000 { 3852 {
4001 finalizer->base.gcmarkbit = true; 3853 set_vectorlike_marked (&finalizer->header);
4002 mark_object (finalizer->function); 3854 mark_object (finalizer->function);
4003 } 3855 }
4004} 3856}
@@ -4015,7 +3867,8 @@ queue_doomed_finalizers (struct Lisp_Finalizer *dest,
4015 while (finalizer != src) 3867 while (finalizer != src)
4016 { 3868 {
4017 struct Lisp_Finalizer *next = finalizer->next; 3869 struct Lisp_Finalizer *next = finalizer->next;
4018 if (!finalizer->base.gcmarkbit && !NILP (finalizer->function)) 3870 if (!vectorlike_marked_p (&finalizer->header)
3871 && !NILP (finalizer->function))
4019 { 3872 {
4020 unchain_finalizer (finalizer); 3873 unchain_finalizer (finalizer);
4021 finalizer_insert (dest, finalizer); 3874 finalizer_insert (dest, finalizer);
@@ -4035,7 +3888,10 @@ run_finalizer_handler (Lisp_Object args)
4035static void 3888static void
4036run_finalizer_function (Lisp_Object function) 3889run_finalizer_function (Lisp_Object function)
4037{ 3890{
4038 ptrdiff_t count = SPECPDL_INDEX (); 3891 specpdl_ref count = SPECPDL_INDEX ();
3892#ifdef HAVE_PDUMPER
3893 ++number_finalizers_run;
3894#endif
4039 3895
4040 specbind (Qinhibit_quit, Qt); 3896 specbind (Qinhibit_quit, Qt);
4041 internal_condition_case_1 (call0, function, Qt, run_finalizer_handler); 3897 internal_condition_case_1 (call0, function, Qt, run_finalizer_handler);
@@ -4051,7 +3907,6 @@ run_finalizers (struct Lisp_Finalizer *finalizers)
4051 while (finalizers->next != finalizers) 3907 while (finalizers->next != finalizers)
4052 { 3908 {
4053 finalizer = finalizers->next; 3909 finalizer = finalizers->next;
4054 eassert (finalizer->base.type == Lisp_Misc_Finalizer);
4055 unchain_finalizer (finalizer); 3910 unchain_finalizer (finalizer);
4056 function = finalizer->function; 3911 function = finalizer->function;
4057 if (!NILP (function)) 3912 if (!NILP (function))
@@ -4071,12 +3926,133 @@ count as reachable for the purpose of deciding whether to run
4071FUNCTION. FUNCTION will be run once per finalizer object. */) 3926FUNCTION. FUNCTION will be run once per finalizer object. */)
4072 (Lisp_Object function) 3927 (Lisp_Object function)
4073{ 3928{
4074 Lisp_Object val = allocate_misc (Lisp_Misc_Finalizer); 3929 CHECK_TYPE (FUNCTIONP (function), Qfunctionp, function);
4075 struct Lisp_Finalizer *finalizer = XFINALIZER (val); 3930 struct Lisp_Finalizer *finalizer
3931 = ALLOCATE_PSEUDOVECTOR (struct Lisp_Finalizer, function, PVEC_FINALIZER);
4076 finalizer->function = function; 3932 finalizer->function = function;
4077 finalizer->prev = finalizer->next = NULL; 3933 finalizer->prev = finalizer->next = NULL;
4078 finalizer_insert (&finalizers, finalizer); 3934 finalizer_insert (&finalizers, finalizer);
4079 return val; 3935 return make_lisp_ptr (finalizer, Lisp_Vectorlike);
3936}
3937
3938
3939/************************************************************************
3940 Mark bit access functions
3941 ************************************************************************/
3942
3943/* With the rare exception of functions implementing block-based
3944 allocation of various types, you should not directly test or set GC
3945 mark bits on objects. Some objects might live in special memory
3946 regions (e.g., a dump image) and might store their mark bits
3947 elsewhere. */
3948
3949static bool
3950vector_marked_p (const struct Lisp_Vector *v)
3951{
3952 if (pdumper_object_p (v))
3953 {
3954 /* Look at cold_start first so that we don't have to fault in
3955 the vector header just to tell that it's a bool vector. */
3956 if (pdumper_cold_object_p (v))
3957 {
3958 eassert (PSEUDOVECTOR_TYPE (v) == PVEC_BOOL_VECTOR);
3959 return true;
3960 }
3961 return pdumper_marked_p (v);
3962 }
3963 return XVECTOR_MARKED_P (v);
3964}
3965
3966static void
3967set_vector_marked (struct Lisp_Vector *v)
3968{
3969 if (pdumper_object_p (v))
3970 {
3971 eassert (PSEUDOVECTOR_TYPE (v) != PVEC_BOOL_VECTOR);
3972 pdumper_set_marked (v);
3973 }
3974 else
3975 XMARK_VECTOR (v);
3976}
3977
3978static bool
3979vectorlike_marked_p (const union vectorlike_header *header)
3980{
3981 return vector_marked_p ((const struct Lisp_Vector *) header);
3982}
3983
3984static void
3985set_vectorlike_marked (union vectorlike_header *header)
3986{
3987 set_vector_marked ((struct Lisp_Vector *) header);
3988}
3989
3990static bool
3991cons_marked_p (const struct Lisp_Cons *c)
3992{
3993 return pdumper_object_p (c)
3994 ? pdumper_marked_p (c)
3995 : XCONS_MARKED_P (c);
3996}
3997
3998static void
3999set_cons_marked (struct Lisp_Cons *c)
4000{
4001 if (pdumper_object_p (c))
4002 pdumper_set_marked (c);
4003 else
4004 XMARK_CONS (c);
4005}
4006
4007static bool
4008string_marked_p (const struct Lisp_String *s)
4009{
4010 return pdumper_object_p (s)
4011 ? pdumper_marked_p (s)
4012 : XSTRING_MARKED_P (s);
4013}
4014
4015static void
4016set_string_marked (struct Lisp_String *s)
4017{
4018 if (pdumper_object_p (s))
4019 pdumper_set_marked (s);
4020 else
4021 XMARK_STRING (s);
4022}
4023
4024static bool
4025symbol_marked_p (const struct Lisp_Symbol *s)
4026{
4027 return pdumper_object_p (s)
4028 ? pdumper_marked_p (s)
4029 : s->u.s.gcmarkbit;
4030}
4031
4032static void
4033set_symbol_marked (struct Lisp_Symbol *s)
4034{
4035 if (pdumper_object_p (s))
4036 pdumper_set_marked (s);
4037 else
4038 s->u.s.gcmarkbit = true;
4039}
4040
4041static bool
4042interval_marked_p (INTERVAL i)
4043{
4044 return pdumper_object_p (i)
4045 ? pdumper_marked_p (i)
4046 : i->gcmarkbit;
4047}
4048
4049static void
4050set_interval_marked (INTERVAL i)
4051{
4052 if (pdumper_object_p (i))
4053 pdumper_set_marked (i);
4054 else
4055 i->gcmarkbit = true;
4080} 4056}
4081 4057
4082 4058
@@ -4095,8 +4071,11 @@ FUNCTION. FUNCTION will be run once per finalizer object. */)
4095void 4071void
4096memory_full (size_t nbytes) 4072memory_full (size_t nbytes)
4097{ 4073{
4074 if (!initialized)
4075 fatal ("memory exhausted");
4076
4098 /* Do not go into hysterics merely because a large request failed. */ 4077 /* Do not go into hysterics merely because a large request failed. */
4099 bool enough_free_memory = 0; 4078 bool enough_free_memory = false;
4100 if (SPARE_MEMORY < nbytes) 4079 if (SPARE_MEMORY < nbytes)
4101 { 4080 {
4102 void *p; 4081 void *p;
@@ -4106,21 +4085,18 @@ memory_full (size_t nbytes)
4106 if (p) 4085 if (p)
4107 { 4086 {
4108 free (p); 4087 free (p);
4109 enough_free_memory = 1; 4088 enough_free_memory = true;
4110 } 4089 }
4111 MALLOC_UNBLOCK_INPUT; 4090 MALLOC_UNBLOCK_INPUT;
4112 } 4091 }
4113 4092
4114 if (! enough_free_memory) 4093 if (! enough_free_memory)
4115 { 4094 {
4116 int i;
4117
4118 Vmemory_full = Qt; 4095 Vmemory_full = Qt;
4119 4096 consing_until_gc = min (consing_until_gc, memory_full_cons_threshold);
4120 memory_full_cons_threshold = sizeof (struct cons_block);
4121 4097
4122 /* The first time we get here, free the spare memory. */ 4098 /* The first time we get here, free the spare memory. */
4123 for (i = 0; i < ARRAYELTS (spare_memory); i++) 4099 for (int i = 0; i < ARRAYELTS (spare_memory); i++)
4124 if (spare_memory[i]) 4100 if (spare_memory[i])
4125 { 4101 {
4126 if (i == 0) 4102 if (i == 0)
@@ -4165,10 +4141,10 @@ refill_memory_reserve (void)
4165 MEM_TYPE_SPARE); 4141 MEM_TYPE_SPARE);
4166 if (spare_memory[5] == 0) 4142 if (spare_memory[5] == 0)
4167 spare_memory[5] = lisp_malloc (sizeof (struct string_block), 4143 spare_memory[5] = lisp_malloc (sizeof (struct string_block),
4168 MEM_TYPE_SPARE); 4144 false, MEM_TYPE_SPARE);
4169 if (spare_memory[6] == 0) 4145 if (spare_memory[6] == 0)
4170 spare_memory[6] = lisp_malloc (sizeof (struct string_block), 4146 spare_memory[6] = lisp_malloc (sizeof (struct string_block),
4171 MEM_TYPE_SPARE); 4147 false, MEM_TYPE_SPARE);
4172 if (spare_memory[0] && spare_memory[1] && spare_memory[5]) 4148 if (spare_memory[0] && spare_memory[1] && spare_memory[5])
4173 Vmemory_full = Qnil; 4149 Vmemory_full = Qnil;
4174#endif 4150#endif
@@ -4565,7 +4541,7 @@ mem_delete_fixup (struct mem_node *x)
4565 4541
4566 4542
4567/* If P is a pointer into a live Lisp string object on the heap, 4543/* If P is a pointer into a live Lisp string object on the heap,
4568 return the object. Otherwise, return nil. M is a pointer to the 4544 return the object's address. Otherwise, return NULL. M points to the
4569 mem_block for P. 4545 mem_block for P.
4570 4546
4571 This and other *_holding functions look for a pointer anywhere into 4547 This and other *_holding functions look for a pointer anywhere into
@@ -4573,379 +4549,370 @@ mem_delete_fixup (struct mem_node *x)
4573 because some compilers sometimes optimize away the latter. See 4549 because some compilers sometimes optimize away the latter. See
4574 Bug#28213. */ 4550 Bug#28213. */
4575 4551
4576static Lisp_Object 4552static struct Lisp_String *
4577live_string_holding (struct mem_node *m, void *p) 4553live_string_holding (struct mem_node *m, void *p)
4578{ 4554{
4579 if (m->type == MEM_TYPE_STRING) 4555 eassert (m->type == MEM_TYPE_STRING);
4580 { 4556 struct string_block *b = m->start;
4581 struct string_block *b = m->start; 4557 char *cp = p;
4582 char *cp = p; 4558 ptrdiff_t offset = cp - (char *) &b->strings[0];
4583 ptrdiff_t offset = cp - (char *) &b->strings[0];
4584 4559
4585 /* P must point into a Lisp_String structure, and it 4560 /* P must point into a Lisp_String structure, and it
4586 must not be on the free-list. */ 4561 must not be on the free-list. */
4587 if (0 <= offset && offset < STRING_BLOCK_SIZE * sizeof b->strings[0]) 4562 if (0 <= offset && offset < sizeof b->strings)
4563 {
4564 ptrdiff_t off = offset % sizeof b->strings[0];
4565 if (off == Lisp_String
4566 || off == 0
4567 || off == offsetof (struct Lisp_String, u.s.size_byte)
4568 || off == offsetof (struct Lisp_String, u.s.intervals)
4569 || off == offsetof (struct Lisp_String, u.s.data))
4588 { 4570 {
4589 struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0]; 4571 struct Lisp_String *s = p = cp -= off;
4590 if (s->data) 4572 if (s->u.s.data)
4591 return make_lisp_ptr (s, Lisp_String); 4573 return s;
4592 } 4574 }
4593 } 4575 }
4594 return Qnil; 4576 return NULL;
4595} 4577}
4596 4578
4597static bool 4579static bool
4598live_string_p (struct mem_node *m, void *p) 4580live_string_p (struct mem_node *m, void *p)
4599{ 4581{
4600 return !NILP (live_string_holding (m, p)); 4582 return live_string_holding (m, p) == p;
4601} 4583}
4602 4584
4603/* If P is a pointer into a live Lisp cons object on the heap, return 4585/* If P is a pointer into a live Lisp cons object on the heap, return
4604 the object. Otherwise, return nil. M is a pointer to the 4586 the object's address. Otherwise, return NULL. M points to the
4605 mem_block for P. */ 4587 mem_block for P. */
4606 4588
4607static Lisp_Object 4589static struct Lisp_Cons *
4608live_cons_holding (struct mem_node *m, void *p) 4590live_cons_holding (struct mem_node *m, void *p)
4609{ 4591{
4610 if (m->type == MEM_TYPE_CONS) 4592 eassert (m->type == MEM_TYPE_CONS);
4593 struct cons_block *b = m->start;
4594 char *cp = p;
4595 ptrdiff_t offset = cp - (char *) &b->conses[0];
4596
4597 /* P must point into a Lisp_Cons, not be
4598 one of the unused cells in the current cons block,
4599 and not be on the free-list. */
4600 if (0 <= offset && offset < sizeof b->conses
4601 && (b != cons_block
4602 || offset / sizeof b->conses[0] < cons_block_index))
4611 { 4603 {
4612 struct cons_block *b = m->start; 4604 ptrdiff_t off = offset % sizeof b->conses[0];
4613 char *cp = p; 4605 if (off == Lisp_Cons
4614 ptrdiff_t offset = cp - (char *) &b->conses[0]; 4606 || off == 0
4615 4607 || off == offsetof (struct Lisp_Cons, u.s.u.cdr))
4616 /* P must point into a Lisp_Cons, not be
4617 one of the unused cells in the current cons block,
4618 and not be on the free-list. */
4619 if (0 <= offset && offset < CONS_BLOCK_SIZE * sizeof b->conses[0]
4620 && (b != cons_block
4621 || offset / sizeof b->conses[0] < cons_block_index))
4622 { 4608 {
4623 struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0]; 4609 struct Lisp_Cons *s = p = cp -= off;
4624 if (!EQ (s->car, Vdead)) 4610 if (!deadp (s->u.s.car))
4625 return make_lisp_ptr (s, Lisp_Cons); 4611 return s;
4626 } 4612 }
4627 } 4613 }
4628 return Qnil; 4614 return NULL;
4629} 4615}
4630 4616
4631static bool 4617static bool
4632live_cons_p (struct mem_node *m, void *p) 4618live_cons_p (struct mem_node *m, void *p)
4633{ 4619{
4634 return !NILP (live_cons_holding (m, p)); 4620 return live_cons_holding (m, p) == p;
4635} 4621}
4636 4622
4637 4623
4638/* If P is a pointer into a live Lisp symbol object on the heap, 4624/* If P is a pointer into a live Lisp symbol object on the heap,
4639 return the object. Otherwise, return nil. M is a pointer to the 4625 return the object's address. Otherwise, return NULL. M points to the
4640 mem_block for P. */ 4626 mem_block for P. */
4641 4627
4642static Lisp_Object 4628static struct Lisp_Symbol *
4643live_symbol_holding (struct mem_node *m, void *p) 4629live_symbol_holding (struct mem_node *m, void *p)
4644{ 4630{
4645 if (m->type == MEM_TYPE_SYMBOL) 4631 eassert (m->type == MEM_TYPE_SYMBOL);
4632 struct symbol_block *b = m->start;
4633 char *cp = p;
4634 ptrdiff_t offset = cp - (char *) &b->symbols[0];
4635
4636 /* P must point into the Lisp_Symbol, not be
4637 one of the unused cells in the current symbol block,
4638 and not be on the free-list. */
4639 if (0 <= offset && offset < sizeof b->symbols
4640 && (b != symbol_block
4641 || offset / sizeof b->symbols[0] < symbol_block_index))
4646 { 4642 {
4647 struct symbol_block *b = m->start; 4643 ptrdiff_t off = offset % sizeof b->symbols[0];
4648 char *cp = p; 4644 if (off == Lisp_Symbol
4649 ptrdiff_t offset = cp - (char *) &b->symbols[0]; 4645
4650 4646 /* Plain '|| off == 0' would run afoul of GCC 10.2
4651 /* P must point into the Lisp_Symbol, not be 4647 -Wlogical-op, as Lisp_Symbol happens to be zero. */
4652 one of the unused cells in the current symbol block, 4648 || (Lisp_Symbol != 0 && off == 0)
4653 and not be on the free-list. */ 4649
4654 if (0 <= offset && offset < SYMBOL_BLOCK_SIZE * sizeof b->symbols[0] 4650 || off == offsetof (struct Lisp_Symbol, u.s.name)
4655 && (b != symbol_block 4651 || off == offsetof (struct Lisp_Symbol, u.s.val)
4656 || offset / sizeof b->symbols[0] < symbol_block_index)) 4652 || off == offsetof (struct Lisp_Symbol, u.s.function)
4653 || off == offsetof (struct Lisp_Symbol, u.s.plist)
4654 || off == offsetof (struct Lisp_Symbol, u.s.next))
4657 { 4655 {
4658 struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0]; 4656 struct Lisp_Symbol *s = p = cp -= off;
4659 if (!EQ (s->function, Vdead)) 4657 if (!deadp (s->u.s.function))
4660 return make_lisp_symbol (s); 4658 return s;
4661 } 4659 }
4662 } 4660 }
4663 return Qnil; 4661 return NULL;
4664} 4662}
4665 4663
4666static bool 4664static bool
4667live_symbol_p (struct mem_node *m, void *p) 4665live_symbol_p (struct mem_node *m, void *p)
4668{ 4666{
4669 return !NILP (live_symbol_holding (m, p)); 4667 return live_symbol_holding (m, p) == p;
4670} 4668}
4671 4669
4672 4670
4673/* Return true if P is a pointer to a live Lisp float on 4671/* If P is a (possibly-tagged) pointer to a live Lisp_Float on the
4674 the heap. M is a pointer to the mem_block for P. */ 4672 heap, return the address of the Lisp_Float. Otherwise, return NULL.
4673 M is a pointer to the mem_block for P. */
4675 4674
4676static bool 4675static struct Lisp_Float *
4677live_float_p (struct mem_node *m, void *p) 4676live_float_holding (struct mem_node *m, void *p)
4678{ 4677{
4679 if (m->type == MEM_TYPE_FLOAT) 4678 eassert (m->type == MEM_TYPE_FLOAT);
4680 { 4679 struct float_block *b = m->start;
4681 struct float_block *b = m->start; 4680 char *cp = p;
4682 char *cp = p; 4681 ptrdiff_t offset = cp - (char *) &b->floats[0];
4683 ptrdiff_t offset = cp - (char *) &b->floats[0];
4684
4685 /* P must point to the start of a Lisp_Float and not be
4686 one of the unused cells in the current float block. */
4687 return (offset >= 0
4688 && offset % sizeof b->floats[0] == 0
4689 && offset < (FLOAT_BLOCK_SIZE * sizeof b->floats[0])
4690 && (b != float_block
4691 || offset / sizeof b->floats[0] < float_block_index));
4692 }
4693 else
4694 return 0;
4695}
4696 4682
4697 4683 /* P must point to (or be a tagged pointer to) the start of a
4698/* If P is a pointer to a live Lisp Misc on the heap, return the object. 4684 Lisp_Float and not be one of the unused cells in the current
4699 Otherwise, return nil. M is a pointer to the mem_block for P. */ 4685 float block. */
4700 4686 if (0 <= offset && offset < sizeof b->floats)
4701static Lisp_Object
4702live_misc_holding (struct mem_node *m, void *p)
4703{
4704 if (m->type == MEM_TYPE_MISC)
4705 { 4687 {
4706 struct marker_block *b = m->start; 4688 int off = offset % sizeof b->floats[0];
4707 char *cp = p; 4689 if ((off == Lisp_Float || off == 0)
4708 ptrdiff_t offset = cp - (char *) &b->markers[0]; 4690 && (b != float_block
4709 4691 || offset / sizeof b->floats[0] < float_block_index))
4710 /* P must point into a Lisp_Misc, not be
4711 one of the unused cells in the current misc block,
4712 and not be on the free-list. */
4713 if (0 <= offset && offset < MARKER_BLOCK_SIZE * sizeof b->markers[0]
4714 && (b != marker_block
4715 || offset / sizeof b->markers[0] < marker_block_index))
4716 { 4692 {
4717 union Lisp_Misc *s = p = cp -= offset % sizeof b->markers[0]; 4693 p = cp - off;
4718 if (s->u_any.type != Lisp_Misc_Free) 4694 return p;
4719 return make_lisp_ptr (s, Lisp_Misc);
4720 } 4695 }
4721 } 4696 }
4722 return Qnil; 4697 return NULL;
4723} 4698}
4724 4699
4725static bool 4700static bool
4726live_misc_p (struct mem_node *m, void *p) 4701live_float_p (struct mem_node *m, void *p)
4727{ 4702{
4728 return !NILP (live_misc_holding (m, p)); 4703 return live_float_holding (m, p) == p;
4729} 4704}
4730 4705
4731/* If P is a pointer to a live vector-like object, return the object. 4706/* Return VECTOR if P points within it, NULL otherwise. */
4707
4708static struct Lisp_Vector *
4709live_vector_pointer (struct Lisp_Vector *vector, void *p)
4710{
4711 void *vvector = vector;
4712 char *cvector = vvector;
4713 char *cp = p;
4714 ptrdiff_t offset = cp - cvector;
4715 return ((offset == Lisp_Vectorlike
4716 || offset == 0
4717 || (sizeof vector->header <= offset
4718 && offset < vector_nbytes (vector)
4719 && (! (vector->header.size & PSEUDOVECTOR_FLAG)
4720 ? (offsetof (struct Lisp_Vector, contents) <= offset
4721 && (((offset - offsetof (struct Lisp_Vector, contents))
4722 % word_size)
4723 == 0))
4724 /* For non-bool-vector pseudovectors, treat any pointer
4725 past the header as valid since it's too much of a pain
4726 to write special-case code for every pseudovector. */
4727 : (! PSEUDOVECTOR_TYPEP (&vector->header, PVEC_BOOL_VECTOR)
4728 || offset == offsetof (struct Lisp_Bool_Vector, size)
4729 || (offsetof (struct Lisp_Bool_Vector, data) <= offset
4730 && (((offset
4731 - offsetof (struct Lisp_Bool_Vector, data))
4732 % sizeof (bits_word))
4733 == 0))))))
4734 ? vector : NULL);
4735}
4736
4737/* If P is a pointer to a live, large vector-like object, return the object.
4732 Otherwise, return nil. 4738 Otherwise, return nil.
4733 M is a pointer to the mem_block for P. */ 4739 M is a pointer to the mem_block for P. */
4734 4740
4735static Lisp_Object 4741static struct Lisp_Vector *
4736live_vector_holding (struct mem_node *m, void *p) 4742live_large_vector_holding (struct mem_node *m, void *p)
4737{
4738 struct Lisp_Vector *vp = p;
4739
4740 if (m->type == MEM_TYPE_VECTOR_BLOCK)
4741 {
4742 /* This memory node corresponds to a vector block. */
4743 struct vector_block *block = m->start;
4744 struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data;
4745
4746 /* P is in the block's allocation range. Scan the block
4747 up to P and see whether P points to the start of some
4748 vector which is not on a free list. FIXME: check whether
4749 some allocation patterns (probably a lot of short vectors)
4750 may cause a substantial overhead of this loop. */
4751 while (VECTOR_IN_BLOCK (vector, block) && vector <= vp)
4752 {
4753 struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector));
4754 if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE))
4755 return make_lisp_ptr (vector, Lisp_Vectorlike);
4756 vector = next;
4757 }
4758 }
4759 else if (m->type == MEM_TYPE_VECTORLIKE)
4760 {
4761 /* This memory node corresponds to a large vector. */
4762 struct Lisp_Vector *vector = large_vector_vec (m->start);
4763 struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector));
4764 if (vector <= vp && vp < next)
4765 return make_lisp_ptr (vector, Lisp_Vectorlike);
4766 }
4767 return Qnil;
4768}
4769
4770static bool
4771live_vector_p (struct mem_node *m, void *p)
4772{ 4743{
4773 return !NILP (live_vector_holding (m, p)); 4744 eassert (m->type == MEM_TYPE_VECTORLIKE);
4774} 4745 return live_vector_pointer (large_vector_vec (m->start), p);
4775
4776/* If P is a pointer into a live buffer, return the buffer.
4777 Otherwise, return nil. M is a pointer to the mem_block for P. */
4778
4779static Lisp_Object
4780live_buffer_holding (struct mem_node *m, void *p)
4781{
4782 /* P must point into the block, and the buffer
4783 must not have been killed. */
4784 if (m->type == MEM_TYPE_BUFFER)
4785 {
4786 struct buffer *b = m->start;
4787 char *cb = m->start;
4788 char *cp = p;
4789 ptrdiff_t offset = cp - cb;
4790 if (0 <= offset && offset < sizeof *b && !NILP (b->name_))
4791 {
4792 Lisp_Object obj;
4793 XSETBUFFER (obj, b);
4794 return obj;
4795 }
4796 }
4797 return Qnil;
4798} 4746}
4799 4747
4800static bool 4748static bool
4801live_buffer_p (struct mem_node *m, void *p) 4749live_large_vector_p (struct mem_node *m, void *p)
4802{ 4750{
4803 return !NILP (live_buffer_holding (m, p)); 4751 return live_large_vector_holding (m, p) == p;
4804} 4752}
4805 4753
4806/* Mark OBJ if we can prove it's a Lisp_Object. */ 4754/* If P is a pointer to a live, small vector-like object, return the object.
4755 Otherwise, return NULL.
4756 M is a pointer to the mem_block for P. */
4807 4757
4808static void 4758static struct Lisp_Vector *
4809mark_maybe_object (Lisp_Object obj) 4759live_small_vector_holding (struct mem_node *m, void *p)
4810{ 4760{
4811#if USE_VALGRIND 4761 eassert (m->type == MEM_TYPE_VECTOR_BLOCK);
4812 if (valgrind_p) 4762 struct Lisp_Vector *vp = p;
4813 VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj)); 4763 struct vector_block *block = m->start;
4814#endif 4764 struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data;
4815 4765
4816 if (INTEGERP (obj)) 4766 /* P is in the block's allocation range. Scan the block
4817 return; 4767 up to P and see whether P points to the start of some
4818 4768 vector which is not on a free list. FIXME: check whether
4819 void *po = XPNTR (obj); 4769 some allocation patterns (probably a lot of short vectors)
4820 struct mem_node *m = mem_find (po); 4770 may cause a substantial overhead of this loop. */
4821 4771 while (VECTOR_IN_BLOCK (vector, block) && vector <= vp)
4822 if (m != MEM_NIL)
4823 { 4772 {
4824 bool mark_p = false; 4773 struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector));
4825 4774 if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE))
4826 switch (XTYPE (obj)) 4775 return live_vector_pointer (vector, vp);
4827 { 4776 vector = next;
4828 case Lisp_String:
4829 mark_p = EQ (obj, live_string_holding (m, po));
4830 break;
4831
4832 case Lisp_Cons:
4833 mark_p = EQ (obj, live_cons_holding (m, po));
4834 break;
4835
4836 case Lisp_Symbol:
4837 mark_p = EQ (obj, live_symbol_holding (m, po));
4838 break;
4839
4840 case Lisp_Float:
4841 mark_p = live_float_p (m, po);
4842 break;
4843
4844 case Lisp_Vectorlike:
4845 mark_p = (EQ (obj, live_vector_holding (m, po))
4846 || EQ (obj, live_buffer_holding (m, po)));
4847 break;
4848
4849 case Lisp_Misc:
4850 mark_p = EQ (obj, live_misc_holding (m, po));
4851 break;
4852
4853 default:
4854 break;
4855 }
4856
4857 if (mark_p)
4858 mark_object (obj);
4859 } 4777 }
4778 return NULL;
4860} 4779}
4861 4780
4862/* Return true if P can point to Lisp data, and false otherwise.
4863 Symbols are implemented via offsets not pointers, but the offsets
4864 are also multiples of GCALIGNMENT. */
4865
4866static bool 4781static bool
4867maybe_lisp_pointer (void *p) 4782live_small_vector_p (struct mem_node *m, void *p)
4868{ 4783{
4869 return (uintptr_t) p % GCALIGNMENT == 0; 4784 return live_small_vector_holding (m, p) == p;
4870} 4785}
4871 4786
4872#ifndef HAVE_MODULES
4873enum { HAVE_MODULES = false };
4874#endif
4875
4876/* If P points to Lisp data, mark that as live if it isn't already 4787/* If P points to Lisp data, mark that as live if it isn't already
4877 marked. */ 4788 marked. */
4878 4789
4879static void 4790static void
4880mark_maybe_pointer (void *p) 4791mark_maybe_pointer (void *p, bool symbol_only)
4881{ 4792{
4882 struct mem_node *m; 4793 struct mem_node *m;
4883 4794
4884#if USE_VALGRIND 4795#if USE_VALGRIND
4885 if (valgrind_p) 4796 VALGRIND_MAKE_MEM_DEFINED (&p, sizeof (p));
4886 VALGRIND_MAKE_MEM_DEFINED (&p, sizeof (p));
4887#endif 4797#endif
4888 4798
4889 if (sizeof (Lisp_Object) == sizeof (void *) || !HAVE_MODULES) 4799 /* If the pointer is in the dump image and the dump has a record
4800 of the object starting at the place where the pointer points, we
4801 definitely have an object. If the pointer is in the dump image
4802 and the dump has no idea what the pointer is pointing at, we
4803 definitely _don't_ have an object. */
4804 if (pdumper_object_p (p))
4890 { 4805 {
4891 if (!maybe_lisp_pointer (p)) 4806 /* FIXME: This code assumes that every reachable pdumper object
4892 return; 4807 is addressed either by a pointer to the object start, or by
4893 } 4808 the same pointer with an LSB-style tag. This assumption
4894 else 4809 fails if a pdumper object is reachable only via machine
4895 { 4810 addresses of non-initial object components. Although such
4896 /* For the wide-int case, also mark emacs_value tagged pointers, 4811 addressing is rare in machine code generated by C compilers
4897 which can be generated by emacs-module.c's value_to_lisp. */ 4812 from Emacs source code, it can occur in some cases. To fix
4898 p = (void *) ((uintptr_t) p & ~(GCALIGNMENT - 1)); 4813 this problem, the pdumper code should grok non-initial
4814 addresses, as the non-pdumper code does. */
4815 uintptr_t mask = VALMASK & UINTPTR_MAX;
4816 uintptr_t masked_p = (uintptr_t) p & mask;
4817 void *po = (void *) masked_p;
4818 char *cp = p;
4819 char *cpo = po;
4820 /* Don't use pdumper_object_p_precise here! It doesn't check the
4821 tag bits. OBJ here might be complete garbage, so we need to
4822 verify both the pointer and the tag. */
4823 int type = pdumper_find_object_type (po);
4824 if (pdumper_valid_object_type_p (type)
4825 && (!USE_LSB_TAG || p == po || cp - cpo == type))
4826 {
4827 if (type == Lisp_Symbol)
4828 mark_object (make_lisp_symbol (po));
4829 else if (!symbol_only)
4830 mark_object (make_lisp_ptr (po, type));
4831 }
4832 return;
4899 } 4833 }
4900 4834
4901 m = mem_find (p); 4835 m = mem_find (p);
4902 if (m != MEM_NIL) 4836 if (m != MEM_NIL)
4903 { 4837 {
4904 Lisp_Object obj = Qnil; 4838 Lisp_Object obj;
4905 4839
4906 switch (m->type) 4840 switch (m->type)
4907 { 4841 {
4908 case MEM_TYPE_NON_LISP: 4842 case MEM_TYPE_NON_LISP:
4909 case MEM_TYPE_SPARE: 4843 case MEM_TYPE_SPARE:
4910 /* Nothing to do; not a pointer to Lisp memory. */ 4844 /* Nothing to do; not a pointer to Lisp memory. */
4911 break; 4845 return;
4912
4913 case MEM_TYPE_BUFFER:
4914 obj = live_buffer_holding (m, p);
4915 break;
4916 4846
4917 case MEM_TYPE_CONS: 4847 case MEM_TYPE_CONS:
4918 obj = live_cons_holding (m, p); 4848 {
4849 if (symbol_only)
4850 return;
4851 struct Lisp_Cons *h = live_cons_holding (m, p);
4852 if (!h)
4853 return;
4854 obj = make_lisp_ptr (h, Lisp_Cons);
4855 }
4919 break; 4856 break;
4920 4857
4921 case MEM_TYPE_STRING: 4858 case MEM_TYPE_STRING:
4922 obj = live_string_holding (m, p); 4859 {
4923 break; 4860 if (symbol_only)
4924 4861 return;
4925 case MEM_TYPE_MISC: 4862 struct Lisp_String *h = live_string_holding (m, p);
4926 obj = live_misc_holding (m, p); 4863 if (!h)
4864 return;
4865 obj = make_lisp_ptr (h, Lisp_String);
4866 }
4927 break; 4867 break;
4928 4868
4929 case MEM_TYPE_SYMBOL: 4869 case MEM_TYPE_SYMBOL:
4930 obj = live_symbol_holding (m, p); 4870 {
4871 struct Lisp_Symbol *h = live_symbol_holding (m, p);
4872 if (!h)
4873 return;
4874 obj = make_lisp_symbol (h);
4875 }
4931 break; 4876 break;
4932 4877
4933 case MEM_TYPE_FLOAT: 4878 case MEM_TYPE_FLOAT:
4934 if (live_float_p (m, p)) 4879 {
4935 obj = make_lisp_ptr (p, Lisp_Float); 4880 if (symbol_only)
4881 return;
4882 struct Lisp_Float *h = live_float_holding (m, p);
4883 if (!h)
4884 return;
4885 obj = make_lisp_ptr (h, Lisp_Float);
4886 }
4936 break; 4887 break;
4937 4888
4938 case MEM_TYPE_VECTORLIKE: 4889 case MEM_TYPE_VECTORLIKE:
4890 {
4891 if (symbol_only)
4892 return;
4893 struct Lisp_Vector *h = live_large_vector_holding (m, p);
4894 if (!h)
4895 return;
4896 obj = make_lisp_ptr (h, Lisp_Vectorlike);
4897 }
4898 break;
4899
4939 case MEM_TYPE_VECTOR_BLOCK: 4900 case MEM_TYPE_VECTOR_BLOCK:
4940 obj = live_vector_holding (m, p); 4901 {
4902 if (symbol_only)
4903 return;
4904 struct Lisp_Vector *h = live_small_vector_holding (m, p);
4905 if (!h)
4906 return;
4907 obj = make_lisp_ptr (h, Lisp_Vectorlike);
4908 }
4941 break; 4909 break;
4942 4910
4943 default: 4911 default:
4944 emacs_abort (); 4912 emacs_abort ();
4945 } 4913 }
4946 4914
4947 if (!NILP (obj)) 4915 mark_object (obj);
4948 mark_object (obj);
4949 } 4916 }
4950} 4917}
4951 4918
@@ -4955,19 +4922,19 @@ mark_maybe_pointer (void *p)
4955 miss objects if __alignof__ were used. */ 4922 miss objects if __alignof__ were used. */
4956#define GC_POINTER_ALIGNMENT alignof (void *) 4923#define GC_POINTER_ALIGNMENT alignof (void *)
4957 4924
4958/* Mark Lisp objects referenced from the address range START+OFFSET..END 4925/* Mark Lisp objects referenced from the address range START..END
4959 or END+OFFSET..START. */ 4926 or END..START. */
4960 4927
4961static void ATTRIBUTE_NO_SANITIZE_ADDRESS 4928void ATTRIBUTE_NO_SANITIZE_ADDRESS
4962mark_memory (void *start, void *end) 4929mark_memory (void const *start, void const *end)
4963{ 4930{
4964 char *pp; 4931 char const *pp;
4965 4932
4966 /* Make START the pointer to the start of the memory region, 4933 /* Make START the pointer to the start of the memory region,
4967 if it isn't already. */ 4934 if it isn't already. */
4968 if (end < start) 4935 if (end < start)
4969 { 4936 {
4970 void *tem = start; 4937 void const *tem = start;
4971 start = end; 4938 start = end;
4972 end = tem; 4939 end = tem;
4973 } 4940 }
@@ -4983,8 +4950,8 @@ mark_memory (void *start, void *end)
4983 { 4950 {
4984 Lisp_Object obj = build_string ("test"); 4951 Lisp_Object obj = build_string ("test");
4985 struct Lisp_String *s = XSTRING (obj); 4952 struct Lisp_String *s = XSTRING (obj);
4986 Fgarbage_collect (); 4953 garbage_collect ();
4987 fprintf (stderr, "test '%s'\n", s->data); 4954 fprintf (stderr, "test '%s'\n", s->u.s.data);
4988 return Qnil; 4955 return Qnil;
4989 } 4956 }
4990 4957
@@ -4992,10 +4959,19 @@ mark_memory (void *start, void *end)
4992 away. The only reference to the life string is through the 4959 away. The only reference to the life string is through the
4993 pointer `s'. */ 4960 pointer `s'. */
4994 4961
4995 for (pp = start; (void *) pp < end; pp += GC_POINTER_ALIGNMENT) 4962 for (pp = start; (void const *) pp < end; pp += GC_POINTER_ALIGNMENT)
4996 { 4963 {
4997 mark_maybe_pointer (*(void **) pp); 4964 void *p = *(void *const *) pp;
4998 mark_maybe_object (*(Lisp_Object *) pp); 4965 mark_maybe_pointer (p, false);
4966
4967 /* Unmask any struct Lisp_Symbol pointer that make_lisp_symbol
4968 previously disguised by adding the address of 'lispsym'.
4969 On a host with 32-bit pointers and 64-bit Lisp_Objects,
4970 a Lisp_Object might be split into registers saved into
4971 non-adjacent words and P might be the low-order word's value. */
4972 intptr_t ip;
4973 INT_ADD_WRAPV ((intptr_t) p, (intptr_t) lispsym, &ip);
4974 mark_maybe_pointer ((void *) ip, true);
4999 } 4975 }
5000} 4976}
5001 4977
@@ -5018,7 +4994,7 @@ marking. Emacs has determined that the method it uses to do the\n\
5018marking will likely work on your system, but this isn't sure.\n\ 4994marking will likely work on your system, but this isn't sure.\n\
5019\n\ 4995\n\
5020If you are a system-programmer, or can get the help of a local wizard\n\ 4996If you are a system-programmer, or can get the help of a local wizard\n\
5021who is, please take a look at the function mark_stack in alloc.c, and\n\ 4997who is, please take a look at the function mark_c_stack in alloc.c, and\n\
5022verify that the methods used are appropriate for your system.\n\ 4998verify that the methods used are appropriate for your system.\n\
5023\n\ 4999\n\
5024Please mail the result to <emacs-devel@gnu.org>.\n\ 5000Please mail the result to <emacs-devel@gnu.org>.\n\
@@ -5031,7 +5007,7 @@ marking. Emacs has determined that the default method it uses to do the\n\
5031marking will not work on your system. We will need a system-dependent\n\ 5007marking will not work on your system. We will need a system-dependent\n\
5032solution for your system.\n\ 5008solution for your system.\n\
5033\n\ 5009\n\
5034Please take a look at the function mark_stack in alloc.c, and\n\ 5010Please take a look at the function mark_c_stack in alloc.c, and\n\
5035try to find a way to make it work on your system.\n\ 5011try to find a way to make it work on your system.\n\
5036\n\ 5012\n\
5037Note that you may get false negatives, depending on the compiler.\n\ 5013Note that you may get false negatives, depending on the compiler.\n\
@@ -5076,10 +5052,10 @@ test_setjmp (void)
5076 taking place, or the setjmp just didn't save the register. */ 5052 taking place, or the setjmp just didn't save the register. */
5077 5053
5078 if (x == 1) 5054 if (x == 1)
5079 fprintf (stderr, SETJMP_WILL_LIKELY_WORK); 5055 fputs (SETJMP_WILL_LIKELY_WORK, stderr);
5080 else 5056 else
5081 { 5057 {
5082 fprintf (stderr, SETJMP_WILL_NOT_WORK); 5058 fputs (SETJMP_WILL_NOT_WORK, stderr);
5083 exit (1); 5059 exit (1);
5084 } 5060 }
5085 } 5061 }
@@ -5096,36 +5072,16 @@ test_setjmp (void)
5096 as a stack scan limit. */ 5072 as a stack scan limit. */
5097typedef union 5073typedef union
5098{ 5074{
5099 /* Align the stack top properly. Even if !HAVE___BUILTIN_UNWIND_INIT, 5075 /* Make sure stack_top and m_stack_bottom are properly aligned as GC
5100 jmp_buf may not be aligned enough on darwin-ppc64. */ 5076 expects. */
5101 max_align_t o; 5077 Lisp_Object o;
5078 void *p;
5102#ifndef HAVE___BUILTIN_UNWIND_INIT 5079#ifndef HAVE___BUILTIN_UNWIND_INIT
5103 sys_jmp_buf j; 5080 sys_jmp_buf j;
5104 char c; 5081 char c;
5105#endif 5082#endif
5106} stacktop_sentry; 5083} stacktop_sentry;
5107 5084
5108/* Force callee-saved registers and register windows onto the stack.
5109 Use the platform-defined __builtin_unwind_init if available,
5110 obviating the need for machine dependent methods. */
5111#ifndef HAVE___BUILTIN_UNWIND_INIT
5112# ifdef __sparc__
5113 /* This trick flushes the register windows so that all the state of
5114 the process is contained in the stack.
5115 FreeBSD does not have a ta 3 handler, so handle it specially.
5116 FIXME: Code in the Boehm GC suggests flushing (with 'flushrs') is
5117 needed on ia64 too. See mach_dep.c, where it also says inline
5118 assembler doesn't work with relevant proprietary compilers. */
5119# if defined __sparc64__ && defined __FreeBSD__
5120# define __builtin_unwind_init() asm ("flushw")
5121# else
5122# define __builtin_unwind_init() asm ("ta 3")
5123# endif
5124# else
5125# define __builtin_unwind_init() ((void) 0)
5126# endif
5127#endif
5128
5129/* Yield an address close enough to the top of the stack that the 5085/* Yield an address close enough to the top of the stack that the
5130 garbage collector need not scan above it. Callers should be 5086 garbage collector need not scan above it. Callers should be
5131 declared NO_INLINE. */ 5087 declared NO_INLINE. */
@@ -5136,18 +5092,16 @@ typedef union
5136#endif 5092#endif
5137 5093
5138/* Set *P to the address of the top of the stack. This must be a 5094/* Set *P to the address of the top of the stack. This must be a
5139 macro, not a function, so that it is executed in the caller’s 5095 macro, not a function, so that it is executed in the caller's
5140 environment. It is not inside a do-while so that its storage 5096 environment. It is not inside a do-while so that its storage
5141 survives the macro. Callers should be declared NO_INLINE. */ 5097 survives the macro. Callers should be declared NO_INLINE. */
5142#ifdef HAVE___BUILTIN_UNWIND_INIT 5098#ifdef HAVE___BUILTIN_UNWIND_INIT
5143# define SET_STACK_TOP_ADDRESS(p) \ 5099# define SET_STACK_TOP_ADDRESS(p) \
5144 stacktop_sentry sentry; \ 5100 stacktop_sentry sentry; \
5145 __builtin_unwind_init (); \
5146 *(p) = NEAR_STACK_TOP (&sentry) 5101 *(p) = NEAR_STACK_TOP (&sentry)
5147#else 5102#else
5148# define SET_STACK_TOP_ADDRESS(p) \ 5103# define SET_STACK_TOP_ADDRESS(p) \
5149 stacktop_sentry sentry; \ 5104 stacktop_sentry sentry; \
5150 __builtin_unwind_init (); \
5151 test_setjmp (); \ 5105 test_setjmp (); \
5152 sys_setjmp (sentry.j); \ 5106 sys_setjmp (sentry.j); \
5153 *(p) = NEAR_STACK_TOP (&sentry + (stack_bottom < &sentry.c)) 5107 *(p) = NEAR_STACK_TOP (&sentry + (stack_bottom < &sentry.c))
@@ -5163,16 +5117,14 @@ typedef union
5163 We have to mark Lisp objects in CPU registers that can hold local 5117 We have to mark Lisp objects in CPU registers that can hold local
5164 variables or are used to pass parameters. 5118 variables or are used to pass parameters.
5165 5119
5166 This code assumes that calling setjmp saves registers we need 5120 If __builtin_unwind_init is available, it should suffice to save
5121 registers.
5122
5123 Otherwise, assume that calling setjmp saves registers we need
5167 to see in a jmp_buf which itself lies on the stack. This doesn't 5124 to see in a jmp_buf which itself lies on the stack. This doesn't
5168 have to be true! It must be verified for each system, possibly 5125 have to be true! It must be verified for each system, possibly
5169 by taking a look at the source code of setjmp. 5126 by taking a look at the source code of setjmp.
5170 5127
5171 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
5172 can use it as a machine independent method to store all registers
5173 to the stack. In this case the macros described in the previous
5174 two paragraphs are not used.
5175
5176 Stack Layout 5128 Stack Layout
5177 5129
5178 Architectures differ in the way their processor stack is organized. 5130 Architectures differ in the way their processor stack is organized.
@@ -5197,7 +5149,7 @@ typedef union
5197 from the stack start. */ 5149 from the stack start. */
5198 5150
5199void 5151void
5200mark_stack (char *bottom, char *end) 5152mark_c_stack (char const *bottom, char const *end)
5201{ 5153{
5202 /* This assumes that the stack is a contiguous region in memory. If 5154 /* This assumes that the stack is a contiguous region in memory. If
5203 that's not the case, something has to be done here to iterate 5155 that's not the case, something has to be done here to iterate
@@ -5211,8 +5163,9 @@ mark_stack (char *bottom, char *end)
5211#endif 5163#endif
5212} 5164}
5213 5165
5214/* This is a trampoline function that flushes registers to the stack, 5166/* flush_stack_call_func is the trampoline function that flushes
5215 and then calls FUNC. ARG is passed through to FUNC verbatim. 5167 registers to the stack, and then calls FUNC. ARG is passed through
5168 to FUNC verbatim.
5216 5169
5217 This function must be called whenever Emacs is about to release the 5170 This function must be called whenever Emacs is about to release the
5218 global interpreter lock. This lets the garbage collector easily 5171 global interpreter lock. This lets the garbage collector easily
@@ -5220,10 +5173,23 @@ mark_stack (char *bottom, char *end)
5220 Lisp. 5173 Lisp.
5221 5174
5222 It is invalid to run any Lisp code or to allocate any GC memory 5175 It is invalid to run any Lisp code or to allocate any GC memory
5223 from FUNC. */ 5176 from FUNC.
5177
5178 Note: all register spilling is done in flush_stack_call_func before
5179 flush_stack_call_func1 is activated.
5180
5181 flush_stack_call_func1 is responsible for identifying the stack
5182 address range to be scanned. It *must* be carefully kept as
5183 noinline to make sure that registers has been spilled before it is
5184 called, otherwise given __builtin_frame_address (0) typically
5185 returns the frame pointer (base pointer) and not the stack pointer
5186 [1] GC will miss to scan callee-saved registers content
5187 (Bug#41357).
5188
5189 [1] <https://gcc.gnu.org/onlinedocs/gcc/Return-Address.html>. */
5224 5190
5225NO_INLINE void 5191NO_INLINE void
5226flush_stack_call_func (void (*func) (void *arg), void *arg) 5192flush_stack_call_func1 (void (*func) (void *arg), void *arg)
5227{ 5193{
5228 void *end; 5194 void *end;
5229 struct thread_state *self = current_thread; 5195 struct thread_state *self = current_thread;
@@ -5233,15 +5199,6 @@ flush_stack_call_func (void (*func) (void *arg), void *arg)
5233 eassert (current_thread == self); 5199 eassert (current_thread == self);
5234} 5200}
5235 5201
5236static bool
5237c_symbol_p (struct Lisp_Symbol *sym)
5238{
5239 char *lispsym_ptr = (char *) lispsym;
5240 char *sym_ptr = (char *) sym;
5241 ptrdiff_t lispsym_offset = sym_ptr - lispsym_ptr;
5242 return 0 <= lispsym_offset && lispsym_offset < sizeof lispsym;
5243}
5244
5245/* Determine whether it is safe to access memory at address P. */ 5202/* Determine whether it is safe to access memory at address P. */
5246static int 5203static int
5247valid_pointer_p (void *p) 5204valid_pointer_p (void *p)
@@ -5254,6 +5211,12 @@ valid_pointer_p (void *p)
5254 return p ? -1 : 0; 5211 return p ? -1 : 0;
5255 5212
5256 int fd[2]; 5213 int fd[2];
5214 static int under_rr_state;
5215
5216 if (!under_rr_state)
5217 under_rr_state = getenv ("RUNNING_UNDER_RR") ? -1 : 1;
5218 if (under_rr_state < 0)
5219 return under_rr_state;
5257 5220
5258 /* Obviously, we cannot just access it (we would SEGV trying), so we 5221 /* Obviously, we cannot just access it (we would SEGV trying), so we
5259 trick the o/s to tell us whether p is a valid pointer. 5222 trick the o/s to tell us whether p is a valid pointer.
@@ -5274,27 +5237,28 @@ valid_pointer_p (void *p)
5274 5237
5275/* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a 5238/* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
5276 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we 5239 valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
5277 cannot validate OBJ. This function can be quite slow, so its primary 5240 cannot validate OBJ. This function can be quite slow, and is used
5278 use is the manual debugging. The only exception is print_object, where 5241 only in debugging. */
5279 we use it to check whether the memory referenced by the pointer of
5280 Lisp_Save_Value object contains valid objects. */
5281 5242
5282int 5243int
5283valid_lisp_object_p (Lisp_Object obj) 5244valid_lisp_object_p (Lisp_Object obj)
5284{ 5245{
5285 if (INTEGERP (obj)) 5246 if (FIXNUMP (obj))
5286 return 1; 5247 return 1;
5287 5248
5288 void *p = XPNTR (obj); 5249 void *p = XPNTR (obj);
5289 if (PURE_P (p)) 5250 if (PURE_P (p))
5290 return 1; 5251 return 1;
5291 5252
5292 if (SYMBOLP (obj) && c_symbol_p (p)) 5253 if (BARE_SYMBOL_P (obj) && c_symbol_p (p))
5293 return ((char *) p - (char *) lispsym) % sizeof lispsym[0] == 0; 5254 return ((char *) p - (char *) lispsym) % sizeof lispsym[0] == 0;
5294 5255
5295 if (p == &buffer_defaults || p == &buffer_local_symbols) 5256 if (p == &buffer_defaults || p == &buffer_local_symbols)
5296 return 2; 5257 return 2;
5297 5258
5259 if (pdumper_object_p (p))
5260 return pdumper_object_p_precise (p) ? 1 : 0;
5261
5298 struct mem_node *m = mem_find (p); 5262 struct mem_node *m = mem_find (p);
5299 5263
5300 if (m == MEM_NIL) 5264 if (m == MEM_NIL)
@@ -5315,18 +5279,12 @@ valid_lisp_object_p (Lisp_Object obj)
5315 case MEM_TYPE_SPARE: 5279 case MEM_TYPE_SPARE:
5316 return 0; 5280 return 0;
5317 5281
5318 case MEM_TYPE_BUFFER:
5319 return live_buffer_p (m, p) ? 1 : 2;
5320
5321 case MEM_TYPE_CONS: 5282 case MEM_TYPE_CONS:
5322 return live_cons_p (m, p); 5283 return live_cons_p (m, p);
5323 5284
5324 case MEM_TYPE_STRING: 5285 case MEM_TYPE_STRING:
5325 return live_string_p (m, p); 5286 return live_string_p (m, p);
5326 5287
5327 case MEM_TYPE_MISC:
5328 return live_misc_p (m, p);
5329
5330 case MEM_TYPE_SYMBOL: 5288 case MEM_TYPE_SYMBOL:
5331 return live_symbol_p (m, p); 5289 return live_symbol_p (m, p);
5332 5290
@@ -5334,8 +5292,10 @@ valid_lisp_object_p (Lisp_Object obj)
5334 return live_float_p (m, p); 5292 return live_float_p (m, p);
5335 5293
5336 case MEM_TYPE_VECTORLIKE: 5294 case MEM_TYPE_VECTORLIKE:
5295 return live_large_vector_p (m, p);
5296
5337 case MEM_TYPE_VECTOR_BLOCK: 5297 case MEM_TYPE_VECTOR_BLOCK:
5338 return live_vector_p (m, p); 5298 return live_small_vector_p (m, p);
5339 5299
5340 default: 5300 default:
5341 break; 5301 break;
@@ -5350,59 +5310,77 @@ valid_lisp_object_p (Lisp_Object obj)
5350 5310
5351/* Allocate room for SIZE bytes from pure Lisp storage and return a 5311/* Allocate room for SIZE bytes from pure Lisp storage and return a
5352 pointer to it. TYPE is the Lisp type for which the memory is 5312 pointer to it. TYPE is the Lisp type for which the memory is
5353 allocated. TYPE < 0 means it's not used for a Lisp object. */ 5313 allocated. TYPE < 0 means it's not used for a Lisp object,
5314 and that the result should have an alignment of -TYPE.
5315
5316 The bytes are initially zero.
5317
5318 If pure space is exhausted, allocate space from the heap. This is
5319 merely an expedient to let Emacs warn that pure space was exhausted
5320 and that Emacs should be rebuilt with a larger pure space. */
5354 5321
5355static void * 5322static void *
5356pure_alloc (size_t size, int type) 5323pure_alloc (size_t size, int type)
5357{ 5324{
5358 void *result; 5325 void *result;
5326 static bool pure_overflow_warned = false;
5359 5327
5360 again: 5328 again:
5361 if (type >= 0) 5329 if (type >= 0)
5362 { 5330 {
5363 /* Allocate space for a Lisp object from the beginning of the free 5331 /* Allocate space for a Lisp object from the beginning of the free
5364 space with taking account of alignment. */ 5332 space with taking account of alignment. */
5365 result = pointer_align (purebeg + pure_bytes_used_lisp, GCALIGNMENT); 5333 result = pointer_align (purebeg + pure_bytes_used_lisp, LISP_ALIGNMENT);
5366 pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size; 5334 pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size;
5367 } 5335 }
5368 else 5336 else
5369 { 5337 {
5370 /* Allocate space for a non-Lisp object from the end of the free 5338 /* Allocate space for a non-Lisp object from the end of the free
5371 space. */ 5339 space. */
5372 pure_bytes_used_non_lisp += size; 5340 ptrdiff_t unaligned_non_lisp = pure_bytes_used_non_lisp + size;
5373 result = purebeg + pure_size - pure_bytes_used_non_lisp; 5341 char *unaligned = purebeg + pure_size - unaligned_non_lisp;
5342 int decr = (intptr_t) unaligned & (-1 - type);
5343 pure_bytes_used_non_lisp = unaligned_non_lisp + decr;
5344 result = unaligned - decr;
5374 } 5345 }
5375 pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp; 5346 pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp;
5376 5347
5377 if (pure_bytes_used <= pure_size) 5348 if (pure_bytes_used <= pure_size)
5378 return result; 5349 return result;
5379 5350
5351 if (!pure_overflow_warned)
5352 {
5353 message ("Pure Lisp storage overflowed");
5354 pure_overflow_warned = true;
5355 }
5356
5380 /* Don't allocate a large amount here, 5357 /* Don't allocate a large amount here,
5381 because it might get mmap'd and then its address 5358 because it might get mmap'd and then its address
5382 might not be usable. */ 5359 might not be usable. */
5383 purebeg = xmalloc (10000); 5360 int small_amount = 10000;
5384 pure_size = 10000; 5361 eassert (size <= small_amount - LISP_ALIGNMENT);
5362 purebeg = xzalloc (small_amount);
5363 pure_size = small_amount;
5385 pure_bytes_used_before_overflow += pure_bytes_used - size; 5364 pure_bytes_used_before_overflow += pure_bytes_used - size;
5386 pure_bytes_used = 0; 5365 pure_bytes_used = 0;
5387 pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0; 5366 pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
5367
5368 /* Can't GC if pure storage overflowed because we can't determine
5369 if something is a pure object or not. */
5370 garbage_collection_inhibited++;
5388 goto again; 5371 goto again;
5389} 5372}
5390 5373
5391
5392#ifndef CANNOT_DUMP
5393
5394/* Print a warning if PURESIZE is too small. */ 5374/* Print a warning if PURESIZE is too small. */
5395 5375
5396void 5376void
5397check_pure_size (void) 5377check_pure_size (void)
5398{ 5378{
5399 if (pure_bytes_used_before_overflow) 5379 if (pure_bytes_used_before_overflow)
5400 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI"d" 5380 message (("emacs:0:Pure Lisp storage overflow (approx. %jd"
5401 " bytes needed)"), 5381 " bytes needed)"),
5402 pure_bytes_used + pure_bytes_used_before_overflow); 5382 pure_bytes_used + pure_bytes_used_before_overflow);
5403} 5383}
5404#endif
5405
5406 5384
5407/* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from 5385/* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
5408 the non-Lisp data pool of the pure storage, and return its start 5386 the non-Lisp data pool of the pure storage, and return its start
@@ -5484,16 +5462,16 @@ make_pure_string (const char *data,
5484{ 5462{
5485 Lisp_Object string; 5463 Lisp_Object string;
5486 struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String); 5464 struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String);
5487 s->data = (unsigned char *) find_string_data_in_pure (data, nbytes); 5465 s->u.s.data = (unsigned char *) find_string_data_in_pure (data, nbytes);
5488 if (s->data == NULL) 5466 if (s->u.s.data == NULL)
5489 { 5467 {
5490 s->data = pure_alloc (nbytes + 1, -1); 5468 s->u.s.data = pure_alloc (nbytes + 1, -1);
5491 memcpy (s->data, data, nbytes); 5469 memcpy (s->u.s.data, data, nbytes);
5492 s->data[nbytes] = '\0'; 5470 s->u.s.data[nbytes] = '\0';
5493 } 5471 }
5494 s->size = nchars; 5472 s->u.s.size = nchars;
5495 s->size_byte = multibyte ? nbytes : -1; 5473 s->u.s.size_byte = multibyte ? nbytes : -1;
5496 s->intervals = NULL; 5474 s->u.s.intervals = NULL;
5497 XSETSTRING (string, s); 5475 XSETSTRING (string, s);
5498 return string; 5476 return string;
5499} 5477}
@@ -5506,10 +5484,10 @@ make_pure_c_string (const char *data, ptrdiff_t nchars)
5506{ 5484{
5507 Lisp_Object string; 5485 Lisp_Object string;
5508 struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String); 5486 struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String);
5509 s->size = nchars; 5487 s->u.s.size = nchars;
5510 s->size_byte = -1; 5488 s->u.s.size_byte = -2;
5511 s->data = (unsigned char *) data; 5489 s->u.s.data = (unsigned char *) data;
5512 s->intervals = NULL; 5490 s->u.s.intervals = NULL;
5513 XSETSTRING (string, s); 5491 XSETSTRING (string, s);
5514 return string; 5492 return string;
5515} 5493}
@@ -5543,6 +5521,34 @@ make_pure_float (double num)
5543 return new; 5521 return new;
5544} 5522}
5545 5523
5524/* Value is a bignum object with value VALUE allocated from pure
5525 space. */
5526
5527static Lisp_Object
5528make_pure_bignum (Lisp_Object value)
5529{
5530 mpz_t const *n = xbignum_val (value);
5531 size_t i, nlimbs = mpz_size (*n);
5532 size_t nbytes = nlimbs * sizeof (mp_limb_t);
5533 mp_limb_t *pure_limbs;
5534 mp_size_t new_size;
5535
5536 struct Lisp_Bignum *b = pure_alloc (sizeof *b, Lisp_Vectorlike);
5537 XSETPVECTYPESIZE (b, PVEC_BIGNUM, 0, VECSIZE (struct Lisp_Bignum));
5538
5539 int limb_alignment = alignof (mp_limb_t);
5540 pure_limbs = pure_alloc (nbytes, - limb_alignment);
5541 for (i = 0; i < nlimbs; ++i)
5542 pure_limbs[i] = mpz_getlimbn (*n, i);
5543
5544 new_size = nlimbs;
5545 if (mpz_sgn (*n) < 0)
5546 new_size = -new_size;
5547
5548 mpz_roinit_n (b->value, pure_limbs, new_size);
5549
5550 return make_lisp_ptr (b, Lisp_Vectorlike);
5551}
5546 5552
5547/* Return a vector with room for LEN Lisp_Objects allocated from 5553/* Return a vector with room for LEN Lisp_Objects allocated from
5548 pure space. */ 5554 pure space. */
@@ -5564,7 +5570,7 @@ static struct Lisp_Hash_Table *
5564purecopy_hash_table (struct Lisp_Hash_Table *table) 5570purecopy_hash_table (struct Lisp_Hash_Table *table)
5565{ 5571{
5566 eassert (NILP (table->weak)); 5572 eassert (NILP (table->weak));
5567 eassert (table->pure); 5573 eassert (table->purecopy);
5568 5574
5569 struct Lisp_Hash_Table *pure = pure_alloc (sizeof *pure, Lisp_Vectorlike); 5575 struct Lisp_Hash_Table *pure = pure_alloc (sizeof *pure, Lisp_Vectorlike);
5570 struct hash_table_test pure_test = table->test; 5576 struct hash_table_test pure_test = table->test;
@@ -5581,7 +5587,8 @@ purecopy_hash_table (struct Lisp_Hash_Table *table)
5581 pure->index = purecopy (table->index); 5587 pure->index = purecopy (table->index);
5582 pure->count = table->count; 5588 pure->count = table->count;
5583 pure->next_free = table->next_free; 5589 pure->next_free = table->next_free;
5584 pure->pure = table->pure; 5590 pure->purecopy = table->purecopy;
5591 eassert (!pure->mutable);
5585 pure->rehash_threshold = table->rehash_threshold; 5592 pure->rehash_threshold = table->rehash_threshold;
5586 pure->rehash_size = table->rehash_size; 5593 pure->rehash_size = table->rehash_size;
5587 pure->key_and_value = purecopy (table->key_and_value); 5594 pure->key_and_value = purecopy (table->key_and_value);
@@ -5615,12 +5622,12 @@ static struct pinned_object
5615static Lisp_Object 5622static Lisp_Object
5616purecopy (Lisp_Object obj) 5623purecopy (Lisp_Object obj)
5617{ 5624{
5618 if (INTEGERP (obj) 5625 if (FIXNUMP (obj)
5619 || (! SYMBOLP (obj) && PURE_P (XPNTR_OR_SYMBOL_OFFSET (obj))) 5626 || (! SYMBOLP (obj) && PURE_P (XPNTR (obj)))
5620 || SUBRP (obj)) 5627 || SUBRP (obj))
5621 return obj; /* Already pure. */ 5628 return obj; /* Already pure. */
5622 5629
5623 if (STRINGP (obj) && XSTRING (obj)->intervals) 5630 if (STRINGP (obj) && XSTRING (obj)->u.s.intervals)
5624 message_with_string ("Dropping text-properties while making string `%s' pure", 5631 message_with_string ("Dropping text-properties while making string `%s' pure",
5625 obj, true); 5632 obj, true);
5626 5633
@@ -5645,7 +5652,7 @@ purecopy (Lisp_Object obj)
5645 /* Do not purify hash tables which haven't been defined with 5652 /* Do not purify hash tables which haven't been defined with
5646 :purecopy as non-nil or are weak - they aren't guaranteed to 5653 :purecopy as non-nil or are weak - they aren't guaranteed to
5647 not change. */ 5654 not change. */
5648 if (!NILP (table->weak) || !table->pure) 5655 if (!NILP (table->weak) || !table->purecopy)
5649 { 5656 {
5650 /* Instead, add the hash table to the list of pinned objects, 5657 /* Instead, add the hash table to the list of pinned objects,
5651 so that it will be marked during GC. */ 5658 so that it will be marked during GC. */
@@ -5671,19 +5678,25 @@ purecopy (Lisp_Object obj)
5671 memcpy (vec, objp, nbytes); 5678 memcpy (vec, objp, nbytes);
5672 for (i = 0; i < size; i++) 5679 for (i = 0; i < size; i++)
5673 vec->contents[i] = purecopy (vec->contents[i]); 5680 vec->contents[i] = purecopy (vec->contents[i]);
5681 // Byte code strings must be pinned.
5682 if (COMPILEDP (obj) && size >= 2 && STRINGP (vec->contents[1])
5683 && !STRING_MULTIBYTE (vec->contents[1]))
5684 pin_string (vec->contents[1]);
5674 XSETVECTOR (obj, vec); 5685 XSETVECTOR (obj, vec);
5675 } 5686 }
5676 else if (SYMBOLP (obj)) 5687 else if (BARE_SYMBOL_P (obj))
5677 { 5688 {
5678 if (!XSYMBOL (obj)->pinned && !c_symbol_p (XSYMBOL (obj))) 5689 if (!XBARE_SYMBOL (obj)->u.s.pinned && !c_symbol_p (XBARE_SYMBOL (obj)))
5679 { /* We can't purify them, but they appear in many pure objects. 5690 { /* We can't purify them, but they appear in many pure objects.
5680 Mark them as `pinned' so we know to mark them at every GC cycle. */ 5691 Mark them as `pinned' so we know to mark them at every GC cycle. */
5681 XSYMBOL (obj)->pinned = true; 5692 XBARE_SYMBOL (obj)->u.s.pinned = true;
5682 symbol_block_pinned = symbol_block; 5693 symbol_block_pinned = symbol_block;
5683 } 5694 }
5684 /* Don't hash-cons it. */ 5695 /* Don't hash-cons it. */
5685 return obj; 5696 return obj;
5686 } 5697 }
5698 else if (BIGNUMP (obj))
5699 obj = make_pure_bignum (obj);
5687 else 5700 else
5688 { 5701 {
5689 AUTO_STRING (fmt, "Don't know how to purify: %S"); 5702 AUTO_STRING (fmt, "Don't know how to purify: %S");
@@ -5706,8 +5719,10 @@ purecopy (Lisp_Object obj)
5706 VARADDRESS. */ 5719 VARADDRESS. */
5707 5720
5708void 5721void
5709staticpro (Lisp_Object *varaddress) 5722staticpro (Lisp_Object const *varaddress)
5710{ 5723{
5724 for (int i = 0; i < staticidx; i++)
5725 eassert (staticvec[i] != varaddress);
5711 if (staticidx >= NSTATICS) 5726 if (staticidx >= NSTATICS)
5712 fatal ("NSTATICS too small; try increasing and recompiling Emacs."); 5727 fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
5713 staticvec[staticidx++] = varaddress; 5728 staticvec[staticidx++] = varaddress;
@@ -5718,40 +5733,49 @@ staticpro (Lisp_Object *varaddress)
5718 Protection from GC 5733 Protection from GC
5719 ***********************************************************************/ 5734 ***********************************************************************/
5720 5735
5721/* Temporarily prevent garbage collection. */ 5736/* Temporarily prevent garbage collection. Temporarily bump
5737 consing_until_gc to speed up maybe_gc when GC is inhibited. */
5722 5738
5723ptrdiff_t 5739static void
5724inhibit_garbage_collection (void) 5740allow_garbage_collection (intmax_t consing)
5725{ 5741{
5726 ptrdiff_t count = SPECPDL_INDEX (); 5742 consing_until_gc = consing - (HI_THRESHOLD - consing_until_gc);
5743 garbage_collection_inhibited--;
5744}
5727 5745
5728 specbind (Qgc_cons_threshold, make_number (MOST_POSITIVE_FIXNUM)); 5746specpdl_ref
5747inhibit_garbage_collection (void)
5748{
5749 specpdl_ref count = SPECPDL_INDEX ();
5750 record_unwind_protect_intmax (allow_garbage_collection, consing_until_gc);
5751 garbage_collection_inhibited++;
5752 consing_until_gc = HI_THRESHOLD;
5729 return count; 5753 return count;
5730} 5754}
5731 5755
5732/* Used to avoid possible overflows when 5756/* Return the number of bytes in N objects each of size S, guarding
5733 converting from C to Lisp integers. */ 5757 against overflow if size_t is narrower than byte_ct. */
5734 5758
5735static Lisp_Object 5759static byte_ct
5736bounded_number (EMACS_INT number) 5760object_bytes (object_ct n, size_t s)
5737{ 5761{
5738 return make_number (min (MOST_POSITIVE_FIXNUM, number)); 5762 byte_ct b = s;
5763 return n * b;
5739} 5764}
5740 5765
5741/* Calculate total bytes of live objects. */ 5766/* Calculate total bytes of live objects. */
5742 5767
5743static size_t 5768static byte_ct
5744total_bytes_of_live_objects (void) 5769total_bytes_of_live_objects (void)
5745{ 5770{
5746 size_t tot = 0; 5771 byte_ct tot = 0;
5747 tot += total_conses * sizeof (struct Lisp_Cons); 5772 tot += object_bytes (gcstat.total_conses, sizeof (struct Lisp_Cons));
5748 tot += total_symbols * sizeof (struct Lisp_Symbol); 5773 tot += object_bytes (gcstat.total_symbols, sizeof (struct Lisp_Symbol));
5749 tot += total_markers * sizeof (union Lisp_Misc); 5774 tot += gcstat.total_string_bytes;
5750 tot += total_string_bytes; 5775 tot += object_bytes (gcstat.total_vector_slots, word_size);
5751 tot += total_vector_slots * word_size; 5776 tot += object_bytes (gcstat.total_floats, sizeof (struct Lisp_Float));
5752 tot += total_floats * sizeof (struct Lisp_Float); 5777 tot += object_bytes (gcstat.total_intervals, sizeof (struct interval));
5753 tot += total_intervals * sizeof (struct interval); 5778 tot += object_bytes (gcstat.total_strings, sizeof (struct Lisp_String));
5754 tot += total_strings * sizeof (struct Lisp_String);
5755 return tot; 5779 return tot;
5756} 5780}
5757 5781
@@ -5772,7 +5796,7 @@ compact_font_cache_entry (Lisp_Object entry)
5772 5796
5773 /* Consider OBJ if it is (font-spec . [font-entity font-entity ...]). */ 5797 /* Consider OBJ if it is (font-spec . [font-entity font-entity ...]). */
5774 if (CONSP (obj) && GC_FONT_SPEC_P (XCAR (obj)) 5798 if (CONSP (obj) && GC_FONT_SPEC_P (XCAR (obj))
5775 && !VECTOR_MARKED_P (GC_XFONT_SPEC (XCAR (obj))) 5799 && !vectorlike_marked_p (&GC_XFONT_SPEC (XCAR (obj))->header)
5776 /* Don't use VECTORP here, as that calls ASIZE, which could 5800 /* Don't use VECTORP here, as that calls ASIZE, which could
5777 hit assertion violation during GC. */ 5801 hit assertion violation during GC. */
5778 && (VECTORLIKEP (XCDR (obj)) 5802 && (VECTORLIKEP (XCDR (obj))
@@ -5788,7 +5812,8 @@ compact_font_cache_entry (Lisp_Object entry)
5788 { 5812 {
5789 Lisp_Object objlist; 5813 Lisp_Object objlist;
5790 5814
5791 if (VECTOR_MARKED_P (GC_XFONT_ENTITY (AREF (obj_cdr, i)))) 5815 if (vectorlike_marked_p (
5816 &GC_XFONT_ENTITY (AREF (obj_cdr, i))->header))
5792 break; 5817 break;
5793 5818
5794 objlist = AREF (AREF (obj_cdr, i), FONT_OBJLIST_INDEX); 5819 objlist = AREF (AREF (obj_cdr, i), FONT_OBJLIST_INDEX);
@@ -5798,7 +5823,7 @@ compact_font_cache_entry (Lisp_Object entry)
5798 struct font *font = GC_XFONT_OBJECT (val); 5823 struct font *font = GC_XFONT_OBJECT (val);
5799 5824
5800 if (!NILP (AREF (val, FONT_TYPE_INDEX)) 5825 if (!NILP (AREF (val, FONT_TYPE_INDEX))
5801 && VECTOR_MARKED_P(font)) 5826 && vectorlike_marked_p (&font->header))
5802 break; 5827 break;
5803 } 5828 }
5804 if (CONSP (objlist)) 5829 if (CONSP (objlist))
@@ -5867,7 +5892,7 @@ compact_undo_list (Lisp_Object list)
5867 { 5892 {
5868 if (CONSP (XCAR (tail)) 5893 if (CONSP (XCAR (tail))
5869 && MARKERP (XCAR (XCAR (tail))) 5894 && MARKERP (XCAR (XCAR (tail)))
5870 && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit) 5895 && !vectorlike_marked_p (&XMARKER (XCAR (XCAR (tail)))->header))
5871 *prev = XCDR (tail); 5896 *prev = XCDR (tail);
5872 else 5897 else
5873 prev = xcdr_addr (tail); 5898 prev = xcdr_addr (tail);
@@ -5891,57 +5916,224 @@ mark_pinned_symbols (void)
5891 5916
5892 for (sblk = symbol_block_pinned; sblk; sblk = sblk->next) 5917 for (sblk = symbol_block_pinned; sblk; sblk = sblk->next)
5893 { 5918 {
5894 union aligned_Lisp_Symbol *sym = sblk->symbols, *end = sym + lim; 5919 struct Lisp_Symbol *sym = sblk->symbols, *end = sym + lim;
5895 for (; sym < end; ++sym) 5920 for (; sym < end; ++sym)
5896 if (sym->s.pinned) 5921 if (sym->u.s.pinned)
5897 mark_object (make_lisp_symbol (&sym->s)); 5922 mark_object (make_lisp_symbol (sym));
5898 5923
5899 lim = SYMBOL_BLOCK_SIZE; 5924 lim = SYMBOL_BLOCK_SIZE;
5900 } 5925 }
5901} 5926}
5902 5927
5903/* Subroutine of Fgarbage_collect that does most of the work. It is a 5928static void
5904 separate function so that we could limit mark_stack in searching 5929visit_vectorlike_root (struct gc_root_visitor visitor,
5905 the stack frames below this function, thus avoiding the rare cases 5930 struct Lisp_Vector *ptr,
5906 where mark_stack finds values that look like live Lisp objects on 5931 enum gc_root_type type)
5907 portions of stack that couldn't possibly contain such live objects. 5932{
5908 For more details of this, see the discussion at 5933 ptrdiff_t size = ptr->header.size;
5909 https://lists.gnu.org/archive/html/emacs-devel/2014-05/msg00270.html. */ 5934 ptrdiff_t i;
5935
5936 if (size & PSEUDOVECTOR_FLAG)
5937 size &= PSEUDOVECTOR_SIZE_MASK;
5938 for (i = 0; i < size; i++)
5939 visitor.visit (&ptr->contents[i], type, visitor.data);
5940}
5941
5942static void
5943visit_buffer_root (struct gc_root_visitor visitor,
5944 struct buffer *buffer,
5945 enum gc_root_type type)
5946{
5947 /* Buffers that are roots don't have intervals, an undo list, or
5948 other constructs that real buffers have. */
5949 eassert (buffer->base_buffer == NULL);
5950 eassert (buffer->overlays == NULL);
5951
5952 /* Visit the buffer-locals. */
5953 visit_vectorlike_root (visitor, (struct Lisp_Vector *) buffer, type);
5954}
5955
5956/* Visit GC roots stored in the Emacs data section. Used by both core
5957 GC and by the portable dumping code.
5958
5959 There are other GC roots of course, but these roots are dynamic
5960 runtime data structures that pdump doesn't care about and so we can
5961 continue to mark those directly in garbage_collect. */
5962void
5963visit_static_gc_roots (struct gc_root_visitor visitor)
5964{
5965 visit_buffer_root (visitor,
5966 &buffer_defaults,
5967 GC_ROOT_BUFFER_LOCAL_DEFAULT);
5968 visit_buffer_root (visitor,
5969 &buffer_local_symbols,
5970 GC_ROOT_BUFFER_LOCAL_NAME);
5971
5972 for (int i = 0; i < ARRAYELTS (lispsym); i++)
5973 {
5974 Lisp_Object sptr = builtin_lisp_symbol (i);
5975 visitor.visit (&sptr, GC_ROOT_C_SYMBOL, visitor.data);
5976 }
5977
5978 for (int i = 0; i < staticidx; i++)
5979 visitor.visit (staticvec[i], GC_ROOT_STATICPRO, visitor.data);
5980}
5981
5982static void
5983mark_object_root_visitor (Lisp_Object const *root_ptr,
5984 enum gc_root_type type,
5985 void *data)
5986{
5987 mark_object (*root_ptr);
5988}
5989
5990/* List of weak hash tables we found during marking the Lisp heap.
5991 NULL on entry to garbage_collect and after it returns. */
5992static struct Lisp_Hash_Table *weak_hash_tables;
5993
5994NO_INLINE /* For better stack traces */
5995static void
5996mark_and_sweep_weak_table_contents (void)
5997{
5998 struct Lisp_Hash_Table *h;
5999 bool marked;
6000
6001 /* Mark all keys and values that are in use. Keep on marking until
6002 there is no more change. This is necessary for cases like
6003 value-weak table A containing an entry X -> Y, where Y is used in a
6004 key-weak table B, Z -> Y. If B comes after A in the list of weak
6005 tables, X -> Y might be removed from A, although when looking at B
6006 one finds that it shouldn't. */
6007 do
6008 {
6009 marked = false;
6010 for (h = weak_hash_tables; h; h = h->next_weak)
6011 marked |= sweep_weak_table (h, false);
6012 }
6013 while (marked);
6014
6015 /* Remove hash table entries that aren't used. */
6016 while (weak_hash_tables)
6017 {
6018 h = weak_hash_tables;
6019 weak_hash_tables = h->next_weak;
6020 h->next_weak = NULL;
6021 sweep_weak_table (h, true);
6022 }
6023}
6024
6025/* Return the number of bytes to cons between GCs, given THRESHOLD and
6026 PERCENTAGE. When calculating a threshold based on PERCENTAGE,
6027 assume SINCE_GC bytes have been allocated since the most recent GC.
6028 The returned value is positive and no greater than HI_THRESHOLD. */
6029static EMACS_INT
6030consing_threshold (intmax_t threshold, Lisp_Object percentage,
6031 intmax_t since_gc)
6032{
6033 if (!NILP (Vmemory_full))
6034 return memory_full_cons_threshold;
6035 else
6036 {
6037 threshold = max (threshold, GC_DEFAULT_THRESHOLD / 10);
6038 if (FLOATP (percentage))
6039 {
6040 double tot = (XFLOAT_DATA (percentage)
6041 * (total_bytes_of_live_objects () + since_gc));
6042 if (threshold < tot)
6043 {
6044 if (tot < HI_THRESHOLD)
6045 return tot;
6046 else
6047 return HI_THRESHOLD;
6048 }
6049 }
6050 return min (threshold, HI_THRESHOLD);
6051 }
6052}
6053
6054/* Adjust consing_until_gc and gc_threshold, given THRESHOLD and PERCENTAGE.
6055 Return the updated consing_until_gc. */
6056
6057static EMACS_INT
6058bump_consing_until_gc (intmax_t threshold, Lisp_Object percentage)
6059{
6060 /* Guesstimate that half the bytes allocated since the most
6061 recent GC are still in use. */
6062 EMACS_INT since_gc = (gc_threshold - consing_until_gc) >> 1;
6063 EMACS_INT new_gc_threshold = consing_threshold (threshold, percentage,
6064 since_gc);
6065 consing_until_gc += new_gc_threshold - gc_threshold;
6066 gc_threshold = new_gc_threshold;
6067 return consing_until_gc;
6068}
6069
6070/* Watch changes to gc-cons-threshold. */
6071static Lisp_Object
6072watch_gc_cons_threshold (Lisp_Object symbol, Lisp_Object newval,
6073 Lisp_Object operation, Lisp_Object where)
6074{
6075 intmax_t threshold;
6076 if (! (INTEGERP (newval) && integer_to_intmax (newval, &threshold)))
6077 return Qnil;
6078 bump_consing_until_gc (threshold, Vgc_cons_percentage);
6079 return Qnil;
6080}
6081
6082/* Watch changes to gc-cons-percentage. */
5910static Lisp_Object 6083static Lisp_Object
5911garbage_collect_1 (void *end) 6084watch_gc_cons_percentage (Lisp_Object symbol, Lisp_Object newval,
6085 Lisp_Object operation, Lisp_Object where)
5912{ 6086{
5913 struct buffer *nextb; 6087 bump_consing_until_gc (gc_cons_threshold, newval);
6088 return Qnil;
6089}
6090
6091/* It may be time to collect garbage. Recalculate consing_until_gc,
6092 since it might depend on current usage, and do the garbage
6093 collection if the recalculation says so. */
6094void
6095maybe_garbage_collect (void)
6096{
6097 if (bump_consing_until_gc (gc_cons_threshold, Vgc_cons_percentage) < 0)
6098 garbage_collect ();
6099}
6100
6101static inline bool mark_stack_empty_p (void);
6102
6103/* Subroutine of Fgarbage_collect that does most of the work. */
6104void
6105garbage_collect (void)
6106{
6107 Lisp_Object tail, buffer;
5914 char stack_top_variable; 6108 char stack_top_variable;
5915 ptrdiff_t i;
5916 bool message_p; 6109 bool message_p;
5917 ptrdiff_t count = SPECPDL_INDEX (); 6110 specpdl_ref count = SPECPDL_INDEX ();
5918 struct timespec start; 6111 struct timespec start;
5919 Lisp_Object retval = Qnil;
5920 size_t tot_before = 0;
5921 6112
5922 /* Can't GC if pure storage overflowed because we can't determine 6113 eassert (weak_hash_tables == NULL);
5923 if something is a pure object or not. */ 6114
5924 if (pure_bytes_used_before_overflow) 6115 if (garbage_collection_inhibited)
5925 return Qnil; 6116 return;
6117
6118 eassert(mark_stack_empty_p ());
5926 6119
5927 /* Record this function, so it appears on the profiler's backtraces. */ 6120 /* Record this function, so it appears on the profiler's backtraces. */
5928 record_in_backtrace (QAutomatic_GC, 0, 0); 6121 record_in_backtrace (QAutomatic_GC, 0, 0);
5929 6122
5930 check_cons_list ();
5931
5932 /* Don't keep undo information around forever. 6123 /* Don't keep undo information around forever.
5933 Do this early on, so it is no problem if the user quits. */ 6124 Do this early on, so it is no problem if the user quits. */
5934 FOR_EACH_BUFFER (nextb) 6125 FOR_EACH_LIVE_BUFFER (tail, buffer)
5935 compact_buffer (nextb); 6126 compact_buffer (XBUFFER (buffer));
5936 6127
5937 if (profiler_memory_running) 6128 byte_ct tot_before = (profiler_memory_running
5938 tot_before = total_bytes_of_live_objects (); 6129 ? total_bytes_of_live_objects ()
6130 : (byte_ct) -1);
5939 6131
5940 start = current_timespec (); 6132 start = current_timespec ();
5941 6133
5942 /* In case user calls debug_print during GC, 6134 /* In case user calls debug_print during GC,
5943 don't let that cause a recursive GC. */ 6135 don't let that cause a recursive GC. */
5944 consing_since_gc = 0; 6136 consing_until_gc = HI_THRESHOLD;
5945 6137
5946 /* Save what's currently displayed in the echo area. Don't do that 6138 /* Save what's currently displayed in the echo area. Don't do that
5947 if we are GC'ing because we've run out of memory, since 6139 if we are GC'ing because we've run out of memory, since
@@ -5958,7 +6150,7 @@ garbage_collect_1 (void *end)
5958#if MAX_SAVE_STACK > 0 6150#if MAX_SAVE_STACK > 0
5959 if (NILP (Vpurify_flag)) 6151 if (NILP (Vpurify_flag))
5960 { 6152 {
5961 char *stack; 6153 char const *stack;
5962 ptrdiff_t stack_size; 6154 ptrdiff_t stack_size;
5963 if (&stack_top_variable < stack_bottom) 6155 if (&stack_top_variable < stack_bottom)
5964 { 6156 {
@@ -5993,31 +6185,37 @@ garbage_collect_1 (void *end)
5993 6185
5994 /* Mark all the special slots that serve as the roots of accessibility. */ 6186 /* Mark all the special slots that serve as the roots of accessibility. */
5995 6187
5996 mark_buffer (&buffer_defaults); 6188 struct gc_root_visitor visitor = { .visit = mark_object_root_visitor };
5997 mark_buffer (&buffer_local_symbols); 6189 visit_static_gc_roots (visitor);
5998
5999 for (i = 0; i < ARRAYELTS (lispsym); i++)
6000 mark_object (builtin_lisp_symbol (i));
6001
6002 for (i = 0; i < staticidx; i++)
6003 mark_object (*staticvec[i]);
6004 6190
6005 mark_pinned_objects (); 6191 mark_pinned_objects ();
6006 mark_pinned_symbols (); 6192 mark_pinned_symbols ();
6193 mark_lread ();
6007 mark_terminals (); 6194 mark_terminals ();
6008 mark_kboards (); 6195 mark_kboards ();
6009 mark_threads (); 6196 mark_threads ();
6197#ifdef HAVE_PGTK
6198 mark_pgtkterm ();
6199#endif
6010 6200
6011#ifdef USE_GTK 6201#ifdef USE_GTK
6012 xg_mark_data (); 6202 xg_mark_data ();
6013#endif 6203#endif
6014 6204
6205#ifdef HAVE_HAIKU
6206 mark_haiku_display ();
6207#endif
6208
6015#ifdef HAVE_WINDOW_SYSTEM 6209#ifdef HAVE_WINDOW_SYSTEM
6016 mark_fringe_data (); 6210 mark_fringe_data ();
6017#endif 6211#endif
6018 6212
6019#ifdef HAVE_MODULES 6213#ifdef HAVE_X_WINDOWS
6020 mark_modules (); 6214 mark_xterm ();
6215#endif
6216
6217#ifdef HAVE_NS
6218 mark_nsterm ();
6021#endif 6219#endif
6022 6220
6023 /* Everything is now marked, except for the data in font caches, 6221 /* Everything is now marked, except for the data in font caches,
@@ -6026,8 +6224,9 @@ garbage_collect_1 (void *end)
6026 6224
6027 compact_font_caches (); 6225 compact_font_caches ();
6028 6226
6029 FOR_EACH_BUFFER (nextb) 6227 FOR_EACH_LIVE_BUFFER (tail, buffer)
6030 { 6228 {
6229 struct buffer *nextb = XBUFFER (buffer);
6031 if (!EQ (BVAR (nextb, undo_list), Qt)) 6230 if (!EQ (BVAR (nextb, undo_list), Qt))
6032 bset_undo_list (nextb, compact_undo_list (BVAR (nextb, undo_list))); 6231 bset_undo_list (nextb, compact_undo_list (BVAR (nextb, undo_list)));
6033 /* Now that we have stripped the elements that need not be 6232 /* Now that we have stripped the elements that need not be
@@ -6045,36 +6244,24 @@ garbage_collect_1 (void *end)
6045 queue_doomed_finalizers (&doomed_finalizers, &finalizers); 6244 queue_doomed_finalizers (&doomed_finalizers, &finalizers);
6046 mark_finalizer_list (&doomed_finalizers); 6245 mark_finalizer_list (&doomed_finalizers);
6047 6246
6048 gc_sweep (); 6247 /* Must happen after all other marking and before gc_sweep. */
6049 6248 mark_and_sweep_weak_table_contents ();
6050 /* Clear the mark bits that we set in certain root slots. */ 6249 eassert (weak_hash_tables == NULL);
6051 VECTOR_UNMARK (&buffer_defaults);
6052 VECTOR_UNMARK (&buffer_local_symbols);
6053 6250
6054 check_cons_list (); 6251 eassert (mark_stack_empty_p ());
6055 6252
6056 gc_in_progress = 0; 6253 gc_sweep ();
6057 6254
6058 unblock_input (); 6255 unmark_main_thread ();
6059 6256
6060 consing_since_gc = 0; 6257 gc_in_progress = 0;
6061 if (gc_cons_threshold < GC_DEFAULT_THRESHOLD / 10)
6062 gc_cons_threshold = GC_DEFAULT_THRESHOLD / 10;
6063 6258
6064 gc_relative_threshold = 0; 6259 consing_until_gc = gc_threshold
6065 if (FLOATP (Vgc_cons_percentage)) 6260 = consing_threshold (gc_cons_threshold, Vgc_cons_percentage, 0);
6066 { /* Set gc_cons_combined_threshold. */
6067 double tot = total_bytes_of_live_objects ();
6068 6261
6069 tot *= XFLOAT_DATA (Vgc_cons_percentage); 6262 /* Unblock *after* re-setting `consing_until_gc` in case `unblock_input`
6070 if (0 < tot) 6263 signals an error (see bug#43389). */
6071 { 6264 unblock_input ();
6072 if (tot < TYPE_MAXIMUM (EMACS_INT))
6073 gc_relative_threshold = tot;
6074 else
6075 gc_relative_threshold = TYPE_MAXIMUM (EMACS_INT);
6076 }
6077 }
6078 6265
6079 if (garbage_collection_messages && NILP (Vmemory_full)) 6266 if (garbage_collection_messages && NILP (Vmemory_full))
6080 { 6267 {
@@ -6086,50 +6273,17 @@ garbage_collect_1 (void *end)
6086 6273
6087 unbind_to (count, Qnil); 6274 unbind_to (count, Qnil);
6088 6275
6089 Lisp_Object total[] = {
6090 list4 (Qconses, make_number (sizeof (struct Lisp_Cons)),
6091 bounded_number (total_conses),
6092 bounded_number (total_free_conses)),
6093 list4 (Qsymbols, make_number (sizeof (struct Lisp_Symbol)),
6094 bounded_number (total_symbols),
6095 bounded_number (total_free_symbols)),
6096 list4 (Qmiscs, make_number (sizeof (union Lisp_Misc)),
6097 bounded_number (total_markers),
6098 bounded_number (total_free_markers)),
6099 list4 (Qstrings, make_number (sizeof (struct Lisp_String)),
6100 bounded_number (total_strings),
6101 bounded_number (total_free_strings)),
6102 list3 (Qstring_bytes, make_number (1),
6103 bounded_number (total_string_bytes)),
6104 list3 (Qvectors,
6105 make_number (header_size + sizeof (Lisp_Object)),
6106 bounded_number (total_vectors)),
6107 list4 (Qvector_slots, make_number (word_size),
6108 bounded_number (total_vector_slots),
6109 bounded_number (total_free_vector_slots)),
6110 list4 (Qfloats, make_number (sizeof (struct Lisp_Float)),
6111 bounded_number (total_floats),
6112 bounded_number (total_free_floats)),
6113 list4 (Qintervals, make_number (sizeof (struct interval)),
6114 bounded_number (total_intervals),
6115 bounded_number (total_free_intervals)),
6116 list3 (Qbuffers, make_number (sizeof (struct buffer)),
6117 bounded_number (total_buffers)),
6118
6119#ifdef DOUG_LEA_MALLOC
6120 list4 (Qheap, make_number (1024),
6121 bounded_number ((mallinfo ().uordblks + 1023) >> 10),
6122 bounded_number ((mallinfo ().fordblks + 1023) >> 10)),
6123#endif
6124 };
6125 retval = CALLMANY (Flist, total);
6126
6127 /* GC is complete: now we can run our finalizer callbacks. */ 6276 /* GC is complete: now we can run our finalizer callbacks. */
6128 run_finalizers (&doomed_finalizers); 6277 run_finalizers (&doomed_finalizers);
6129 6278
6279#ifdef HAVE_WINDOW_SYSTEM
6280 /* Eject unused image cache entries. */
6281 image_prune_animation_caches (false);
6282#endif
6283
6130 if (!NILP (Vpost_gc_hook)) 6284 if (!NILP (Vpost_gc_hook))
6131 { 6285 {
6132 ptrdiff_t gc_count = inhibit_garbage_collection (); 6286 specpdl_ref gc_count = inhibit_garbage_collection ();
6133 safe_run_hooks (Qpost_gc_hook); 6287 safe_run_hooks (Qpost_gc_hook);
6134 unbind_to (gc_count, Qnil); 6288 unbind_to (gc_count, Qnil);
6135 } 6289 }
@@ -6137,24 +6291,21 @@ garbage_collect_1 (void *end)
6137 /* Accumulate statistics. */ 6291 /* Accumulate statistics. */
6138 if (FLOATP (Vgc_elapsed)) 6292 if (FLOATP (Vgc_elapsed))
6139 { 6293 {
6140 struct timespec since_start = timespec_sub (current_timespec (), start); 6294 static struct timespec gc_elapsed;
6141 Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed) 6295 gc_elapsed = timespec_add (gc_elapsed,
6142 + timespectod (since_start)); 6296 timespec_sub (current_timespec (), start));
6297 Vgc_elapsed = make_float (timespectod (gc_elapsed));
6143 } 6298 }
6144 6299
6145 gcs_done++; 6300 gcs_done++;
6146 6301
6147 /* Collect profiling data. */ 6302 /* Collect profiling data. */
6148 if (profiler_memory_running) 6303 if (tot_before != (byte_ct) -1)
6149 { 6304 {
6150 size_t swept = 0; 6305 byte_ct tot_after = total_bytes_of_live_objects ();
6151 size_t tot_after = total_bytes_of_live_objects (); 6306 if (tot_after < tot_before)
6152 if (tot_before > tot_after) 6307 malloc_probe (min (tot_before - tot_after, SIZE_MAX));
6153 swept = tot_before - tot_after;
6154 malloc_probe (swept);
6155 } 6308 }
6156
6157 return retval;
6158} 6309}
6159 6310
6160DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "", 6311DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
@@ -6169,15 +6320,86 @@ where each entry has the form (NAME SIZE USED FREE), where:
6169- FREE is the number of those objects that are not live but that Emacs 6320- FREE is the number of those objects that are not live but that Emacs
6170 keeps around for future allocations (maybe because it does not know how 6321 keeps around for future allocations (maybe because it does not know how
6171 to return them to the OS). 6322 to return them to the OS).
6172However, if there was overflow in pure space, `garbage-collect' 6323
6173returns nil, because real GC can't be done. 6324However, if there was overflow in pure space, and Emacs was dumped
6174See Info node `(elisp)Garbage Collection'. */ 6325using the \"unexec\" method, `garbage-collect' returns nil, because
6175 attributes: noinline) 6326real GC can't be done.
6327
6328Note that calling this function does not guarantee that absolutely all
6329unreachable objects will be garbage-collected. Emacs uses a
6330mark-and-sweep garbage collector, but is conservative when it comes to
6331collecting objects in some circumstances.
6332
6333For further details, see Info node `(elisp)Garbage Collection'. */)
6176 (void) 6334 (void)
6177{ 6335{
6178 void *end; 6336 if (garbage_collection_inhibited)
6179 SET_STACK_TOP_ADDRESS (&end); 6337 return Qnil;
6180 return garbage_collect_1 (end); 6338
6339 specpdl_ref count = SPECPDL_INDEX ();
6340 specbind (Qsymbols_with_pos_enabled, Qnil);
6341 garbage_collect ();
6342 unbind_to (count, Qnil);
6343 struct gcstat gcst = gcstat;
6344
6345 Lisp_Object total[] = {
6346 list4 (Qconses, make_fixnum (sizeof (struct Lisp_Cons)),
6347 make_int (gcst.total_conses),
6348 make_int (gcst.total_free_conses)),
6349 list4 (Qsymbols, make_fixnum (sizeof (struct Lisp_Symbol)),
6350 make_int (gcst.total_symbols),
6351 make_int (gcst.total_free_symbols)),
6352 list4 (Qstrings, make_fixnum (sizeof (struct Lisp_String)),
6353 make_int (gcst.total_strings),
6354 make_int (gcst.total_free_strings)),
6355 list3 (Qstring_bytes, make_fixnum (1),
6356 make_int (gcst.total_string_bytes)),
6357 list3 (Qvectors,
6358 make_fixnum (header_size + sizeof (Lisp_Object)),
6359 make_int (gcst.total_vectors)),
6360 list4 (Qvector_slots, make_fixnum (word_size),
6361 make_int (gcst.total_vector_slots),
6362 make_int (gcst.total_free_vector_slots)),
6363 list4 (Qfloats, make_fixnum (sizeof (struct Lisp_Float)),
6364 make_int (gcst.total_floats),
6365 make_int (gcst.total_free_floats)),
6366 list4 (Qintervals, make_fixnum (sizeof (struct interval)),
6367 make_int (gcst.total_intervals),
6368 make_int (gcst.total_free_intervals)),
6369 list3 (Qbuffers, make_fixnum (sizeof (struct buffer)),
6370 make_int (gcst.total_buffers)),
6371
6372#ifdef DOUG_LEA_MALLOC
6373 list4 (Qheap, make_fixnum (1024),
6374 make_int ((mallinfo ().uordblks + 1023) >> 10),
6375 make_int ((mallinfo ().fordblks + 1023) >> 10)),
6376#endif
6377 };
6378 return CALLMANY (Flist, total);
6379}
6380
6381DEFUN ("garbage-collect-maybe", Fgarbage_collect_maybe,
6382Sgarbage_collect_maybe, 1, 1, 0,
6383 doc: /* Call `garbage-collect' if enough allocation happened.
6384FACTOR determines what "enough" means here:
6385If FACTOR is a positive number N, it means to run GC if more than
63861/Nth of the allocations needed to trigger automatic allocation took
6387place.
6388Therefore, as N gets higher, this is more likely to perform a GC.
6389Returns non-nil if GC happened, and nil otherwise. */)
6390 (Lisp_Object factor)
6391{
6392 CHECK_FIXNAT (factor);
6393 EMACS_INT fact = XFIXNAT (factor);
6394
6395 EMACS_INT since_gc = gc_threshold - consing_until_gc;
6396 if (fact >= 1 && since_gc > gc_threshold / fact)
6397 {
6398 garbage_collect ();
6399 return Qt;
6400 }
6401 else
6402 return Qnil;
6181} 6403}
6182 6404
6183/* Mark Lisp objects in glyph matrix MATRIX. Currently the 6405/* Mark Lisp objects in glyph matrix MATRIX. Currently the
@@ -6200,34 +6422,44 @@ mark_glyph_matrix (struct glyph_matrix *matrix)
6200 6422
6201 for (; glyph < end_glyph; ++glyph) 6423 for (; glyph < end_glyph; ++glyph)
6202 if (STRINGP (glyph->object) 6424 if (STRINGP (glyph->object)
6203 && !STRING_MARKED_P (XSTRING (glyph->object))) 6425 && !string_marked_p (XSTRING (glyph->object)))
6204 mark_object (glyph->object); 6426 mark_object (glyph->object);
6205 } 6427 }
6206 } 6428 }
6207} 6429}
6208 6430
6209/* Mark reference to a Lisp_Object. 6431/* Whether to remember a few of the last marked values for debugging. */
6210 If the object referred to has not been seen yet, recursively mark 6432#define GC_REMEMBER_LAST_MARKED 0
6211 all the references contained in it. */
6212 6433
6213#define LAST_MARKED_SIZE 500 6434#if GC_REMEMBER_LAST_MARKED
6435enum { LAST_MARKED_SIZE = 1 << 9 }; /* Must be a power of 2. */
6214Lisp_Object last_marked[LAST_MARKED_SIZE] EXTERNALLY_VISIBLE; 6436Lisp_Object last_marked[LAST_MARKED_SIZE] EXTERNALLY_VISIBLE;
6215static int last_marked_index; 6437static int last_marked_index;
6438#endif
6439
6440/* Whether to enable the mark_object_loop_halt debugging feature. */
6441#define GC_CDR_COUNT 0
6216 6442
6443#if GC_CDR_COUNT
6217/* For debugging--call abort when we cdr down this many 6444/* For debugging--call abort when we cdr down this many
6218 links of a list, in mark_object. In debugging, 6445 links of a list, in mark_object. In debugging,
6219 the call to abort will hit a breakpoint. 6446 the call to abort will hit a breakpoint.
6220 Normally this is zero and the check never goes off. */ 6447 Normally this is zero and the check never goes off. */
6221ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE; 6448ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE;
6449#endif
6222 6450
6223static void 6451static void
6224mark_vectorlike (struct Lisp_Vector *ptr) 6452mark_vectorlike (union vectorlike_header *header)
6225{ 6453{
6454 struct Lisp_Vector *ptr = (struct Lisp_Vector *) header;
6226 ptrdiff_t size = ptr->header.size; 6455 ptrdiff_t size = ptr->header.size;
6227 ptrdiff_t i;
6228 6456
6229 eassert (!VECTOR_MARKED_P (ptr)); 6457 eassert (!vector_marked_p (ptr));
6230 VECTOR_MARK (ptr); /* Else mark it. */ 6458
6459 /* Bool vectors have a different case in mark_object. */
6460 eassert (PSEUDOVECTOR_TYPE (ptr) != PVEC_BOOL_VECTOR);
6461
6462 set_vector_marked (ptr); /* Else mark it. */
6231 if (size & PSEUDOVECTOR_FLAG) 6463 if (size & PSEUDOVECTOR_FLAG)
6232 size &= PSEUDOVECTOR_SIZE_MASK; 6464 size &= PSEUDOVECTOR_SIZE_MASK;
6233 6465
@@ -6235,8 +6467,7 @@ mark_vectorlike (struct Lisp_Vector *ptr)
6235 the number of Lisp_Object fields that we should trace. 6467 the number of Lisp_Object fields that we should trace.
6236 The distinction is used e.g. by Lisp_Process which places extra 6468 The distinction is used e.g. by Lisp_Process which places extra
6237 non-Lisp_Object fields at the end of the structure... */ 6469 non-Lisp_Object fields at the end of the structure... */
6238 for (i = 0; i < size; i++) /* ...and then mark its elements. */ 6470 mark_objects (ptr->contents, size);
6239 mark_object (ptr->contents[i]);
6240} 6471}
6241 6472
6242/* Like mark_vectorlike but optimized for char-tables (and 6473/* Like mark_vectorlike but optimized for char-tables (and
@@ -6250,17 +6481,18 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype)
6250 /* Consult the Lisp_Sub_Char_Table layout before changing this. */ 6481 /* Consult the Lisp_Sub_Char_Table layout before changing this. */
6251 int i, idx = (pvectype == PVEC_SUB_CHAR_TABLE ? SUB_CHAR_TABLE_OFFSET : 0); 6482 int i, idx = (pvectype == PVEC_SUB_CHAR_TABLE ? SUB_CHAR_TABLE_OFFSET : 0);
6252 6483
6253 eassert (!VECTOR_MARKED_P (ptr)); 6484 eassert (!vector_marked_p (ptr));
6254 VECTOR_MARK (ptr); 6485 set_vector_marked (ptr);
6255 for (i = idx; i < size; i++) 6486 for (i = idx; i < size; i++)
6256 { 6487 {
6257 Lisp_Object val = ptr->contents[i]; 6488 Lisp_Object val = ptr->contents[i];
6258 6489
6259 if (INTEGERP (val) || (SYMBOLP (val) && XSYMBOL (val)->gcmarkbit)) 6490 if (FIXNUMP (val) ||
6491 (BARE_SYMBOL_P (val) && symbol_marked_p (XBARE_SYMBOL (val))))
6260 continue; 6492 continue;
6261 if (SUB_CHAR_TABLE_P (val)) 6493 if (SUB_CHAR_TABLE_P (val))
6262 { 6494 {
6263 if (! VECTOR_MARKED_P (XVECTOR (val))) 6495 if (! vector_marked_p (XVECTOR (val)))
6264 mark_char_table (XVECTOR (val), PVEC_SUB_CHAR_TABLE); 6496 mark_char_table (XVECTOR (val), PVEC_SUB_CHAR_TABLE);
6265 } 6497 }
6266 else 6498 else
@@ -6268,25 +6500,12 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype)
6268 } 6500 }
6269} 6501}
6270 6502
6271NO_INLINE /* To reduce stack depth in mark_object. */
6272static Lisp_Object
6273mark_compiled (struct Lisp_Vector *ptr)
6274{
6275 int i, size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
6276
6277 VECTOR_MARK (ptr);
6278 for (i = 0; i < size; i++)
6279 if (i != COMPILED_CONSTANTS)
6280 mark_object (ptr->contents[i]);
6281 return size > COMPILED_CONSTANTS ? ptr->contents[COMPILED_CONSTANTS] : Qnil;
6282}
6283
6284/* Mark the chain of overlays starting at PTR. */ 6503/* Mark the chain of overlays starting at PTR. */
6285 6504
6286static void 6505static void
6287mark_overlay (struct Lisp_Overlay *ov) 6506mark_overlay (struct Lisp_Overlay *ov)
6288{ 6507{
6289 ov->gcmarkbit = 1; 6508 set_vectorlike_marked (&ov->header);
6290 mark_object (ov->plist); 6509 mark_object (ov->plist);
6291} 6510}
6292 6511
@@ -6296,15 +6515,20 @@ static void
6296mark_buffer (struct buffer *buffer) 6515mark_buffer (struct buffer *buffer)
6297{ 6516{
6298 /* This is handled much like other pseudovectors... */ 6517 /* This is handled much like other pseudovectors... */
6299 mark_vectorlike ((struct Lisp_Vector *) buffer); 6518 mark_vectorlike (&buffer->header);
6300 6519
6301 /* ...but there are some buffer-specific things. */ 6520 /* ...but there are some buffer-specific things. */
6302 6521
6303 MARK_INTERVAL_TREE (buffer_intervals (buffer)); 6522 mark_interval_tree (buffer_intervals (buffer));
6304 6523
6305 /* For now, we just don't mark the undo_list. It's done later in 6524 /* For now, we just don't mark the undo_list. It's done later in
6306 a special way just before the sweep phase, and after stripping 6525 a special way just before the sweep phase, and after stripping
6307 some of its elements that are not needed any more. */ 6526 some of its elements that are not needed any more.
6527 Note: this later processing is only done for live buffers, so
6528 for dead buffers, the undo_list should be nil (set by Fkill_buffer),
6529 but just to be on the safe side, we mark it here. */
6530 if (!BUFFER_LIVE_P (buffer))
6531 mark_object (BVAR (buffer, undo_list));
6308 6532
6309 struct interval_node *node; 6533 struct interval_node *node;
6310 buffer_overlay_iter_start (buffer, PTRDIFF_MIN, PTRDIFF_MAX, ITREE_ASCENDING); 6534 buffer_overlay_iter_start (buffer, PTRDIFF_MIN, PTRDIFF_MAX, ITREE_ASCENDING);
@@ -6313,7 +6537,8 @@ mark_buffer (struct buffer *buffer)
6313 buffer_overlay_iter_finish (buffer); 6537 buffer_overlay_iter_finish (buffer);
6314 6538
6315 /* If this is an indirect buffer, mark its base buffer. */ 6539 /* If this is an indirect buffer, mark its base buffer. */
6316 if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer)) 6540 if (buffer->base_buffer &&
6541 !vectorlike_marked_p (&buffer->base_buffer->header))
6317 mark_buffer (buffer->base_buffer); 6542 mark_buffer (buffer->base_buffer);
6318} 6543}
6319 6544
@@ -6325,18 +6550,16 @@ mark_face_cache (struct face_cache *c)
6325{ 6550{
6326 if (c) 6551 if (c)
6327 { 6552 {
6328 int i, j; 6553 for (int i = 0; i < c->used; i++)
6329 for (i = 0; i < c->used; ++i)
6330 { 6554 {
6331 struct face *face = FACE_FROM_ID_OR_NULL (c->f, i); 6555 struct face *face = FACE_FROM_ID_OR_NULL (c->f, i);
6332 6556
6333 if (face) 6557 if (face)
6334 { 6558 {
6335 if (face->font && !VECTOR_MARKED_P (face->font)) 6559 if (face->font && !vectorlike_marked_p (&face->font->header))
6336 mark_vectorlike ((struct Lisp_Vector *) face->font); 6560 mark_vectorlike (&face->font->header);
6337 6561
6338 for (j = 0; j < LFACE_VECTOR_SIZE; ++j) 6562 mark_objects (face->lface, LFACE_VECTOR_SIZE);
6339 mark_object (face->lface[j]);
6340 } 6563 }
6341 } 6564 }
6342 } 6565 }
@@ -6348,42 +6571,14 @@ mark_localized_symbol (struct Lisp_Symbol *ptr)
6348{ 6571{
6349 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr); 6572 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
6350 Lisp_Object where = blv->where; 6573 Lisp_Object where = blv->where;
6351 /* If the value is set up for a killed buffer or deleted 6574 /* If the value is set up for a killed buffer restore its global binding. */
6352 frame, restore its global binding. If the value is 6575 if ((BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where))))
6353 forwarded to a C variable, either it's not a Lisp_Object
6354 var, or it's staticpro'd already. */
6355 if ((BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where)))
6356 || (FRAMEP (where) && !FRAME_LIVE_P (XFRAME (where))))
6357 swap_in_global_binding (ptr); 6576 swap_in_global_binding (ptr);
6358 mark_object (blv->where); 6577 mark_object (blv->where);
6359 mark_object (blv->valcell); 6578 mark_object (blv->valcell);
6360 mark_object (blv->defcell); 6579 mark_object (blv->defcell);
6361} 6580}
6362 6581
6363NO_INLINE /* To reduce stack depth in mark_object. */
6364static void
6365mark_save_value (struct Lisp_Save_Value *ptr)
6366{
6367 /* If `save_type' is zero, `data[0].pointer' is the address
6368 of a memory area containing `data[1].integer' potential
6369 Lisp_Objects. */
6370 if (ptr->save_type == SAVE_TYPE_MEMORY)
6371 {
6372 Lisp_Object *p = ptr->data[0].pointer;
6373 ptrdiff_t nelt;
6374 for (nelt = ptr->data[1].integer; nelt > 0; nelt--, p++)
6375 mark_maybe_object (*p);
6376 }
6377 else
6378 {
6379 /* Find Lisp_Objects in `data[N]' slots and mark them. */
6380 int i;
6381 for (i = 0; i < SAVE_VALUE_SLOTS; i++)
6382 if (save_type (ptr, i) == SAVE_OBJECT)
6383 mark_object (ptr->data[i].object);
6384 }
6385}
6386
6387/* Remove killed buffers or items whose car is a killed buffer from 6582/* Remove killed buffers or items whose car is a killed buffer from
6388 LIST, and mark other items. Return changed LIST, which is marked. */ 6583 LIST, and mark other items. Return changed LIST, which is marked. */
6389 6584
@@ -6392,7 +6587,7 @@ mark_discard_killed_buffers (Lisp_Object list)
6392{ 6587{
6393 Lisp_Object tail, *prev = &list; 6588 Lisp_Object tail, *prev = &list;
6394 6589
6395 for (tail = list; CONSP (tail) && !CONS_MARKED_P (XCONS (tail)); 6590 for (tail = list; CONSP (tail) && !cons_marked_p (XCONS (tail));
6396 tail = XCDR (tail)) 6591 tail = XCDR (tail))
6397 { 6592 {
6398 Lisp_Object tem = XCAR (tail); 6593 Lisp_Object tem = XCAR (tail);
@@ -6402,7 +6597,7 @@ mark_discard_killed_buffers (Lisp_Object list)
6402 *prev = XCDR (tail); 6597 *prev = XCDR (tail);
6403 else 6598 else
6404 { 6599 {
6405 CONS_MARK (XCONS (tail)); 6600 set_cons_marked (XCONS (tail));
6406 mark_object (XCAR (tail)); 6601 mark_object (XCAR (tail));
6407 prev = xcdr_addr (tail); 6602 prev = xcdr_addr (tail);
6408 } 6603 }
@@ -6411,351 +6606,448 @@ mark_discard_killed_buffers (Lisp_Object list)
6411 return list; 6606 return list;
6412} 6607}
6413 6608
6414/* Determine type of generic Lisp_Object and mark it accordingly. 6609static void
6610mark_frame (struct Lisp_Vector *ptr)
6611{
6612 struct frame *f = (struct frame *) ptr;
6613 mark_vectorlike (&ptr->header);
6614 mark_face_cache (f->face_cache);
6615#ifdef HAVE_WINDOW_SYSTEM
6616 if (FRAME_WINDOW_P (f) && FRAME_OUTPUT_DATA (f))
6617 {
6618 struct font *font = FRAME_FONT (f);
6415 6619
6416 This function implements a straightforward depth-first marking 6620 if (font && !vectorlike_marked_p (&font->header))
6417 algorithm and so the recursion depth may be very high (a few 6621 mark_vectorlike (&font->header);
6418 tens of thousands is not uncommon). To minimize stack usage, 6622 }
6419 a few cold paths are moved out to NO_INLINE functions above. 6623#endif
6420 In general, inlining them doesn't help you to gain more speed. */ 6624}
6421 6625
6422void 6626static void
6423mark_object (Lisp_Object arg) 6627mark_window (struct Lisp_Vector *ptr)
6424{ 6628{
6425 register Lisp_Object obj; 6629 struct window *w = (struct window *) ptr;
6426 void *po;
6427#if GC_CHECK_MARKED_OBJECTS
6428 struct mem_node *m;
6429#endif
6430 ptrdiff_t cdr_count = 0;
6431 6630
6432 obj = arg; 6631 mark_vectorlike (&ptr->header);
6433 loop:
6434 6632
6435 po = XPNTR (obj); 6633 /* Mark glyph matrices, if any. Marking window
6436 if (PURE_P (po)) 6634 matrices is sufficient because frame matrices
6635 use the same glyph memory. */
6636 if (w->current_matrix)
6637 {
6638 mark_glyph_matrix (w->current_matrix);
6639 mark_glyph_matrix (w->desired_matrix);
6640 }
6641
6642 /* Filter out killed buffers from both buffer lists
6643 in attempt to help GC to reclaim killed buffers faster.
6644 We can do it elsewhere for live windows, but this is the
6645 best place to do it for dead windows. */
6646 wset_prev_buffers
6647 (w, mark_discard_killed_buffers (w->prev_buffers));
6648 wset_next_buffers
6649 (w, mark_discard_killed_buffers (w->next_buffers));
6650}
6651
6652/* Entry of the mark stack. */
6653struct mark_entry
6654{
6655 ptrdiff_t n; /* number of values, or 0 if a single value */
6656 union {
6657 Lisp_Object value; /* when n = 0 */
6658 Lisp_Object *values; /* when n > 0 */
6659 } u;
6660};
6661
6662/* This stack is used during marking for traversing data structures without
6663 using C recursion. */
6664struct mark_stack
6665{
6666 struct mark_entry *stack; /* base of stack */
6667 ptrdiff_t size; /* allocated size in entries */
6668 ptrdiff_t sp; /* current number of entries */
6669};
6670
6671static struct mark_stack mark_stk = {NULL, 0, 0};
6672
6673static inline bool
6674mark_stack_empty_p (void)
6675{
6676 return mark_stk.sp <= 0;
6677}
6678
6679/* Pop and return a value from the mark stack (which must be nonempty). */
6680static inline Lisp_Object
6681mark_stack_pop (void)
6682{
6683 eassume (!mark_stack_empty_p ());
6684 struct mark_entry *e = &mark_stk.stack[mark_stk.sp - 1];
6685 if (e->n == 0) /* single value */
6686 {
6687 --mark_stk.sp;
6688 return e->u.value;
6689 }
6690 /* Array of values: pop them left to right, which seems to be slightly
6691 faster than right to left. */
6692 e->n--;
6693 if (e->n == 0)
6694 --mark_stk.sp; /* last value consumed */
6695 return (++e->u.values)[-1];
6696}
6697
6698NO_INLINE static void
6699grow_mark_stack (void)
6700{
6701 struct mark_stack *ms = &mark_stk;
6702 eassert (ms->sp == ms->size);
6703 ptrdiff_t min_incr = ms->sp == 0 ? 8192 : 1;
6704 ms->stack = xpalloc (ms->stack, &ms->size, min_incr, -1, sizeof *ms->stack);
6705 eassert (ms->sp < ms->size);
6706}
6707
6708/* Push VALUE onto the mark stack. */
6709static inline void
6710mark_stack_push_value (Lisp_Object value)
6711{
6712 if (mark_stk.sp >= mark_stk.size)
6713 grow_mark_stack ();
6714 mark_stk.stack[mark_stk.sp++] = (struct mark_entry){.n = 0, .u.value = value};
6715}
6716
6717/* Push the N values at VALUES onto the mark stack. */
6718static inline void
6719mark_stack_push_values (Lisp_Object *values, ptrdiff_t n)
6720{
6721 eassume (n >= 0);
6722 if (n == 0)
6437 return; 6723 return;
6724 if (mark_stk.sp >= mark_stk.size)
6725 grow_mark_stack ();
6726 mark_stk.stack[mark_stk.sp++] = (struct mark_entry){.n = n,
6727 .u.values = values};
6728}
6438 6729
6439 last_marked[last_marked_index++] = obj; 6730/* Traverse and mark objects on the mark stack above BASE_SP.
6440 if (last_marked_index == LAST_MARKED_SIZE)
6441 last_marked_index = 0;
6442 6731
6443 /* Perform some sanity checks on the objects marked here. Abort if 6732 Traversal is depth-first using the mark stack for most common
6444 we encounter an object we know is bogus. This increases GC time 6733 object types. Recursion is used for other types, in the hope that
6445 by ~80%. */ 6734 they are rare enough that C stack usage is kept low. */
6735static void
6736process_mark_stack (ptrdiff_t base_sp)
6737{
6446#if GC_CHECK_MARKED_OBJECTS 6738#if GC_CHECK_MARKED_OBJECTS
6739 struct mem_node *m = NULL;
6740#endif
6741#if GC_CDR_COUNT
6742 ptrdiff_t cdr_count = 0;
6743#endif
6447 6744
6448 /* Check that the object pointed to by PO is known to be a Lisp 6745 eassume (mark_stk.sp >= base_sp && base_sp >= 0);
6449 structure allocated from the heap. */
6450#define CHECK_ALLOCATED() \
6451 do { \
6452 m = mem_find (po); \
6453 if (m == MEM_NIL) \
6454 emacs_abort (); \
6455 } while (0)
6456 6746
6457 /* Check that the object pointed to by PO is live, using predicate 6747 while (mark_stk.sp > base_sp)
6458 function LIVEP. */ 6748 {
6459#define CHECK_LIVE(LIVEP) \ 6749 Lisp_Object obj = mark_stack_pop ();
6460 do { \ 6750 mark_obj: ;
6461 if (!LIVEP (m, po)) \ 6751 void *po = XPNTR (obj);
6462 emacs_abort (); \ 6752 if (PURE_P (po))
6463 } while (0) 6753 continue;
6464 6754
6465 /* Check both of the above conditions, for non-symbols. */ 6755#if GC_REMEMBER_LAST_MARKED
6466#define CHECK_ALLOCATED_AND_LIVE(LIVEP) \ 6756 last_marked[last_marked_index++] = obj;
6467 do { \ 6757 last_marked_index &= LAST_MARKED_SIZE - 1;
6468 CHECK_ALLOCATED (); \ 6758#endif
6469 CHECK_LIVE (LIVEP); \
6470 } while (0) \
6471 6759
6472 /* Check both of the above conditions, for symbols. */ 6760 /* Perform some sanity checks on the objects marked here. Abort if
6473#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \ 6761 we encounter an object we know is bogus. This increases GC time
6474 do { \ 6762 by ~80%. */
6475 if (!c_symbol_p (ptr)) \ 6763#if GC_CHECK_MARKED_OBJECTS
6476 { \ 6764
6477 CHECK_ALLOCATED (); \ 6765 /* Check that the object pointed to by PO is known to be a Lisp
6478 CHECK_LIVE (live_symbol_p); \ 6766 structure allocated from the heap. */
6479 } \ 6767#define CHECK_ALLOCATED() \
6480 } while (0) \ 6768 do { \
6769 if (pdumper_object_p (po)) \
6770 { \
6771 if (!pdumper_object_p_precise (po)) \
6772 emacs_abort (); \
6773 break; \
6774 } \
6775 m = mem_find (po); \
6776 if (m == MEM_NIL) \
6777 emacs_abort (); \
6778 } while (0)
6779
6780 /* Check that the object pointed to by PO is live, using predicate
6781 function LIVEP. */
6782#define CHECK_LIVE(LIVEP, MEM_TYPE) \
6783 do { \
6784 if (pdumper_object_p (po)) \
6785 break; \
6786 if (! (m->type == MEM_TYPE && LIVEP (m, po))) \
6787 emacs_abort (); \
6788 } while (0)
6789
6790 /* Check both of the above conditions, for non-symbols. */
6791#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) \
6792 do { \
6793 CHECK_ALLOCATED (); \
6794 CHECK_LIVE (LIVEP, MEM_TYPE); \
6795 } while (false)
6796
6797 /* Check both of the above conditions, for symbols. */
6798#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \
6799 do { \
6800 if (!c_symbol_p (ptr)) \
6801 { \
6802 CHECK_ALLOCATED (); \
6803 CHECK_LIVE (live_symbol_p, MEM_TYPE_SYMBOL); \
6804 } \
6805 } while (false)
6481 6806
6482#else /* not GC_CHECK_MARKED_OBJECTS */ 6807#else /* not GC_CHECK_MARKED_OBJECTS */
6483 6808
6484#define CHECK_LIVE(LIVEP) ((void) 0) 6809#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) ((void) 0)
6485#define CHECK_ALLOCATED_AND_LIVE(LIVEP) ((void) 0) 6810#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0)
6486#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0)
6487 6811
6488#endif /* not GC_CHECK_MARKED_OBJECTS */ 6812#endif /* not GC_CHECK_MARKED_OBJECTS */
6489 6813
6490 switch (XTYPE (obj)) 6814 switch (XTYPE (obj))
6491 { 6815 {
6492 case Lisp_String: 6816 case Lisp_String:
6493 { 6817 {
6494 register struct Lisp_String *ptr = XSTRING (obj); 6818 register struct Lisp_String *ptr = XSTRING (obj);
6495 if (STRING_MARKED_P (ptr)) 6819 if (string_marked_p (ptr))
6496 break; 6820 break;
6497 CHECK_ALLOCATED_AND_LIVE (live_string_p); 6821 CHECK_ALLOCATED_AND_LIVE (live_string_p, MEM_TYPE_STRING);
6498 MARK_STRING (ptr); 6822 set_string_marked (ptr);
6499 MARK_INTERVAL_TREE (ptr->intervals); 6823 mark_interval_tree (ptr->u.s.intervals);
6500#ifdef GC_CHECK_STRING_BYTES 6824#ifdef GC_CHECK_STRING_BYTES
6501 /* Check that the string size recorded in the string is the 6825 /* Check that the string size recorded in the string is the
6502 same as the one recorded in the sdata structure. */ 6826 same as the one recorded in the sdata structure. */
6503 string_bytes (ptr); 6827 string_bytes (ptr);
6504#endif /* GC_CHECK_STRING_BYTES */ 6828#endif /* GC_CHECK_STRING_BYTES */
6505 } 6829 }
6506 break;
6507
6508 case Lisp_Vectorlike:
6509 {
6510 register struct Lisp_Vector *ptr = XVECTOR (obj);
6511
6512 if (VECTOR_MARKED_P (ptr))
6513 break; 6830 break;
6514 6831
6515#if GC_CHECK_MARKED_OBJECTS 6832 case Lisp_Vectorlike:
6516 m = mem_find (po);
6517 if (m == MEM_NIL && !SUBRP (obj) && !main_thread_p (po))
6518 emacs_abort ();
6519#endif /* GC_CHECK_MARKED_OBJECTS */
6520
6521 enum pvec_type pvectype
6522 = PSEUDOVECTOR_TYPE (ptr);
6523
6524 if (pvectype != PVEC_SUBR
6525 && pvectype != PVEC_BUFFER
6526 && !main_thread_p (po))
6527 CHECK_LIVE (live_vector_p);
6528
6529 switch (pvectype)
6530 { 6833 {
6531 case PVEC_BUFFER: 6834 register struct Lisp_Vector *ptr = XVECTOR (obj);
6532#if GC_CHECK_MARKED_OBJECTS
6533 {
6534 struct buffer *b;
6535 FOR_EACH_BUFFER (b)
6536 if (b == po)
6537 break;
6538 if (b == NULL)
6539 emacs_abort ();
6540 }
6541#endif /* GC_CHECK_MARKED_OBJECTS */
6542 mark_buffer ((struct buffer *) ptr);
6543 break;
6544
6545 case PVEC_COMPILED:
6546 /* Although we could treat this just like a vector, mark_compiled
6547 returns the COMPILED_CONSTANTS element, which is marked at the
6548 next iteration of goto-loop here. This is done to avoid a few
6549 recursive calls to mark_object. */
6550 obj = mark_compiled (ptr);
6551 if (!NILP (obj))
6552 goto loop;
6553 break;
6554
6555 case PVEC_FRAME:
6556 {
6557 struct frame *f = (struct frame *) ptr;
6558 6835
6559 mark_vectorlike (ptr); 6836 if (vector_marked_p (ptr))
6560 mark_face_cache (f->face_cache); 6837 break;
6561#ifdef HAVE_WINDOW_SYSTEM
6562 if (FRAME_WINDOW_P (f) && FRAME_X_OUTPUT (f))
6563 {
6564 struct font *font = FRAME_FONT (f);
6565 6838
6566 if (font && !VECTOR_MARKED_P (font)) 6839 enum pvec_type pvectype
6567 mark_vectorlike ((struct Lisp_Vector *) font); 6840 = PSEUDOVECTOR_TYPE (ptr);
6568 } 6841
6842#ifdef GC_CHECK_MARKED_OBJECTS
6843 if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po))
6844 {
6845 m = mem_find (po);
6846 if (m == MEM_NIL)
6847 emacs_abort ();
6848 if (m->type == MEM_TYPE_VECTORLIKE)
6849 CHECK_LIVE (live_large_vector_p, MEM_TYPE_VECTORLIKE);
6850 else
6851 CHECK_LIVE (live_small_vector_p, MEM_TYPE_VECTOR_BLOCK);
6852 }
6569#endif 6853#endif
6570 }
6571 break;
6572 6854
6573 case PVEC_WINDOW: 6855 switch (pvectype)
6574 { 6856 {
6575 struct window *w = (struct window *) ptr; 6857 case PVEC_BUFFER:
6858 mark_buffer ((struct buffer *) ptr);
6859 break;
6860
6861 case PVEC_FRAME:
6862 mark_frame (ptr);
6863 break;
6576 6864
6577 mark_vectorlike (ptr); 6865 case PVEC_WINDOW:
6866 mark_window (ptr);
6867 break;
6578 6868
6579 /* Mark glyph matrices, if any. Marking window 6869 case PVEC_HASH_TABLE:
6580 matrices is sufficient because frame matrices
6581 use the same glyph memory. */
6582 if (w->current_matrix)
6583 { 6870 {
6584 mark_glyph_matrix (w->current_matrix); 6871 struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *)ptr;
6585 mark_glyph_matrix (w->desired_matrix); 6872 ptrdiff_t size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
6873 set_vector_marked (ptr);
6874 mark_stack_push_values (ptr->contents, size);
6875 mark_stack_push_value (h->test.name);
6876 mark_stack_push_value (h->test.user_hash_function);
6877 mark_stack_push_value (h->test.user_cmp_function);
6878 if (NILP (h->weak))
6879 mark_stack_push_value (h->key_and_value);
6880 else
6881 {
6882 /* For weak tables, mark only the vector and not its
6883 contents --- that's what makes it weak. */
6884 eassert (h->next_weak == NULL);
6885 h->next_weak = weak_hash_tables;
6886 weak_hash_tables = h;
6887 set_vector_marked (XVECTOR (h->key_and_value));
6888 }
6889 break;
6586 } 6890 }
6587 6891
6588 /* Filter out killed buffers from both buffer lists 6892 case PVEC_CHAR_TABLE:
6589 in attempt to help GC to reclaim killed buffers faster. 6893 case PVEC_SUB_CHAR_TABLE:
6590 We can do it elsewhere for live windows, but this is the 6894 mark_char_table (ptr, (enum pvec_type) pvectype);
6591 best place to do it for dead windows. */ 6895 break;
6592 wset_prev_buffers 6896
6593 (w, mark_discard_killed_buffers (w->prev_buffers)); 6897 case PVEC_BOOL_VECTOR:
6594 wset_next_buffers 6898 /* bool vectors in a dump are permanently "marked", since
6595 (w, mark_discard_killed_buffers (w->next_buffers)); 6899 they're in the old section and don't have mark bits.
6596 } 6900 If we're looking at a dumped bool vector, we should
6597 break; 6901 have aborted above when we called vector_marked_p, so
6598 6902 we should never get here. */
6599 case PVEC_HASH_TABLE: 6903 eassert (!pdumper_object_p (ptr));
6600 { 6904 set_vector_marked (ptr);
6601 struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *) ptr; 6905 break;
6602 6906
6603 mark_vectorlike (ptr); 6907 case PVEC_OVERLAY:
6604 mark_object (h->test.name); 6908 mark_overlay (XOVERLAY (obj));
6605 mark_object (h->test.user_hash_function); 6909 break;
6606 mark_object (h->test.user_cmp_function); 6910
6607 /* If hash table is not weak, mark all keys and values. 6911 case PVEC_SUBR:
6608 For weak tables, mark only the vector. */ 6912#ifdef HAVE_NATIVE_COMP
6609 if (NILP (h->weak)) 6913 if (SUBR_NATIVE_COMPILEDP (obj))
6610 mark_object (h->key_and_value); 6914 {
6611 else 6915 set_vector_marked (ptr);
6612 VECTOR_MARK (XVECTOR (h->key_and_value)); 6916 struct Lisp_Subr *subr = XSUBR (obj);
6613 } 6917 mark_stack_push_value (subr->intspec.native);
6614 break; 6918 mark_stack_push_value (subr->command_modes);
6615 6919 mark_stack_push_value (subr->native_comp_u);
6616 case PVEC_CHAR_TABLE: 6920 mark_stack_push_value (subr->lambda_list);
6617 case PVEC_SUB_CHAR_TABLE: 6921 mark_stack_push_value (subr->type);
6618 mark_char_table (ptr, (enum pvec_type) pvectype); 6922 }
6619 break; 6923#endif
6620 6924 break;
6621 case PVEC_BOOL_VECTOR:
6622 /* No Lisp_Objects to mark in a bool vector. */
6623 VECTOR_MARK (ptr);
6624 break;
6625
6626 case PVEC_SUBR:
6627 break;
6628 6925
6629 case PVEC_FREE: 6926 case PVEC_FREE:
6630 emacs_abort (); 6927 emacs_abort ();
6631 6928
6632 default: 6929 default:
6633 mark_vectorlike (ptr); 6930 {
6931 /* A regular vector or pseudovector needing no special
6932 treatment. */
6933 ptrdiff_t size = ptr->header.size;
6934 if (size & PSEUDOVECTOR_FLAG)
6935 size &= PSEUDOVECTOR_SIZE_MASK;
6936 set_vector_marked (ptr);
6937 mark_stack_push_values (ptr->contents, size);
6938 }
6939 break;
6940 }
6634 } 6941 }
6635 }
6636 break;
6637
6638 case Lisp_Symbol:
6639 {
6640 register struct Lisp_Symbol *ptr = XSYMBOL (obj);
6641 nextsym:
6642 if (ptr->gcmarkbit)
6643 break; 6942 break;
6644 CHECK_ALLOCATED_AND_LIVE_SYMBOL (); 6943
6645 ptr->gcmarkbit = 1; 6944 case Lisp_Symbol:
6646 /* Attempt to catch bogus objects. */
6647 eassert (valid_lisp_object_p (ptr->function));
6648 mark_object (ptr->function);
6649 mark_object (ptr->plist);
6650 switch (ptr->redirect)
6651 { 6945 {
6652 case SYMBOL_PLAINVAL: mark_object (SYMBOL_VAL (ptr)); break; 6946 struct Lisp_Symbol *ptr = XBARE_SYMBOL (obj);
6653 case SYMBOL_VARALIAS: 6947 nextsym:
6654 { 6948 if (symbol_marked_p (ptr))
6655 Lisp_Object tem;
6656 XSETSYMBOL (tem, SYMBOL_ALIAS (ptr));
6657 mark_object (tem);
6658 break; 6949 break;
6659 } 6950 CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
6660 case SYMBOL_LOCALIZED: 6951 set_symbol_marked (ptr);
6661 mark_localized_symbol (ptr); 6952 /* Attempt to catch bogus objects. */
6662 break; 6953 eassert (valid_lisp_object_p (ptr->u.s.function));
6663 case SYMBOL_FORWARDED: 6954 mark_stack_push_value (ptr->u.s.function);
6664 /* If the value is forwarded to a buffer or keyboard field, 6955 mark_stack_push_value (ptr->u.s.plist);
6665 these are marked when we see the corresponding object. 6956 switch (ptr->u.s.redirect)
6666 And if it's forwarded to a C variable, either it's not 6957 {
6667 a Lisp_Object var, or it's staticpro'd already. */ 6958 case SYMBOL_PLAINVAL:
6668 break; 6959 mark_stack_push_value (SYMBOL_VAL (ptr));
6669 default: emacs_abort (); 6960 break;
6961 case SYMBOL_VARALIAS:
6962 {
6963 Lisp_Object tem;
6964 XSETSYMBOL (tem, SYMBOL_ALIAS (ptr));
6965 mark_stack_push_value (tem);
6966 break;
6967 }
6968 case SYMBOL_LOCALIZED:
6969 mark_localized_symbol (ptr);
6970 break;
6971 case SYMBOL_FORWARDED:
6972 /* If the value is forwarded to a buffer or keyboard field,
6973 these are marked when we see the corresponding object.
6974 And if it's forwarded to a C variable, either it's not
6975 a Lisp_Object var, or it's staticpro'd already. */
6976 break;
6977 default: emacs_abort ();
6978 }
6979 if (!PURE_P (XSTRING (ptr->u.s.name)))
6980 set_string_marked (XSTRING (ptr->u.s.name));
6981 mark_interval_tree (string_intervals (ptr->u.s.name));
6982 /* Inner loop to mark next symbol in this bucket, if any. */
6983 po = ptr = ptr->u.s.next;
6984 if (ptr)
6985 goto nextsym;
6670 } 6986 }
6671 if (!PURE_P (XSTRING (ptr->name))) 6987 break;
6672 MARK_STRING (XSTRING (ptr->name));
6673 MARK_INTERVAL_TREE (string_intervals (ptr->name));
6674 /* Inner loop to mark next symbol in this bucket, if any. */
6675 po = ptr = ptr->next;
6676 if (ptr)
6677 goto nextsym;
6678 }
6679 break;
6680
6681 case Lisp_Misc:
6682 CHECK_ALLOCATED_AND_LIVE (live_misc_p);
6683 6988
6684 if (XMISCANY (obj)->gcmarkbit) 6989 case Lisp_Cons:
6685 break; 6990 {
6991 struct Lisp_Cons *ptr = XCONS (obj);
6992 if (cons_marked_p (ptr))
6993 break;
6994 CHECK_ALLOCATED_AND_LIVE (live_cons_p, MEM_TYPE_CONS);
6995 set_cons_marked (ptr);
6996 /* Avoid growing the stack if the cdr is nil.
6997 In any case, make sure the car is expanded first. */
6998 if (!NILP (ptr->u.s.u.cdr))
6999 {
7000 mark_stack_push_value (ptr->u.s.u.cdr);
7001#if GC_CDR_COUNT
7002 cdr_count++;
7003 if (cdr_count == mark_object_loop_halt)
7004 emacs_abort ();
7005#endif
7006 }
7007 /* Speedup hack for the common case (successive list elements). */
7008 obj = ptr->u.s.car;
7009 goto mark_obj;
7010 }
6686 7011
6687 switch (XMISCTYPE (obj)) 7012 case Lisp_Float:
6688 { 7013 CHECK_ALLOCATED_AND_LIVE (live_float_p, MEM_TYPE_FLOAT);
6689 case Lisp_Misc_Marker: 7014 /* Do not mark floats stored in a dump image: these floats are
6690 /* DO NOT mark thru the marker's chain. 7015 "cold" and do not have mark bits. */
6691 The buffer's markers chain does not preserve markers from gc; 7016 if (pdumper_object_p (XFLOAT (obj)))
6692 instead, markers are removed from the chain when freed by gc. */ 7017 eassert (pdumper_cold_object_p (XFLOAT (obj)));
6693 XMISCANY (obj)->gcmarkbit = 1; 7018 else if (!XFLOAT_MARKED_P (XFLOAT (obj)))
7019 XFLOAT_MARK (XFLOAT (obj));
6694 break; 7020 break;
6695 7021
6696 case Lisp_Misc_Save_Value: 7022 case_Lisp_Int:
6697 XMISCANY (obj)->gcmarkbit = 1;
6698 mark_save_value (XSAVE_VALUE (obj));
6699 break; 7023 break;
6700 7024
6701 case Lisp_Misc_Overlay:
6702 mark_overlay (XOVERLAY (obj));
6703 break;
6704
6705 case Lisp_Misc_Finalizer:
6706 XMISCANY (obj)->gcmarkbit = true;
6707 mark_object (XFINALIZER (obj)->function);
6708 break;
6709
6710#ifdef HAVE_MODULES
6711 case Lisp_Misc_User_Ptr:
6712 XMISCANY (obj)->gcmarkbit = true;
6713 break;
6714#endif
6715
6716 default: 7025 default:
6717 emacs_abort (); 7026 emacs_abort ();
6718 } 7027 }
6719 break;
6720
6721 case Lisp_Cons:
6722 {
6723 register struct Lisp_Cons *ptr = XCONS (obj);
6724 if (CONS_MARKED_P (ptr))
6725 break;
6726 CHECK_ALLOCATED_AND_LIVE (live_cons_p);
6727 CONS_MARK (ptr);
6728 /* If the cdr is nil, avoid recursion for the car. */
6729 if (EQ (ptr->u.cdr, Qnil))
6730 {
6731 obj = ptr->car;
6732 cdr_count = 0;
6733 goto loop;
6734 }
6735 mark_object (ptr->car);
6736 obj = ptr->u.cdr;
6737 cdr_count++;
6738 if (cdr_count == mark_object_loop_halt)
6739 emacs_abort ();
6740 goto loop;
6741 }
6742
6743 case Lisp_Float:
6744 CHECK_ALLOCATED_AND_LIVE (live_float_p);
6745 FLOAT_MARK (XFLOAT (obj));
6746 break;
6747
6748 case_Lisp_Int:
6749 break;
6750
6751 default:
6752 emacs_abort ();
6753 } 7028 }
6754 7029
6755#undef CHECK_LIVE 7030#undef CHECK_LIVE
6756#undef CHECK_ALLOCATED 7031#undef CHECK_ALLOCATED
6757#undef CHECK_ALLOCATED_AND_LIVE 7032#undef CHECK_ALLOCATED_AND_LIVE
6758} 7033}
7034
7035void
7036mark_object (Lisp_Object obj)
7037{
7038 ptrdiff_t sp = mark_stk.sp;
7039 mark_stack_push_value (obj);
7040 process_mark_stack (sp);
7041}
7042
7043void
7044mark_objects (Lisp_Object *objs, ptrdiff_t n)
7045{
7046 ptrdiff_t sp = mark_stk.sp;
7047 mark_stack_push_values (objs, n);
7048 process_mark_stack (sp);
7049}
7050
6759/* Mark the Lisp pointers in the terminal objects. 7051/* Mark the Lisp pointers in the terminal objects.
6760 Called by Fgarbage_collect. */ 7052 Called by Fgarbage_collect. */
6761 7053
@@ -6772,13 +7064,11 @@ mark_terminals (void)
6772 gets marked. */ 7064 gets marked. */
6773 mark_image_cache (t->image_cache); 7065 mark_image_cache (t->image_cache);
6774#endif /* HAVE_WINDOW_SYSTEM */ 7066#endif /* HAVE_WINDOW_SYSTEM */
6775 if (!VECTOR_MARKED_P (t)) 7067 if (!vectorlike_marked_p (&t->header))
6776 mark_vectorlike ((struct Lisp_Vector *)t); 7068 mark_vectorlike (&t->header);
6777 } 7069 }
6778} 7070}
6779 7071
6780
6781
6782/* Value is non-zero if OBJ will survive the current GC because it's 7072/* Value is non-zero if OBJ will survive the current GC because it's
6783 either marked or does not need to be marked to survive. */ 7073 either marked or does not need to be marked to survive. */
6784 7074
@@ -6790,31 +7080,31 @@ survives_gc_p (Lisp_Object obj)
6790 switch (XTYPE (obj)) 7080 switch (XTYPE (obj))
6791 { 7081 {
6792 case_Lisp_Int: 7082 case_Lisp_Int:
6793 survives_p = 1; 7083 survives_p = true;
6794 break; 7084 break;
6795 7085
6796 case Lisp_Symbol: 7086 case Lisp_Symbol:
6797 survives_p = XSYMBOL (obj)->gcmarkbit; 7087 survives_p = symbol_marked_p (XBARE_SYMBOL (obj));
6798 break;
6799
6800 case Lisp_Misc:
6801 survives_p = XMISCANY (obj)->gcmarkbit;
6802 break; 7088 break;
6803 7089
6804 case Lisp_String: 7090 case Lisp_String:
6805 survives_p = STRING_MARKED_P (XSTRING (obj)); 7091 survives_p = string_marked_p (XSTRING (obj));
6806 break; 7092 break;
6807 7093
6808 case Lisp_Vectorlike: 7094 case Lisp_Vectorlike:
6809 survives_p = SUBRP (obj) || VECTOR_MARKED_P (XVECTOR (obj)); 7095 survives_p =
7096 (SUBRP (obj) && !SUBR_NATIVE_COMPILEDP (obj)) ||
7097 vector_marked_p (XVECTOR (obj));
6810 break; 7098 break;
6811 7099
6812 case Lisp_Cons: 7100 case Lisp_Cons:
6813 survives_p = CONS_MARKED_P (XCONS (obj)); 7101 survives_p = cons_marked_p (XCONS (obj));
6814 break; 7102 break;
6815 7103
6816 case Lisp_Float: 7104 case Lisp_Float:
6817 survives_p = FLOAT_MARKED_P (XFLOAT (obj)); 7105 survives_p =
7106 XFLOAT_MARKED_P (XFLOAT (obj)) ||
7107 pdumper_object_p (XFLOAT (obj));
6818 break; 7108 break;
6819 7109
6820 default: 7110 default:
@@ -6831,14 +7121,13 @@ NO_INLINE /* For better stack traces */
6831static void 7121static void
6832sweep_conses (void) 7122sweep_conses (void)
6833{ 7123{
6834 struct cons_block *cblk;
6835 struct cons_block **cprev = &cons_block; 7124 struct cons_block **cprev = &cons_block;
6836 int lim = cons_block_index; 7125 int lim = cons_block_index;
6837 EMACS_INT num_free = 0, num_used = 0; 7126 object_ct num_free = 0, num_used = 0;
6838 7127
6839 cons_free_list = 0; 7128 cons_free_list = 0;
6840 7129
6841 for (cblk = cons_block; cblk; cblk = *cprev) 7130 for (struct cons_block *cblk; (cblk = *cprev); )
6842 { 7131 {
6843 int i = 0; 7132 int i = 0;
6844 int this_free = 0; 7133 int this_free = 0;
@@ -6867,17 +7156,18 @@ sweep_conses (void)
6867 7156
6868 for (pos = start; pos < stop; pos++) 7157 for (pos = start; pos < stop; pos++)
6869 { 7158 {
6870 if (!CONS_MARKED_P (&cblk->conses[pos])) 7159 struct Lisp_Cons *acons = &cblk->conses[pos];
7160 if (!XCONS_MARKED_P (acons))
6871 { 7161 {
6872 this_free++; 7162 this_free++;
6873 cblk->conses[pos].u.chain = cons_free_list; 7163 cblk->conses[pos].u.s.u.chain = cons_free_list;
6874 cons_free_list = &cblk->conses[pos]; 7164 cons_free_list = &cblk->conses[pos];
6875 cons_free_list->car = Vdead; 7165 cons_free_list->u.s.car = dead_object ();
6876 } 7166 }
6877 else 7167 else
6878 { 7168 {
6879 num_used++; 7169 num_used++;
6880 CONS_UNMARK (&cblk->conses[pos]); 7170 XUNMARK_CONS (acons);
6881 } 7171 }
6882 } 7172 }
6883 } 7173 }
@@ -6891,7 +7181,7 @@ sweep_conses (void)
6891 { 7181 {
6892 *cprev = cblk->next; 7182 *cprev = cblk->next;
6893 /* Unhook from the free list. */ 7183 /* Unhook from the free list. */
6894 cons_free_list = cblk->conses[0].u.chain; 7184 cons_free_list = cblk->conses[0].u.s.u.chain;
6895 lisp_align_free (cblk); 7185 lisp_align_free (cblk);
6896 } 7186 }
6897 else 7187 else
@@ -6900,37 +7190,38 @@ sweep_conses (void)
6900 cprev = &cblk->next; 7190 cprev = &cblk->next;
6901 } 7191 }
6902 } 7192 }
6903 total_conses = num_used; 7193 gcstat.total_conses = num_used;
6904 total_free_conses = num_free; 7194 gcstat.total_free_conses = num_free;
6905} 7195}
6906 7196
6907NO_INLINE /* For better stack traces */ 7197NO_INLINE /* For better stack traces */
6908static void 7198static void
6909sweep_floats (void) 7199sweep_floats (void)
6910{ 7200{
6911 register struct float_block *fblk;
6912 struct float_block **fprev = &float_block; 7201 struct float_block **fprev = &float_block;
6913 register int lim = float_block_index; 7202 int lim = float_block_index;
6914 EMACS_INT num_free = 0, num_used = 0; 7203 object_ct num_free = 0, num_used = 0;
6915 7204
6916 float_free_list = 0; 7205 float_free_list = 0;
6917 7206
6918 for (fblk = float_block; fblk; fblk = *fprev) 7207 for (struct float_block *fblk; (fblk = *fprev); )
6919 { 7208 {
6920 register int i;
6921 int this_free = 0; 7209 int this_free = 0;
6922 for (i = 0; i < lim; i++) 7210 for (int i = 0; i < lim; i++)
6923 if (!FLOAT_MARKED_P (&fblk->floats[i])) 7211 {
6924 { 7212 struct Lisp_Float *afloat = &fblk->floats[i];
6925 this_free++; 7213 if (!XFLOAT_MARKED_P (afloat))
6926 fblk->floats[i].u.chain = float_free_list; 7214 {
6927 float_free_list = &fblk->floats[i]; 7215 this_free++;
6928 } 7216 fblk->floats[i].u.chain = float_free_list;
6929 else 7217 float_free_list = &fblk->floats[i];
6930 { 7218 }
6931 num_used++; 7219 else
6932 FLOAT_UNMARK (&fblk->floats[i]); 7220 {
6933 } 7221 num_used++;
7222 XFLOAT_UNMARK (afloat);
7223 }
7224 }
6934 lim = FLOAT_BLOCK_SIZE; 7225 lim = FLOAT_BLOCK_SIZE;
6935 /* If this block contains only free floats and we have already 7226 /* If this block contains only free floats and we have already
6936 seen more than two blocks worth of free floats then deallocate 7227 seen more than two blocks worth of free floats then deallocate
@@ -6948,27 +7239,25 @@ sweep_floats (void)
6948 fprev = &fblk->next; 7239 fprev = &fblk->next;
6949 } 7240 }
6950 } 7241 }
6951 total_floats = num_used; 7242 gcstat.total_floats = num_used;
6952 total_free_floats = num_free; 7243 gcstat.total_free_floats = num_free;
6953} 7244}
6954 7245
6955NO_INLINE /* For better stack traces */ 7246NO_INLINE /* For better stack traces */
6956static void 7247static void
6957sweep_intervals (void) 7248sweep_intervals (void)
6958{ 7249{
6959 register struct interval_block *iblk;
6960 struct interval_block **iprev = &interval_block; 7250 struct interval_block **iprev = &interval_block;
6961 register int lim = interval_block_index; 7251 int lim = interval_block_index;
6962 EMACS_INT num_free = 0, num_used = 0; 7252 object_ct num_free = 0, num_used = 0;
6963 7253
6964 interval_free_list = 0; 7254 interval_free_list = 0;
6965 7255
6966 for (iblk = interval_block; iblk; iblk = *iprev) 7256 for (struct interval_block *iblk; (iblk = *iprev); )
6967 { 7257 {
6968 register int i;
6969 int this_free = 0; 7258 int this_free = 0;
6970 7259
6971 for (i = 0; i < lim; i++) 7260 for (int i = 0; i < lim; i++)
6972 { 7261 {
6973 if (!iblk->intervals[i].gcmarkbit) 7262 if (!iblk->intervals[i].gcmarkbit)
6974 { 7263 {
@@ -6999,8 +7288,8 @@ sweep_intervals (void)
6999 iprev = &iblk->next; 7288 iprev = &iblk->next;
7000 } 7289 }
7001 } 7290 }
7002 total_intervals = num_used; 7291 gcstat.total_intervals = num_used;
7003 total_free_intervals = num_free; 7292 gcstat.total_free_intervals = num_free;
7004} 7293}
7005 7294
7006NO_INLINE /* For better stack traces */ 7295NO_INLINE /* For better stack traces */
@@ -7010,36 +7299,44 @@ sweep_symbols (void)
7010 struct symbol_block *sblk; 7299 struct symbol_block *sblk;
7011 struct symbol_block **sprev = &symbol_block; 7300 struct symbol_block **sprev = &symbol_block;
7012 int lim = symbol_block_index; 7301 int lim = symbol_block_index;
7013 EMACS_INT num_free = 0, num_used = ARRAYELTS (lispsym); 7302 object_ct num_free = 0, num_used = ARRAYELTS (lispsym);
7014 7303
7015 symbol_free_list = NULL; 7304 symbol_free_list = NULL;
7016 7305
7017 for (int i = 0; i < ARRAYELTS (lispsym); i++) 7306 for (int i = 0; i < ARRAYELTS (lispsym); i++)
7018 lispsym[i].s.gcmarkbit = 0; 7307 lispsym[i].u.s.gcmarkbit = 0;
7019 7308
7020 for (sblk = symbol_block; sblk; sblk = *sprev) 7309 for (sblk = symbol_block; sblk; sblk = *sprev)
7021 { 7310 {
7022 int this_free = 0; 7311 int this_free = 0;
7023 union aligned_Lisp_Symbol *sym = sblk->symbols; 7312 struct Lisp_Symbol *sym = sblk->symbols;
7024 union aligned_Lisp_Symbol *end = sym + lim; 7313 struct Lisp_Symbol *end = sym + lim;
7025 7314
7026 for (; sym < end; ++sym) 7315 for (; sym < end; ++sym)
7027 { 7316 {
7028 if (!sym->s.gcmarkbit) 7317 if (!sym->u.s.gcmarkbit)
7029 { 7318 {
7030 if (sym->s.redirect == SYMBOL_LOCALIZED) 7319 if (sym->u.s.redirect == SYMBOL_LOCALIZED)
7031 xfree (SYMBOL_BLV (&sym->s)); 7320 {
7032 sym->s.next = symbol_free_list; 7321 xfree (SYMBOL_BLV (sym));
7033 symbol_free_list = &sym->s; 7322 /* At every GC we sweep all symbol_blocks and rebuild the
7034 symbol_free_list->function = Vdead; 7323 symbol_free_list, so those symbols which stayed unused
7324 between the two will be re-swept.
7325 So we have to make sure we don't re-free this blv next
7326 time we sweep this symbol_block (bug#29066). */
7327 sym->u.s.redirect = SYMBOL_PLAINVAL;
7328 }
7329 sym->u.s.next = symbol_free_list;
7330 symbol_free_list = sym;
7331 symbol_free_list->u.s.function = dead_object ();
7035 ++this_free; 7332 ++this_free;
7036 } 7333 }
7037 else 7334 else
7038 { 7335 {
7039 ++num_used; 7336 ++num_used;
7040 sym->s.gcmarkbit = 0; 7337 sym->u.s.gcmarkbit = 0;
7041 /* Attempt to catch bogus objects. */ 7338 /* Attempt to catch bogus objects. */
7042 eassert (valid_lisp_object_p (sym->s.function)); 7339 eassert (valid_lisp_object_p (sym->u.s.function));
7043 } 7340 }
7044 } 7341 }
7045 7342
@@ -7051,7 +7348,7 @@ sweep_symbols (void)
7051 { 7348 {
7052 *sprev = sblk->next; 7349 *sprev = sblk->next;
7053 /* Unhook from the free list. */ 7350 /* Unhook from the free list. */
7054 symbol_free_list = sblk->symbols[0].s.next; 7351 symbol_free_list = sblk->symbols[0].u.s.next;
7055 lisp_free (sblk); 7352 lisp_free (sblk);
7056 } 7353 }
7057 else 7354 else
@@ -7060,127 +7357,57 @@ sweep_symbols (void)
7060 sprev = &sblk->next; 7357 sprev = &sblk->next;
7061 } 7358 }
7062 } 7359 }
7063 total_symbols = num_used; 7360 gcstat.total_symbols = num_used;
7064 total_free_symbols = num_free; 7361 gcstat.total_free_symbols = num_free;
7065} 7362}
7066 7363
7067NO_INLINE /* For better stack traces. */ 7364/* Remove BUFFER's markers that are due to be swept. This is needed since
7365 we treat BUF_MARKERS and markers's `next' field as weak pointers. */
7068static void 7366static void
7069sweep_misc (void) 7367unchain_dead_markers (struct buffer *buffer)
7070{ 7368{
7071 register struct marker_block *mblk; 7369 struct Lisp_Marker *this, **prev = &BUF_MARKERS (buffer);
7072 struct marker_block **mprev = &marker_block;
7073 register int lim = marker_block_index;
7074 EMACS_INT num_free = 0, num_used = 0;
7075
7076 /* Put all unmarked misc's on free list. For a marker, first
7077 unchain it from the buffer it points into. */
7078
7079 marker_free_list = 0;
7080
7081 for (mblk = marker_block; mblk; mblk = *mprev)
7082 {
7083 register int i;
7084 int this_free = 0;
7085
7086 for (i = 0; i < lim; i++)
7087 {
7088 if (!mblk->markers[i].m.u_any.gcmarkbit)
7089 {
7090 if (mblk->markers[i].m.u_any.type == Lisp_Misc_Marker)
7091 unchain_marker (&mblk->markers[i].m.u_marker);
7092 else if (mblk->markers[i].m.u_any.type == Lisp_Misc_Finalizer)
7093 unchain_finalizer (&mblk->markers[i].m.u_finalizer);
7094 else if (mblk->markers[i].m.u_any.type == Lisp_Misc_Overlay)
7095 {
7096 xfree (mblk->markers[i].m.u_overlay.interval);
7097 mblk->markers[i].m.u_overlay.interval = NULL;
7098 }
7099#ifdef HAVE_MODULES
7100 else if (mblk->markers[i].m.u_any.type == Lisp_Misc_User_Ptr)
7101 {
7102 struct Lisp_User_Ptr *uptr = &mblk->markers[i].m.u_user_ptr;
7103 if (uptr->finalizer)
7104 uptr->finalizer (uptr->p);
7105 }
7106#endif
7107 /* Set the type of the freed object to Lisp_Misc_Free.
7108 We could leave the type alone, since nobody checks it,
7109 but this might catch bugs faster. */
7110 mblk->markers[i].m.u_marker.type = Lisp_Misc_Free;
7111 mblk->markers[i].m.u_free.chain = marker_free_list;
7112 marker_free_list = &mblk->markers[i].m;
7113 this_free++;
7114 }
7115 else
7116 {
7117 num_used++;
7118 mblk->markers[i].m.u_any.gcmarkbit = 0;
7119 }
7120 }
7121 lim = MARKER_BLOCK_SIZE;
7122 /* If this block contains only free markers and we have already
7123 seen more than two blocks worth of free markers then deallocate
7124 this block. */
7125 if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE)
7126 {
7127 *mprev = mblk->next;
7128 /* Unhook from the free list. */
7129 marker_free_list = mblk->markers[0].m.u_free.chain;
7130 lisp_free (mblk);
7131 }
7132 else
7133 {
7134 num_free += this_free;
7135 mprev = &mblk->next;
7136 }
7137 }
7138 7370
7139 total_markers = num_used; 7371 while ((this = *prev))
7140 total_free_markers = num_free; 7372 if (vectorlike_marked_p (&this->header))
7373 prev = &this->next;
7374 else
7375 {
7376 this->buffer = NULL;
7377 *prev = this->next;
7378 }
7141} 7379}
7142 7380
7143NO_INLINE /* For better stack traces */ 7381NO_INLINE /* For better stack traces */
7144static void 7382static void
7145sweep_buffers (void) 7383sweep_buffers (void)
7146{ 7384{
7147 register struct buffer *buffer, **bprev = &all_buffers; 7385 Lisp_Object tail, buf;
7148 7386
7149 total_buffers = 0; 7387 gcstat.total_buffers = 0;
7150 for (buffer = all_buffers; buffer; buffer = *bprev) 7388 FOR_EACH_LIVE_BUFFER (tail, buf)
7151 if (!VECTOR_MARKED_P (buffer)) 7389 {
7152 { 7390 struct buffer *buffer = XBUFFER (buf);
7153 *bprev = buffer->next; 7391 /* Do not use buffer_(set|get)_intervals here. */
7154 free_buffer_overlays (buffer); 7392 buffer->text->intervals = balance_intervals (buffer->text->intervals);
7155 lisp_free (buffer); 7393 unchain_dead_markers (buffer);
7156 } 7394 gcstat.total_buffers++;
7157 else 7395 }
7158 {
7159 VECTOR_UNMARK (buffer);
7160 /* Do not use buffer_(set|get)_intervals here. */
7161 buffer->text->intervals = balance_intervals (buffer->text->intervals);
7162 total_buffers++;
7163 bprev = &buffer->next;
7164 }
7165} 7396}
7166 7397
7167/* Sweep: find all structures not marked, and free them. */ 7398/* Sweep: find all structures not marked, and free them. */
7168static void 7399static void
7169gc_sweep (void) 7400gc_sweep (void)
7170{ 7401{
7171 /* Remove or mark entries in weak hash tables.
7172 This must be done before any object is unmarked. */
7173 sweep_weak_hash_tables ();
7174
7175 sweep_strings (); 7402 sweep_strings ();
7176 check_string_bytes (!noninteractive); 7403 check_string_bytes (!noninteractive);
7177 sweep_conses (); 7404 sweep_conses ();
7178 sweep_floats (); 7405 sweep_floats ();
7179 sweep_intervals (); 7406 sweep_intervals ();
7180 sweep_symbols (); 7407 sweep_symbols ();
7181 sweep_misc ();
7182 sweep_buffers (); 7408 sweep_buffers ();
7183 sweep_vectors (); 7409 sweep_vectors ();
7410 pdumper_clear_marks ();
7184 check_string_bytes (!noninteractive); 7411 check_string_bytes (!noninteractive);
7185} 7412}
7186 7413
@@ -7234,60 +7461,85 @@ or memory information can't be obtained, return nil. */)
7234 7461
7235/* Debugging aids. */ 7462/* Debugging aids. */
7236 7463
7237DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0,
7238 doc: /* Return the address of the last byte Emacs has allocated, divided by 1024.
7239This may be helpful in debugging Emacs's memory usage.
7240We divide the value by 1024 to make sure it fits in a Lisp integer. */)
7241 (void)
7242{
7243 Lisp_Object end;
7244
7245#if defined HAVE_NS || defined __APPLE__ || !HAVE_SBRK
7246 /* Avoid warning. sbrk has no relation to memory allocated anyway. */
7247 XSETINT (end, 0);
7248#else
7249 XSETINT (end, (intptr_t) (char *) sbrk (0) / 1024);
7250#endif
7251
7252 return end;
7253}
7254
7255DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0, 7464DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0,
7256 doc: /* Return a list of counters that measure how much consing there has been. 7465 doc: /* Return a list of counters that measure how much consing there has been.
7257Each of these counters increments for a certain kind of object. 7466Each of these counters increments for a certain kind of object.
7258The counters wrap around from the largest positive integer to zero. 7467The counters wrap around from the largest positive integer to zero.
7259Garbage collection does not decrease them. 7468Garbage collection does not decrease them.
7260The elements of the value are as follows: 7469The elements of the value are as follows:
7261 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS) 7470 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS INTERVALS STRINGS)
7262All are in units of 1 = one object consed 7471All are in units of 1 = one object consed
7263except for VECTOR-CELLS and STRING-CHARS, which count the total length of 7472except for VECTOR-CELLS and STRING-CHARS, which count the total length of
7264objects consed. 7473objects consed.
7265MISCS include overlays, markers, and some internal types.
7266Frames, windows, buffers, and subprocesses count as vectors 7474Frames, windows, buffers, and subprocesses count as vectors
7267 (but the contents of a buffer's text do not count here). */) 7475 (but the contents of a buffer's text do not count here). */)
7268 (void) 7476 (void)
7269{ 7477{
7270 return listn (CONSTYPE_HEAP, 8, 7478 return list (make_int (cons_cells_consed),
7271 bounded_number (cons_cells_consed), 7479 make_int (floats_consed),
7272 bounded_number (floats_consed), 7480 make_int (vector_cells_consed),
7273 bounded_number (vector_cells_consed), 7481 make_int (symbols_consed),
7274 bounded_number (symbols_consed), 7482 make_int (string_chars_consed),
7275 bounded_number (string_chars_consed), 7483 make_int (intervals_consed),
7276 bounded_number (misc_objects_consed), 7484 make_int (strings_consed));
7277 bounded_number (intervals_consed), 7485}
7278 bounded_number (strings_consed)); 7486
7487#if defined GNU_LINUX && defined __GLIBC__ && \
7488 (__GLIBC__ > 2 || __GLIBC_MINOR__ >= 10)
7489DEFUN ("malloc-info", Fmalloc_info, Smalloc_info, 0, 0, "",
7490 doc: /* Report malloc information to stderr.
7491This function outputs to stderr an XML-formatted
7492description of the current state of the memory-allocation
7493arenas. */)
7494 (void)
7495{
7496 if (malloc_info (0, stderr))
7497 error ("malloc_info failed: %s", emacs_strerror (errno));
7498 return Qnil;
7499}
7500#endif
7501
7502#ifdef HAVE_MALLOC_TRIM
7503DEFUN ("malloc-trim", Fmalloc_trim, Smalloc_trim, 0, 1, "",
7504 doc: /* Release free heap memory to the OS.
7505This function asks libc to return unused heap memory back to the operating
7506system. This function isn't guaranteed to do anything, and is mainly
7507meant as a debugging tool.
7508
7509If LEAVE_PADDING is given, ask the system to leave that much unused
7510space in the heap of the Emacs process. This should be an integer, and if
7511not given, it defaults to 0.
7512
7513This function returns nil if no memory could be returned to the
7514system, and non-nil if some memory could be returned. */)
7515 (Lisp_Object leave_padding)
7516{
7517 int pad = 0;
7518
7519 if (! NILP (leave_padding))
7520 {
7521 CHECK_FIXNAT (leave_padding);
7522 pad = XFIXNUM (leave_padding);
7523 }
7524
7525 /* 1 means that memory was released to the system. */
7526 if (malloc_trim (pad) == 1)
7527 return Qt;
7528 else
7529 return Qnil;
7279} 7530}
7531#endif
7280 7532
7281static bool 7533static bool
7282symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj) 7534symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj)
7283{ 7535{
7284 struct Lisp_Symbol *sym = XSYMBOL (symbol); 7536 struct Lisp_Symbol *sym = XBARE_SYMBOL (symbol);
7285 Lisp_Object val = find_symbol_value (symbol); 7537 Lisp_Object val = find_symbol_value (symbol);
7286 return (EQ (val, obj) 7538 return (EQ (val, obj)
7287 || EQ (sym->function, obj) 7539 || EQ (sym->u.s.function, obj)
7288 || (!NILP (sym->function) 7540 || (!NILP (sym->u.s.function)
7289 && COMPILEDP (sym->function) 7541 && COMPILEDP (sym->u.s.function)
7290 && EQ (AREF (sym->function, COMPILED_BYTECODE), obj)) 7542 && EQ (AREF (sym->u.s.function, COMPILED_BYTECODE), obj))
7291 || (!NILP (val) 7543 || (!NILP (val)
7292 && COMPILEDP (val) 7544 && COMPILEDP (val)
7293 && EQ (AREF (val, COMPILED_BYTECODE), obj))); 7545 && EQ (AREF (val, COMPILED_BYTECODE), obj)));
@@ -7300,10 +7552,10 @@ Lisp_Object
7300which_symbols (Lisp_Object obj, EMACS_INT find_max) 7552which_symbols (Lisp_Object obj, EMACS_INT find_max)
7301{ 7553{
7302 struct symbol_block *sblk; 7554 struct symbol_block *sblk;
7303 ptrdiff_t gc_count = inhibit_garbage_collection (); 7555 specpdl_ref gc_count = inhibit_garbage_collection ();
7304 Lisp_Object found = Qnil; 7556 Lisp_Object found = Qnil;
7305 7557
7306 if (! DEADP (obj)) 7558 if (! deadp (obj))
7307 { 7559 {
7308 for (int i = 0; i < ARRAYELTS (lispsym); i++) 7560 for (int i = 0; i < ARRAYELTS (lispsym); i++)
7309 { 7561 {
@@ -7318,15 +7570,15 @@ which_symbols (Lisp_Object obj, EMACS_INT find_max)
7318 7570
7319 for (sblk = symbol_block; sblk; sblk = sblk->next) 7571 for (sblk = symbol_block; sblk; sblk = sblk->next)
7320 { 7572 {
7321 union aligned_Lisp_Symbol *aligned_sym = sblk->symbols; 7573 struct Lisp_Symbol *asym = sblk->symbols;
7322 int bn; 7574 int bn;
7323 7575
7324 for (bn = 0; bn < SYMBOL_BLOCK_SIZE; bn++, aligned_sym++) 7576 for (bn = 0; bn < SYMBOL_BLOCK_SIZE; bn++, asym++)
7325 { 7577 {
7326 if (sblk == symbol_block && bn >= symbol_block_index) 7578 if (sblk == symbol_block && bn >= symbol_block_index)
7327 break; 7579 break;
7328 7580
7329 Lisp_Object sym = make_lisp_symbol (&aligned_sym->s); 7581 Lisp_Object sym = make_lisp_symbol (asym);
7330 if (symbol_uses_obj (sym, obj)) 7582 if (symbol_uses_obj (sym, obj))
7331 { 7583 {
7332 found = Fcons (sym, found); 7584 found = Fcons (sym, found);
@@ -7338,8 +7590,7 @@ which_symbols (Lisp_Object obj, EMACS_INT find_max)
7338 } 7590 }
7339 7591
7340 out: 7592 out:
7341 unbind_to (gc_count, Qnil); 7593 return unbind_to (gc_count, found);
7342 return found;
7343} 7594}
7344 7595
7345#ifdef SUSPICIOUS_OBJECT_CHECKING 7596#ifdef SUSPICIOUS_OBJECT_CHECKING
@@ -7454,32 +7705,46 @@ verify_alloca (void)
7454 7705
7455/* Initialization. */ 7706/* Initialization. */
7456 7707
7708static void init_alloc_once_for_pdumper (void);
7709
7457void 7710void
7458init_alloc_once (void) 7711init_alloc_once (void)
7459{ 7712{
7713 gc_cons_threshold = GC_DEFAULT_THRESHOLD;
7460 /* Even though Qt's contents are not set up, its address is known. */ 7714 /* Even though Qt's contents are not set up, its address is known. */
7461 Vpurify_flag = Qt; 7715 Vpurify_flag = Qt;
7462 7716
7463 purebeg = PUREBEG; 7717 PDUMPER_REMEMBER_SCALAR (buffer_defaults.header);
7464 pure_size = PURESIZE; 7718 PDUMPER_REMEMBER_SCALAR (buffer_local_symbols.header);
7719
7720 /* Call init_alloc_once_for_pdumper now so we run mem_init early.
7721 Keep in mind that when we reload from a dump, we'll run _only_
7722 init_alloc_once_for_pdumper and not init_alloc_once at all. */
7723 pdumper_do_now_and_after_load (init_alloc_once_for_pdumper);
7465 7724
7466 verify_alloca (); 7725 verify_alloca ();
7467 init_finalizer_list (&finalizers);
7468 init_finalizer_list (&doomed_finalizers);
7469 7726
7727 init_strings ();
7728 init_vectors ();
7729}
7730
7731static void
7732init_alloc_once_for_pdumper (void)
7733{
7734 purebeg = PUREBEG;
7735 pure_size = PURESIZE;
7470 mem_init (); 7736 mem_init ();
7471 Vdead = make_pure_string ("DEAD", 4, 4, 0);
7472 7737
7473#ifdef DOUG_LEA_MALLOC 7738#ifdef DOUG_LEA_MALLOC
7474 mallopt (M_TRIM_THRESHOLD, 128 * 1024); /* Trim threshold. */ 7739 mallopt (M_TRIM_THRESHOLD, 128 * 1024); /* Trim threshold. */
7475 mallopt (M_MMAP_THRESHOLD, 64 * 1024); /* Mmap threshold. */ 7740 mallopt (M_MMAP_THRESHOLD, 64 * 1024); /* Mmap threshold. */
7476 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* Max. number of mmap'ed areas. */ 7741 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* Max. number of mmap'ed areas. */
7477#endif 7742#endif
7478 init_strings ();
7479 init_vectors ();
7480 7743
7744
7745 init_finalizer_list (&finalizers);
7746 init_finalizer_list (&doomed_finalizers);
7481 refill_memory_reserve (); 7747 refill_memory_reserve ();
7482 gc_cons_threshold = GC_DEFAULT_THRESHOLD;
7483} 7748}
7484 7749
7485void 7750void
@@ -7487,10 +7752,6 @@ init_alloc (void)
7487{ 7752{
7488 Vgc_elapsed = make_float (0.0); 7753 Vgc_elapsed = make_float (0.0);
7489 gcs_done = 0; 7754 gcs_done = 0;
7490
7491#if USE_VALGRIND
7492 valgrind_p = RUNNING_ON_VALGRIND != 0;
7493#endif
7494} 7755}
7495 7756
7496void 7757void
@@ -7533,11 +7794,6 @@ If this portion is smaller than `gc-cons-threshold', this is ignored. */);
7533 DEFVAR_INT ("string-chars-consed", string_chars_consed, 7794 DEFVAR_INT ("string-chars-consed", string_chars_consed,
7534 doc: /* Number of string characters that have been consed so far. */); 7795 doc: /* Number of string characters that have been consed so far. */);
7535 7796
7536 DEFVAR_INT ("misc-objects-consed", misc_objects_consed,
7537 doc: /* Number of miscellaneous objects that have been consed so far.
7538These include markers and overlays, plus certain objects not visible
7539to users. */);
7540
7541 DEFVAR_INT ("intervals-consed", intervals_consed, 7797 DEFVAR_INT ("intervals-consed", intervals_consed,
7542 doc: /* Number of intervals that have been consed so far. */); 7798 doc: /* Number of intervals that have been consed so far. */);
7543 7799
@@ -7564,8 +7820,10 @@ do hash-consing of the objects allocated to pure space. */);
7564 /* We build this in advance because if we wait until we need it, we might 7820 /* We build this in advance because if we wait until we need it, we might
7565 not be able to allocate the memory to hold it. */ 7821 not be able to allocate the memory to hold it. */
7566 Vmemory_signal_data 7822 Vmemory_signal_data
7567 = listn (CONSTYPE_PURE, 2, Qerror, 7823 = pure_list (Qerror,
7568 build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs")); 7824 build_pure_c_string ("Memory exhausted--use"
7825 " M-x save-some-buffers then"
7826 " exit and restart Emacs"));
7569 7827
7570 DEFVAR_LISP ("memory-full", Vmemory_full, 7828 DEFVAR_LISP ("memory-full", Vmemory_full,
7571 doc: /* Non-nil means Emacs cannot get much more Lisp memory. */); 7829 doc: /* Non-nil means Emacs cannot get much more Lisp memory. */);
@@ -7573,7 +7831,6 @@ do hash-consing of the objects allocated to pure space. */);
7573 7831
7574 DEFSYM (Qconses, "conses"); 7832 DEFSYM (Qconses, "conses");
7575 DEFSYM (Qsymbols, "symbols"); 7833 DEFSYM (Qsymbols, "symbols");
7576 DEFSYM (Qmiscs, "miscs");
7577 DEFSYM (Qstrings, "strings"); 7834 DEFSYM (Qstrings, "strings");
7578 DEFSYM (Qvectors, "vectors"); 7835 DEFSYM (Qvectors, "vectors");
7579 DEFSYM (Qfloats, "floats"); 7836 DEFSYM (Qfloats, "floats");
@@ -7584,6 +7841,7 @@ do hash-consing of the objects allocated to pure space. */);
7584 DEFSYM (Qheap, "heap"); 7841 DEFSYM (Qheap, "heap");
7585 DEFSYM (QAutomatic_GC, "Automatic GC"); 7842 DEFSYM (QAutomatic_GC, "Automatic GC");
7586 7843
7844 DEFSYM (Qgc_cons_percentage, "gc-cons-percentage");
7587 DEFSYM (Qgc_cons_threshold, "gc-cons-threshold"); 7845 DEFSYM (Qgc_cons_threshold, "gc-cons-threshold");
7588 DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots"); 7846 DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots");
7589 7847
@@ -7593,12 +7851,18 @@ The time is in seconds as a floating point value. */);
7593 DEFVAR_INT ("gcs-done", gcs_done, 7851 DEFVAR_INT ("gcs-done", gcs_done,
7594 doc: /* Accumulated number of garbage collections done. */); 7852 doc: /* Accumulated number of garbage collections done. */);
7595 7853
7854 DEFVAR_INT ("integer-width", integer_width,
7855 doc: /* Maximum number N of bits in safely-calculated integers.
7856Integers with absolute values less than 2**N do not signal a range error.
7857N should be nonnegative. */);
7858
7596 defsubr (&Scons); 7859 defsubr (&Scons);
7597 defsubr (&Slist); 7860 defsubr (&Slist);
7598 defsubr (&Svector); 7861 defsubr (&Svector);
7599 defsubr (&Srecord); 7862 defsubr (&Srecord);
7600 defsubr (&Sbool_vector); 7863 defsubr (&Sbool_vector);
7601 defsubr (&Smake_byte_code); 7864 defsubr (&Smake_byte_code);
7865 defsubr (&Smake_closure);
7602 defsubr (&Smake_list); 7866 defsubr (&Smake_list);
7603 defsubr (&Smake_vector); 7867 defsubr (&Smake_vector);
7604 defsubr (&Smake_record); 7868 defsubr (&Smake_record);
@@ -7609,12 +7873,48 @@ The time is in seconds as a floating point value. */);
7609 defsubr (&Smake_finalizer); 7873 defsubr (&Smake_finalizer);
7610 defsubr (&Spurecopy); 7874 defsubr (&Spurecopy);
7611 defsubr (&Sgarbage_collect); 7875 defsubr (&Sgarbage_collect);
7612 defsubr (&Smemory_limit); 7876 defsubr (&Sgarbage_collect_maybe);
7613 defsubr (&Smemory_info); 7877 defsubr (&Smemory_info);
7614 defsubr (&Smemory_use_counts); 7878 defsubr (&Smemory_use_counts);
7879#if defined GNU_LINUX && defined __GLIBC__ && \
7880 (__GLIBC__ > 2 || __GLIBC_MINOR__ >= 10)
7881
7882 defsubr (&Smalloc_info);
7883#endif
7884#ifdef HAVE_MALLOC_TRIM
7885 defsubr (&Smalloc_trim);
7886#endif
7615 defsubr (&Ssuspicious_object); 7887 defsubr (&Ssuspicious_object);
7888
7889 Lisp_Object watcher;
7890
7891 static union Aligned_Lisp_Subr Swatch_gc_cons_threshold =
7892 {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) },
7893 { .a4 = watch_gc_cons_threshold },
7894 4, 4, "watch_gc_cons_threshold", {0}, lisp_h_Qnil}};
7895 XSETSUBR (watcher, &Swatch_gc_cons_threshold.s);
7896 Fadd_variable_watcher (Qgc_cons_threshold, watcher);
7897
7898 static union Aligned_Lisp_Subr Swatch_gc_cons_percentage =
7899 {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) },
7900 { .a4 = watch_gc_cons_percentage },
7901 4, 4, "watch_gc_cons_percentage", {0}, lisp_h_Qnil}};
7902 XSETSUBR (watcher, &Swatch_gc_cons_percentage.s);
7903 Fadd_variable_watcher (Qgc_cons_percentage, watcher);
7616} 7904}
7617 7905
7906#ifdef HAVE_X_WINDOWS
7907enum defined_HAVE_X_WINDOWS { defined_HAVE_X_WINDOWS = true };
7908#else
7909enum defined_HAVE_X_WINDOWS { defined_HAVE_X_WINDOWS = false };
7910#endif
7911
7912#ifdef HAVE_PGTK
7913enum defined_HAVE_PGTK { defined_HAVE_PGTK = true };
7914#else
7915enum defined_HAVE_PGTK { defined_HAVE_PGTK = false };
7916#endif
7917
7618/* When compiled with GCC, GDB might say "No enum type named 7918/* When compiled with GCC, GDB might say "No enum type named
7619 pvec_type" if we don't have at least one symbol with that type, and 7919 pvec_type" if we don't have at least one symbol with that type, and
7620 then xbacktrace could fail. Similarly for the other enums and 7920 then xbacktrace could fail. Similarly for the other enums and
@@ -7633,5 +7933,7 @@ union
7633 enum MAX_ALLOCA MAX_ALLOCA; 7933 enum MAX_ALLOCA MAX_ALLOCA;
7634 enum More_Lisp_Bits More_Lisp_Bits; 7934 enum More_Lisp_Bits More_Lisp_Bits;
7635 enum pvec_type pvec_type; 7935 enum pvec_type pvec_type;
7936 enum defined_HAVE_X_WINDOWS defined_HAVE_X_WINDOWS;
7937 enum defined_HAVE_PGTK defined_HAVE_PGTK;
7636} const EXTERNALLY_VISIBLE gdb_make_enums_visible = {0}; 7938} const EXTERNALLY_VISIBLE gdb_make_enums_visible = {0};
7637#endif /* __GNUC__ */ 7939#endif /* __GNUC__ */
generated by cgit v1.2.1 (git 2.18.0) at 2026-01-15 19:04:22 +0000