root/src/alloc.c

DEFINITIONS

1. malloc_initialize_hook
2. alloc_unexec_pre
3. alloc_unexec_post
4. my_heap_start
5. no_sanitize_memcpy
6. which_symbols
7. deadp
8. pointer_align
9. XPNTR
10. XFLOAT_INIT
11. tally_consing
12. pointers_fit_in_lispobj_p
13. mmap_lisp_allowed_p
14. malloc_warning
15. display_malloc_warning
16. buffer_memory_full
17. malloc_block_input
18. malloc_unblock_input
19. lmalloc
20. xzalloc
21. xrealloc
22. xfree
23. xnmalloc
24. xnrealloc
25. xpalloc
26. xstrdup
27. xlispstrdup
28. dupstring
29. xputenv
30. record_xmalloc
31. lisp_malloc
32. lisp_free
33. aligned_alloc
34. lisp_align_malloc
35. lisp_align_free
36. laligned
37. lmalloc
38. lrealloc
39. make_interval
40. mark_interval_tree_1
41. mark_interval_tree
42. sdata_size
43. init_strings
44. string_bytes
45. check_sblock
46. check_string_bytes
47. check_string_free_list
48. allocate_string
49. allocate_string_data
50. resize_string_data
51. sweep_strings
52. free_large_strings
53. compact_small_strings
54. string_overflow
55. bool_vector_fill
56. make_uninit_bool_vector
57. make_string
58. make_unibyte_string
59. make_multibyte_string
60. make_string_from_bytes
61. make_specified_string
62. make_clear_string
63. make_uninit_string
64. make_clear_multibyte_string
65. make_uninit_multibyte_string
66. make_formatted_string
67. pin_string
68. make_float
69. free_cons
70. list1
71. list2
72. list3
73. list4
74. list5
75. cons_listn
76. listn
77. pure_listn
78. next_vector
79. set_next_vector
80. ADVANCE
81. VINDEX
82. large_vector_vec
83. setup_on_free_list
84. allocate_vector_block
85. init_vectors
86. allocate_vector_from_block
87. vectorlike_nbytes
88. cleanup_vector
89. sweep_vectors
90. allocate_vectorlike
91. allocate_clear_vector
92. allocate_vector
93. allocate_nil_vector
94. allocate_pseudovector
95. allocate_buffer
96. allocate_record
97. make_vector
98. set_symbol_name
99. init_symbol
100. DEFUN
101. make_misc_ptr
102. build_symbol_with_pos
103. build_overlay
104. DEFUN
105. build_marker
106. make_event_array
107. make_user_ptr
108. init_finalizer_list
109. finalizer_insert
110. unchain_finalizer
111. mark_finalizer_list
112. queue_doomed_finalizers
113. run_finalizer_handler
114. run_finalizer_function
115. run_finalizers
116. DEFUN
117. vector_marked_p
118. set_vector_marked
119. vectorlike_marked_p
120. set_vectorlike_marked
121. cons_marked_p
122. set_cons_marked
123. string_marked_p
124. set_string_marked
125. symbol_marked_p
126. set_symbol_marked
127. interval_marked_p
128. set_interval_marked
129. memory_full
130. refill_memory_reserve
131. mem_init
132. mem_find
133. mem_insert
134. mem_insert_fixup
135. mem_rotate_left
136. mem_rotate_right
137. mem_delete
138. mem_delete_fixup
139. live_string_holding
140. live_string_p
141. live_cons_holding
142. live_cons_p
143. live_symbol_holding
144. live_symbol_p
145. live_float_holding
146. live_float_p
147. live_vector_pointer
148. live_large_vector_holding
149. live_large_vector_p
150. live_small_vector_holding
151. live_small_vector_p
152. mark_maybe_pointer
153. mark_memory
154. test_setjmp
155. test_setjmp
156. mark_c_stack
157. flush_stack_call_func1
158. valid_pointer_p
159. valid_lisp_object_p
160. pure_alloc
161. check_pure_size
162. find_string_data_in_pure
163. make_pure_string
164. make_pure_c_string
165. pure_cons
166. make_pure_float
167. make_pure_bignum
168. make_pure_vector
169. purecopy_hash_table
170. DEFUN
171. purecopy
172. staticpro
173. allow_garbage_collection
174. inhibit_garbage_collection
175. object_bytes
176. total_bytes_of_live_objects
177. compact_font_cache_entry
178. compact_font_caches
179. compact_undo_list
180. mark_pinned_objects
181. android_make_lisp_symbol
182. mark_pinned_symbols
183. visit_vectorlike_root
184. visit_buffer_root
185. visit_static_gc_roots
186. mark_object_root_visitor
187. mark_and_sweep_weak_table_contents
188. consing_threshold
189. bump_consing_until_gc
190. watch_gc_cons_threshold
191. watch_gc_cons_percentage
192. maybe_garbage_collect
193. garbage_collect
194. DEFUN
195. DEFUN
196. mark_glyph_matrix
197. mark_vectorlike
198. mark_char_table
199. mark_overlay
200. mark_overlays
201. mark_buffer
202. mark_face_cache
203. mark_localized_symbol
204. mark_discard_killed_buffers
205. mark_frame
206. mark_window
207. mark_stack_empty_p
208. mark_stack_pop
209. grow_mark_stack
210. mark_stack_push_value
211. mark_stack_push_values
212. process_mark_stack
213. mark_object
214. mark_objects
215. mark_terminals
216. survives_gc_p
217. sweep_conses
218. sweep_floats
219. sweep_intervals
220. sweep_symbols
221. unchain_dead_markers
222. sweep_buffers
223. gc_sweep
224. DEFUN
225. DEFUN
226. DEFUN
227. DEFUN
228. symbol_uses_obj
229. which_symbols
230. find_suspicious_object_in_range
231. note_suspicious_free
232. detect_suspicious_free
233. DEFUN
234. die
235. verify_alloca
236. init_alloc_once
237. init_alloc_once_for_pdumper
238. init_alloc
239. syms_of_alloc

     1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
     2 
     3 Copyright (C) 1985-2023 Free Software Foundation, Inc.
     4 
     5 This file is part of GNU Emacs.
     6 
     7 GNU Emacs is free software: you can redistribute it and/or modify
     8 it under the terms of the GNU General Public License as published by
     9 the Free Software Foundation, either version 3 of the License, or (at
    10 your option) any later version.
    11 
    12 GNU Emacs is distributed in the hope that it will be useful,
    13 but WITHOUT ANY WARRANTY; without even the implied warranty of
    14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    15 GNU General Public License for more details.
    16 
    17 You should have received a copy of the GNU General Public License
    18 along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
    19 
    20 #include <config.h>
    21 
    22 #include <errno.h>
    23 #include <stdint.h>
    24 #include <stdlib.h>
    25 #include <limits.h>             /* For CHAR_BIT.  */
    26 #include <signal.h>             /* For SIGABRT, SIGDANGER.  */
    27 
    28 #ifdef HAVE_PTHREAD
    29 #include <pthread.h>
    30 #endif
    31 
    32 #include "lisp.h"
    33 #include "bignum.h"
    34 #include "dispextern.h"
    35 #include "intervals.h"
    36 #include "puresize.h"
    37 #include "sheap.h"
    38 #include "sysstdio.h"
    39 #include "systime.h"
    40 #include "character.h"
    41 #include "buffer.h"
    42 #include "window.h"
    43 #include "keyboard.h"
    44 #include "frame.h"
    45 #include "blockinput.h"
    46 #include "pdumper.h"
    47 #include "termhooks.h"          /* For struct terminal.  */
    48 #include "itree.h"
    49 #ifdef HAVE_WINDOW_SYSTEM
    50 #include TERM_HEADER
    51 #endif /* HAVE_WINDOW_SYSTEM */
    52 
    53 #if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
    54 #include "sfntfont.h"
    55 #endif
    56 
    57 #ifdef HAVE_TREE_SITTER
    58 #include "treesit.h"
    59 #endif
    60 
    61 #include <flexmember.h>
    62 #include <verify.h>
    63 #include <execinfo.h>           /* For backtrace.  */
    64 
    65 #ifdef HAVE_LINUX_SYSINFO
    66 #include <sys/sysinfo.h>
    67 #endif
    68 
    69 #ifdef MSDOS
    70 #include "dosfns.h"             /* For dos_memory_info.  */
    71 #endif
    72 
    73 #ifdef HAVE_MALLOC_H
    74 # include <malloc.h>
    75 #endif
    76 
    77 #if (defined ENABLE_CHECKING \
    78      && defined HAVE_VALGRIND_VALGRIND_H && !defined USE_VALGRIND)
    79 # define USE_VALGRIND 1
    80 #endif
    81 
    82 #if USE_VALGRIND
    83 #include <valgrind/valgrind.h>
    84 #include <valgrind/memcheck.h>
    85 #endif
    86 
    87 /* AddressSanitizer exposes additional functions for manually marking
    88    memory as poisoned/unpoisoned.  When ASan is enabled and the needed
    89    header is available, memory is poisoned when:
    90 
    91    * An ablock is freed (lisp_align_free), or ablocks are initially
    92    allocated (lisp_align_malloc).
    93    * An interval_block is initially allocated (make_interval).
    94    * A dead INTERVAL is put on the interval free list
    95    (sweep_intervals).
    96    * A sdata is marked as dead (sweep_strings, pin_string).
    97    * An sblock is initially allocated (allocate_string_data).
    98    * A string_block is initially allocated (allocate_string).
    99    * A dead string is put on string_free_list (sweep_strings).
   100    * A float_block is initially allocated (make_float).
   101    * A dead float is put on float_free_list.
   102    * A cons_block is initially allocated (Fcons).
   103    * A dead cons is put on cons_free_list (sweep_cons).
   104    * A dead vector is put on vector_free_list (setup_on_free_list),
   105    or a new vector block is allocated (allocate_vector_from_block).
   106    Accordingly, objects reused from the free list are unpoisoned.
   107 
   108    This feature can be disabled wtih the run-time flag
   109    `allow_user_poisoning' set to zero.  */
   110 #if ADDRESS_SANITIZER && defined HAVE_SANITIZER_ASAN_INTERFACE_H \
   111   && !defined GC_ASAN_POISON_OBJECTS
   112 # define GC_ASAN_POISON_OBJECTS 1
   113 # include <sanitizer/asan_interface.h>
   114 #else
   115 # define GC_ASAN_POISON_OBJECTS 0
   116 #endif
   117 
   118 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
   119    We turn that on by default when ENABLE_CHECKING is defined;
   120    define GC_CHECK_MARKED_OBJECTS to zero to disable.  */
   121 
   122 #if defined ENABLE_CHECKING && !defined GC_CHECK_MARKED_OBJECTS
   123 # define GC_CHECK_MARKED_OBJECTS 1
   124 #endif
   125 
   126 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
   127    memory.  Can do this only if using gmalloc.c and if not checking
   128    marked objects.  */
   129 
   130 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
   131      || defined HYBRID_MALLOC || GC_CHECK_MARKED_OBJECTS)
   132 #undef GC_MALLOC_CHECK
   133 #endif
   134 
   135 #include <unistd.h>
   136 #include <fcntl.h>
   137 
   138 #ifdef USE_GTK
   139 # include "gtkutil.h"
   140 #endif
   141 #ifdef WINDOWSNT
   142 #include "w32.h"
   143 #include "w32heap.h"    /* for sbrk */
   144 #endif
   145 
   146 /* A type with alignment at least as large as any object that Emacs
   147    allocates.  This is not max_align_t because some platforms (e.g.,
   148    mingw) have buggy malloc implementations that do not align for
   149    max_align_t.  This union contains types of all GCALIGNED_STRUCT
   150    components visible here.  */
   151 union emacs_align_type
   152 {
   153   struct frame frame;
   154   struct Lisp_Bignum Lisp_Bignum;
   155   struct Lisp_Bool_Vector Lisp_Bool_Vector;
   156   struct Lisp_Char_Table Lisp_Char_Table;
   157   struct Lisp_CondVar Lisp_CondVar;
   158   struct Lisp_Finalizer Lisp_Finalizer;
   159   struct Lisp_Float Lisp_Float;
   160   struct Lisp_Hash_Table Lisp_Hash_Table;
   161   struct Lisp_Marker Lisp_Marker;
   162   struct Lisp_Misc_Ptr Lisp_Misc_Ptr;
   163   struct Lisp_Mutex Lisp_Mutex;
   164   struct Lisp_Overlay Lisp_Overlay;
   165   struct Lisp_Sub_Char_Table Lisp_Sub_Char_Table;
   166   struct Lisp_Subr Lisp_Subr;
   167   struct Lisp_Sqlite Lisp_Sqlite;
   168   struct Lisp_User_Ptr Lisp_User_Ptr;
   169   struct Lisp_Vector Lisp_Vector;
   170   struct terminal terminal;
   171   struct thread_state thread_state;
   172   struct window window;
   173 
   174   /* Omit the following since they would require including process.h
   175      etc.  In practice their alignments never exceed that of the
   176      structs already listed.  */
   177 #if 0
   178   struct Lisp_Module_Function Lisp_Module_Function;
   179   struct Lisp_Process Lisp_Process;
   180   struct save_window_data save_window_data;
   181   struct scroll_bar scroll_bar;
   182   struct xwidget_view xwidget_view;
   183   struct xwidget xwidget;
   184 #endif
   185 };
   186 
   187 /* MALLOC_SIZE_NEAR (N) is a good number to pass to malloc when
   188    allocating a block of memory with size close to N bytes.
   189    For best results N should be a power of 2.
   190 
   191    When calculating how much memory to allocate, GNU malloc (SIZE)
   192    adds sizeof (size_t) to SIZE for internal overhead, and then rounds
   193    up to a multiple of MALLOC_ALIGNMENT.  Emacs can improve
   194    performance a bit on GNU platforms by arranging for the resulting
   195    size to be a power of two.  This heuristic is good for glibc 2.26
   196    (2017) and later, and does not affect correctness on other
   197    platforms.  */
   198 
   199 #define MALLOC_SIZE_NEAR(n) \
   200   (ROUNDUP (max (n, sizeof (size_t)), MALLOC_ALIGNMENT) - sizeof (size_t))
   201 #ifdef __i386
   202 enum { MALLOC_ALIGNMENT = 16 };
   203 #else
   204 enum { MALLOC_ALIGNMENT = max (2 * sizeof (size_t), alignof (long double)) };
   205 #endif
   206 
   207 #ifdef DOUG_LEA_MALLOC
   208 
   209 /* Specify maximum number of areas to mmap.  It would be nice to use a
   210    value that explicitly means "no limit".  */
   211 
   212 # define MMAP_MAX_AREAS 100000000
   213 
   214 /* A pointer to the memory allocated that copies that static data
   215    inside glibc's malloc.  */
   216 static void *malloc_state_ptr;
   217 
   218 /* Restore the dumped malloc state.  Because malloc can be invoked
   219    even before main (e.g. by the dynamic linker), the dumped malloc
   220    state must be restored as early as possible using this special hook.  */
   221 static void
   222 malloc_initialize_hook (void)
   223 {
   224   static bool malloc_using_checking;
   225 
   226   if (! initialized)
   227     {
   228 # ifdef GNU_LINUX
   229       my_heap_start ();
   230 # endif
   231       malloc_using_checking = getenv ("MALLOC_CHECK_") != NULL;
   232     }
   233   else
   234     {
   235       if (!malloc_using_checking)
   236         {
   237           /* Work around a bug in glibc's malloc.  MALLOC_CHECK_ must be
   238              ignored if the heap to be restored was constructed without
   239              malloc checking.  Can't use unsetenv, since that calls malloc.  */
   240           char **p = environ;
   241           if (p)
   242             for (; *p; p++)
   243               if (strncmp (*p, "MALLOC_CHECK_=", 14) == 0)
   244                 {
   245                   do
   246                     *p = p[1];
   247                   while (*++p);
   248 
   249                   break;
   250                 }
   251         }
   252 
   253       if (malloc_set_state (malloc_state_ptr) != 0)
   254         emacs_abort ();
   255       alloc_unexec_post ();
   256     }
   257 }
   258 
   259 /* Declare the malloc initialization hook, which runs before 'main' starts.
   260    EXTERNALLY_VISIBLE works around Bug#22522.  */
   261 typedef void (*voidfuncptr) (void);
   262 # ifndef __MALLOC_HOOK_VOLATILE
   263 #  define __MALLOC_HOOK_VOLATILE
   264 # endif
   265 voidfuncptr __MALLOC_HOOK_VOLATILE __malloc_initialize_hook EXTERNALLY_VISIBLE
   266   = malloc_initialize_hook;
   267 
   268 #endif
   269 
   270 #if defined DOUG_LEA_MALLOC || defined HAVE_UNEXEC
   271 
   272 /* Allocator-related actions to do just before and after unexec.  */
   273 
   274 void
   275 alloc_unexec_pre (void)
   276 {
   277 # ifdef DOUG_LEA_MALLOC
   278   malloc_state_ptr = malloc_get_state ();
   279   if (!malloc_state_ptr)
   280     fatal ("malloc_get_state: %s", strerror (errno));
   281 # endif
   282 }
   283 
   284 void
   285 alloc_unexec_post (void)
   286 {
   287 # ifdef DOUG_LEA_MALLOC
   288   free (malloc_state_ptr);
   289 # endif
   290 }
   291 
   292 # ifdef GNU_LINUX
   293 
   294 /* The address where the heap starts.  */
   295 void *
   296 my_heap_start (void)
   297 {
   298   static void *start;
   299   if (! start)
   300     start = sbrk (0);
   301   return start;
   302 }
   303 # endif
   304 
   305 #endif
   306 
   307 /* Mark, unmark, query mark bit of a Lisp string.  S must be a pointer
   308    to a struct Lisp_String.  */
   309 
   310 #define XMARK_STRING(S)         ((S)->u.s.size |= ARRAY_MARK_FLAG)
   311 #define XUNMARK_STRING(S)       ((S)->u.s.size &= ~ARRAY_MARK_FLAG)
   312 #define XSTRING_MARKED_P(S)     (((S)->u.s.size & ARRAY_MARK_FLAG) != 0)
   313 
   314 #define XMARK_VECTOR(V)         ((V)->header.size |= ARRAY_MARK_FLAG)
   315 #define XUNMARK_VECTOR(V)       ((V)->header.size &= ~ARRAY_MARK_FLAG)
   316 #define XVECTOR_MARKED_P(V)     (((V)->header.size & ARRAY_MARK_FLAG) != 0)
   317 
   318 /* Default value of gc_cons_threshold (see below).  */
   319 
   320 #define GC_DEFAULT_THRESHOLD (100000 * word_size)
   321 
   322 /* Global variables.  */
   323 struct emacs_globals globals;
   324 
   325 /* maybe_gc collects garbage if this goes negative.  */
   326 
   327 EMACS_INT consing_until_gc;
   328 
   329 #ifdef HAVE_PDUMPER
   330 /* Number of finalizers run: used to loop over GC until we stop
   331    generating garbage.  */
   332 int number_finalizers_run;
   333 #endif
   334 
   335 /* True during GC.  */
   336 
   337 bool gc_in_progress;
   338 
   339 /* System byte and object counts reported by GC.  */
   340 
   341 /* Assume byte counts fit in uintptr_t and object counts fit into
   342    intptr_t.  */
   343 typedef uintptr_t byte_ct;
   344 typedef intptr_t object_ct;
   345 
   346 /* Large-magnitude value for a threshold count, which fits in EMACS_INT.
   347    Using only half the EMACS_INT range avoids overflow hassles.
   348    There is no need to fit these counts into fixnums.  */
   349 #define HI_THRESHOLD (EMACS_INT_MAX / 2)
   350 
   351 /* Number of live and free conses etc. counted by the most-recent GC.  */
   352 
   353 static struct gcstat
   354 {
   355   object_ct total_conses, total_free_conses;
   356   object_ct total_symbols, total_free_symbols;
   357   object_ct total_strings, total_free_strings;
   358   byte_ct total_string_bytes;
   359   object_ct total_vectors, total_vector_slots, total_free_vector_slots;
   360   object_ct total_floats, total_free_floats;
   361   object_ct total_intervals, total_free_intervals;
   362   object_ct total_buffers;
   363 } gcstat;
   364 
   365 /* Points to memory space allocated as "spare", to be freed if we run
   366    out of memory.  We keep one large block, four cons-blocks, and
   367    two string blocks.  */
   368 
   369 static char *spare_memory[7];
   370 
   371 /* Amount of spare memory to keep in large reserve block, or to see
   372    whether this much is available when malloc fails on a larger request.  */
   373 
   374 #define SPARE_MEMORY (1 << 14)
   375 
   376 /* Initialize it to a nonzero value to force it into data space
   377    (rather than bss space).  That way unexec will remap it into text
   378    space (pure), on some systems.  We have not implemented the
   379    remapping on more recent systems because this is less important
   380    nowadays than in the days of small memories and timesharing.  */
   381 
   382 EMACS_INT pure[(PURESIZE + sizeof (EMACS_INT) - 1) / sizeof (EMACS_INT)] = {1,};
   383 #define PUREBEG (char *) pure
   384 
   385 /* Pointer to the pure area, and its size.  */
   386 
   387 static char *purebeg;
   388 static ptrdiff_t pure_size;
   389 
   390 /* Number of bytes of pure storage used before pure storage overflowed.
   391    If this is non-zero, this implies that an overflow occurred.  */
   392 
   393 static ptrdiff_t pure_bytes_used_before_overflow;
   394 
   395 /* Index in pure at which next pure Lisp object will be allocated..  */
   396 
   397 static ptrdiff_t pure_bytes_used_lisp;
   398 
   399 /* Number of bytes allocated for non-Lisp objects in pure storage.  */
   400 
   401 static ptrdiff_t pure_bytes_used_non_lisp;
   402 
   403 /* If positive, garbage collection is inhibited.  Otherwise, zero.  */
   404 
   405 intptr_t garbage_collection_inhibited;
   406 
   407 /* The GC threshold in bytes, the last time it was calculated
   408    from gc-cons-threshold and gc-cons-percentage.  */
   409 static EMACS_INT gc_threshold;
   410 
   411 /* If nonzero, this is a warning delivered by malloc and not yet
   412    displayed.  */
   413 
   414 const char *pending_malloc_warning;
   415 
   416 /* Pointer sanity only on request.  FIXME: Code depending on
   417    SUSPICIOUS_OBJECT_CHECKING is obsolete; remove it entirely.  */
   418 #ifdef ENABLE_CHECKING
   419 #define SUSPICIOUS_OBJECT_CHECKING 1
   420 #endif
   421 
   422 #ifdef SUSPICIOUS_OBJECT_CHECKING
   423 struct suspicious_free_record
   424 {
   425   void *suspicious_object;
   426   void *backtrace[128];
   427 };
   428 static void *suspicious_objects[32];
   429 static int suspicious_object_index;
   430 struct suspicious_free_record suspicious_free_history[64] EXTERNALLY_VISIBLE;
   431 static int suspicious_free_history_index;
   432 /* Find the first currently-monitored suspicious pointer in range
   433    [begin,end) or NULL if no such pointer exists.  */
   434 static void *find_suspicious_object_in_range (void *begin, void *end);
   435 static void detect_suspicious_free (void *ptr);
   436 #else
   437 # define find_suspicious_object_in_range(begin, end) ((void *) NULL)
   438 # define detect_suspicious_free(ptr) ((void) 0)
   439 #endif
   440 
   441 /* Maximum amount of C stack to save when a GC happens.  */
   442 
   443 #ifndef MAX_SAVE_STACK
   444 #define MAX_SAVE_STACK 16000
   445 #endif
   446 
   447 /* Buffer in which we save a copy of the C stack at each GC.  */
   448 
   449 #if MAX_SAVE_STACK > 0
   450 static char *stack_copy;
   451 static ptrdiff_t stack_copy_size;
   452 
   453 /* Copy to DEST a block of memory from SRC of size SIZE bytes,
   454    avoiding any address sanitization.  */
   455 
   456 static void * ATTRIBUTE_NO_SANITIZE_ADDRESS
   457 no_sanitize_memcpy (void *dest, void const *src, size_t size)
   458 {
   459   if (! ADDRESS_SANITIZER)
   460     return memcpy (dest, src, size);
   461   else
   462     {
   463       size_t i;
   464       char *d = dest;
   465       char const *s = src;
   466       for (i = 0; i < size; i++)
   467         d[i] = s[i];
   468       return dest;
   469     }
   470 }
   471 
   472 #endif /* MAX_SAVE_STACK > 0 */
   473 
   474 static void unchain_finalizer (struct Lisp_Finalizer *);
   475 static void mark_terminals (void);
   476 static void gc_sweep (void);
   477 static Lisp_Object make_pure_vector (ptrdiff_t);
   478 static void mark_buffer (struct buffer *);
   479 
   480 #if !defined REL_ALLOC || defined SYSTEM_MALLOC || defined HYBRID_MALLOC
   481 static void refill_memory_reserve (void);
   482 #endif
   483 static void compact_small_strings (void);
   484 static void free_large_strings (void);
   485 extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
   486 
   487 static bool vector_marked_p (struct Lisp_Vector const *);
   488 static bool vectorlike_marked_p (union vectorlike_header const *);
   489 static void set_vectorlike_marked (union vectorlike_header *);
   490 static bool interval_marked_p (INTERVAL);
   491 static void set_interval_marked (INTERVAL);
   492 
   493 /* When scanning the C stack for live Lisp objects, Emacs keeps track of
   494    what memory allocated via lisp_malloc and lisp_align_malloc is intended
   495    for what purpose.  This enumeration specifies the type of memory.  */
   496 
   497 enum mem_type
   498 {
   499   MEM_TYPE_NON_LISP,
   500   MEM_TYPE_CONS,
   501   MEM_TYPE_STRING,
   502   MEM_TYPE_SYMBOL,
   503   MEM_TYPE_FLOAT,
   504   /* Since all non-bool pseudovectors are small enough to be
   505      allocated from vector blocks, this memory type denotes
   506      large regular vectors and large bool pseudovectors.  */
   507   MEM_TYPE_VECTORLIKE,
   508   /* Special type to denote vector blocks.  */
   509   MEM_TYPE_VECTOR_BLOCK,
   510   /* Special type to denote reserved memory.  */
   511   MEM_TYPE_SPARE
   512 };
   513 
   514 static bool
   515 deadp (Lisp_Object x)
   516 {
   517   return BASE_EQ (x, dead_object ());
   518 }
   519 
   520 #ifdef GC_MALLOC_CHECK
   521 
   522 enum mem_type allocated_mem_type;
   523 
   524 #endif /* GC_MALLOC_CHECK */
   525 
   526 /* A node in the red-black tree describing allocated memory containing
   527    Lisp data.  Each such block is recorded with its start and end
   528    address when it is allocated, and removed from the tree when it
   529    is freed.
   530 
   531    A red-black tree is a balanced binary tree with the following
   532    properties:
   533 
   534    1. Every node is either red or black.
   535    2. Every leaf is black.
   536    3. If a node is red, then both of its children are black.
   537    4. Every simple path from a node to a descendant leaf contains
   538    the same number of black nodes.
   539    5. The root is always black.
   540 
   541    When nodes are inserted into the tree, or deleted from the tree,
   542    the tree is "fixed" so that these properties are always true.
   543 
   544    A red-black tree with N internal nodes has height at most 2
   545    log(N+1).  Searches, insertions and deletions are done in O(log N).
   546    Please see a text book about data structures for a detailed
   547    description of red-black trees.  Any book worth its salt should
   548    describe them.  */
   549 
   550 struct mem_node
   551 {
   552   /* Children of this node.  These pointers are never NULL.  When there
   553      is no child, the value is MEM_NIL, which points to a dummy node.  */
   554   struct mem_node *left, *right;
   555 
   556   /* The parent of this node.  In the root node, this is NULL.  */
   557   struct mem_node *parent;
   558 
   559   /* Start and end of allocated region.  */
   560   void *start, *end;
   561 
   562   /* Node color.  */
   563   enum {MEM_BLACK, MEM_RED} color;
   564 
   565   /* Memory type.  */
   566   enum mem_type type;
   567 };
   568 
   569 /* Root of the tree describing allocated Lisp memory.  */
   570 
   571 static struct mem_node *mem_root;
   572 
   573 /* Lowest and highest known address in the heap.  */
   574 
   575 static void *min_heap_address, *max_heap_address;
   576 
   577 /* Sentinel node of the tree.  */
   578 
   579 static struct mem_node mem_z;
   580 #define MEM_NIL &mem_z
   581 
   582 static struct mem_node *mem_insert (void *, void *, enum mem_type);
   583 static void mem_insert_fixup (struct mem_node *);
   584 static void mem_rotate_left (struct mem_node *);
   585 static void mem_rotate_right (struct mem_node *);
   586 static void mem_delete (struct mem_node *);
   587 static void mem_delete_fixup (struct mem_node *);
   588 static struct mem_node *mem_find (void *);
   589 
   590 /* Addresses of staticpro'd variables.  Initialize it to a nonzero
   591    value if we might unexec; otherwise some compilers put it into
   592    BSS.  */
   593 
   594 Lisp_Object const *staticvec[NSTATICS]
   595 #ifdef HAVE_UNEXEC
   596 = {&Vpurify_flag}
   597 #endif
   598   ;
   599 
   600 /* Index of next unused slot in staticvec.  */
   601 
   602 int staticidx;
   603 
   604 static void *pure_alloc (size_t, int);
   605 
   606 /* Return PTR rounded up to the next multiple of ALIGNMENT.  */
   607 
   608 static void *
   609 pointer_align (void *ptr, int alignment)
   610 {
   611   return (void *) ROUNDUP ((uintptr_t) ptr, alignment);
   612 }
   613 
   614 /* Extract the pointer hidden within O.  */
   615 
   616 static ATTRIBUTE_NO_SANITIZE_UNDEFINED void *
   617 XPNTR (Lisp_Object a)
   618 {
   619   return (BARE_SYMBOL_P (a)
   620           ? (char *) lispsym + (XLI (a) - LISP_WORD_TAG (Lisp_Symbol))
   621           : (char *) XLP (a) - (XLI (a) & ~VALMASK));
   622 }
   623 
   624 static void
   625 XFLOAT_INIT (Lisp_Object f, double n)
   626 {
   627   XFLOAT (f)->u.data = n;
   628 }
   629 
   630 /* Account for allocation of NBYTES in the heap.  This is a separate
   631    function to avoid hassles with implementation-defined conversion
   632    from unsigned to signed types.  */
   633 static void
   634 tally_consing (ptrdiff_t nbytes)
   635 {
   636   consing_until_gc -= nbytes;
   637 }
   638 
   639 #ifdef DOUG_LEA_MALLOC
   640 static bool
   641 pointers_fit_in_lispobj_p (void)
   642 {
   643   return (UINTPTR_MAX <= VAL_MAX) || USE_LSB_TAG;
   644 }
   645 
   646 static bool
   647 mmap_lisp_allowed_p (void)
   648 {
   649   /* If we can't store all memory addresses in our lisp objects, it's
   650      risky to let the heap use mmap and give us addresses from all
   651      over our address space.  We also can't use mmap for lisp objects
   652      if we might dump: unexec doesn't preserve the contents of mmapped
   653      regions.  */
   654   return pointers_fit_in_lispobj_p () && !will_dump_with_unexec_p ();
   655 }
   656 #endif
   657 
   658 /* Head of a circularly-linked list of extant finalizers. */
   659 struct Lisp_Finalizer finalizers;
   660 
   661 /* Head of a circularly-linked list of finalizers that must be invoked
   662    because we deemed them unreachable.  This list must be global, and
   663    not a local inside garbage_collect, in case we GC again while
   664    running finalizers.  */
   665 struct Lisp_Finalizer doomed_finalizers;
   666 
   667 
   668 /************************************************************************
   669                                 Malloc
   670  ************************************************************************/
   671 
   672 #if defined SIGDANGER || (!defined SYSTEM_MALLOC && !defined HYBRID_MALLOC)
   673 
   674 /* Function malloc calls this if it finds we are near exhausting storage.  */
   675 
   676 void
   677 malloc_warning (const char *str)
   678 {
   679   pending_malloc_warning = str;
   680 }
   681 
   682 #endif
   683 
   684 /* Display an already-pending malloc warning.  */
   685 
   686 void
   687 display_malloc_warning (void)
   688 {
   689   call3 (intern ("display-warning"),
   690          intern ("alloc"),
   691          build_string (pending_malloc_warning),
   692          intern (":emergency"));
   693   pending_malloc_warning = 0;
   694 }
   695 
   696 /* Called if we can't allocate relocatable space for a buffer.  */
   697 
   698 void
   699 buffer_memory_full (ptrdiff_t nbytes)
   700 {
   701   /* If buffers use the relocating allocator, no need to free
   702      spare_memory, because we may have plenty of malloc space left
   703      that we could get, and if we don't, the malloc that fails will
   704      itself cause spare_memory to be freed.  If buffers don't use the
   705      relocating allocator, treat this like any other failing
   706      malloc.  */
   707 
   708 #ifndef REL_ALLOC
   709   memory_full (nbytes);
   710 #else
   711   /* This used to call error, but if we've run out of memory, we could
   712      get infinite recursion trying to build the string.  */
   713   xsignal (Qnil, Vmemory_signal_data);
   714 #endif
   715 }
   716 
   717 /* A common multiple of the positive integers A and B.  Ideally this
   718    would be the least common multiple, but there's no way to do that
   719    as a constant expression in C, so do the best that we can easily do.  */
   720 #define COMMON_MULTIPLE(a, b) \
   721   ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
   722 
   723 /* Alignment needed for memory blocks that are allocated via malloc
   724    and that contain Lisp objects.  On typical hosts malloc already
   725    aligns sufficiently, but extra work is needed on oddball hosts
   726    where Emacs would crash if malloc returned a non-GCALIGNED pointer.  */
   727 enum { LISP_ALIGNMENT = alignof (union { union emacs_align_type x;
   728                                          GCALIGNED_UNION_MEMBER }) };
   729 verify (LISP_ALIGNMENT % GCALIGNMENT == 0);
   730 
   731 /* True if malloc (N) is known to return storage suitably aligned for
   732    Lisp objects whenever N is a multiple of LISP_ALIGNMENT.  In
   733    practice this is true whenever alignof (max_align_t) is also a
   734    multiple of LISP_ALIGNMENT.  This works even for buggy platforms
   735    like MinGW circa 2020, where alignof (max_align_t) is 16 even though
   736    the malloc alignment is only 8, and where Emacs still works because
   737    it never does anything that requires an alignment of 16.  */
   738 enum { MALLOC_IS_LISP_ALIGNED = alignof (max_align_t) % LISP_ALIGNMENT == 0 };
   739 
   740 /* If compiled with XMALLOC_BLOCK_INPUT_CHECK, define a symbol
   741    BLOCK_INPUT_IN_MEMORY_ALLOCATORS that is visible to the debugger.
   742    If that variable is set, block input while in one of Emacs's memory
   743    allocation functions.  There should be no need for this debugging
   744    option, since signal handlers do not allocate memory, but Emacs
   745    formerly allocated memory in signal handlers and this compile-time
   746    option remains as a way to help debug the issue should it rear its
   747    ugly head again.  */
   748 #ifdef XMALLOC_BLOCK_INPUT_CHECK
   749 bool block_input_in_memory_allocators EXTERNALLY_VISIBLE;
   750 static void
   751 malloc_block_input (void)
   752 {
   753   if (block_input_in_memory_allocators)
   754     block_input ();
   755 }
   756 static void
   757 malloc_unblock_input (void)
   758 {
   759   if (block_input_in_memory_allocators)
   760     {
   761       int err = errno;
   762       unblock_input ();
   763       errno = err;
   764     }
   765 }
   766 # define MALLOC_BLOCK_INPUT malloc_block_input ()
   767 # define MALLOC_UNBLOCK_INPUT malloc_unblock_input ()
   768 #else
   769 # define MALLOC_BLOCK_INPUT ((void) 0)
   770 # define MALLOC_UNBLOCK_INPUT ((void) 0)
   771 #endif
   772 
   773 #define MALLOC_PROBE(size)                      \
   774   do {                                          \
   775     if (profiler_memory_running)                \
   776       malloc_probe (size);                      \
   777   } while (0)
   778 
   779 static void *lmalloc (size_t, bool) ATTRIBUTE_MALLOC_SIZE ((1));
   780 static void *lrealloc (void *, size_t);
   781 
   782 /* Like malloc but check for no memory and block interrupt input.  */
   783 
   784 void *
   785 xmalloc (size_t size)
   786 {
   787   void *val;
   788 
   789   MALLOC_BLOCK_INPUT;
   790   val = lmalloc (size, false);
   791   MALLOC_UNBLOCK_INPUT;
   792 
   793   if (!val)
   794     memory_full (size);
   795   MALLOC_PROBE (size);
   796   return val;
   797 }
   798 
   799 /* Like the above, but zeroes out the memory just allocated.  */
   800 
   801 void *
   802 xzalloc (size_t size)
   803 {
   804   void *val;
   805 
   806   MALLOC_BLOCK_INPUT;
   807   val = lmalloc (size, true);
   808   MALLOC_UNBLOCK_INPUT;
   809 
   810   if (!val)
   811     memory_full (size);
   812   MALLOC_PROBE (size);
   813   return val;
   814 }
   815 
   816 /* Like realloc but check for no memory and block interrupt input.  */
   817 
   818 void *
   819 xrealloc (void *block, size_t size)
   820 {
   821   void *val;
   822 
   823   MALLOC_BLOCK_INPUT;
   824   /* Call lmalloc when BLOCK is null, for the benefit of long-obsolete
   825      platforms lacking support for realloc (NULL, size).  */
   826   if (! block)
   827     val = lmalloc (size, false);
   828   else
   829     val = lrealloc (block, size);
   830   MALLOC_UNBLOCK_INPUT;
   831 
   832   if (!val)
   833     memory_full (size);
   834   MALLOC_PROBE (size);
   835   return val;
   836 }
   837 
   838 
   839 /* Like free but block interrupt input.  */
   840 
   841 void
   842 xfree (void *block)
   843 {
   844   if (!block)
   845     return;
   846   if (pdumper_object_p (block))
   847     return;
   848   MALLOC_BLOCK_INPUT;
   849   free (block);
   850   MALLOC_UNBLOCK_INPUT;
   851   /* We don't call refill_memory_reserve here
   852      because in practice the call in r_alloc_free seems to suffice.  */
   853 }
   854 
   855 
   856 /* Other parts of Emacs pass large int values to allocator functions
   857    expecting ptrdiff_t.  This is portable in practice, but check it to
   858    be safe.  */
   859 verify (INT_MAX <= PTRDIFF_MAX);
   860 
   861 
   862 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
   863    Signal an error on memory exhaustion, and block interrupt input.  */
   864 
   865 void *
   866 xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size)
   867 {
   868   eassert (0 <= nitems && 0 < item_size);
   869   ptrdiff_t nbytes;
   870   if (ckd_mul (&nbytes, nitems, item_size) || SIZE_MAX < nbytes)
   871     memory_full (SIZE_MAX);
   872   return xmalloc (nbytes);
   873 }
   874 
   875 
   876 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
   877    Signal an error on memory exhaustion, and block interrupt input.  */
   878 
   879 void *
   880 xnrealloc (void *pa, ptrdiff_t nitems, ptrdiff_t item_size)
   881 {
   882   eassert (0 <= nitems && 0 < item_size);
   883   ptrdiff_t nbytes;
   884   if (ckd_mul (&nbytes, nitems, item_size) || SIZE_MAX < nbytes)
   885     memory_full (SIZE_MAX);
   886   return xrealloc (pa, nbytes);
   887 }
   888 
   889 
   890 /* Grow PA, which points to an array of *NITEMS items, and return the
   891    location of the reallocated array, updating *NITEMS to reflect its
   892    new size.  The new array will contain at least NITEMS_INCR_MIN more
   893    items, but will not contain more than NITEMS_MAX items total.
   894    ITEM_SIZE is the size of each item, in bytes.
   895 
   896    ITEM_SIZE and NITEMS_INCR_MIN must be positive.  *NITEMS must be
   897    nonnegative.  If NITEMS_MAX is -1, it is treated as if it were
   898    infinity.
   899 
   900    If PA is null, then allocate a new array instead of reallocating
   901    the old one.
   902 
   903    Block interrupt input as needed.  If memory exhaustion occurs, set
   904    *NITEMS to zero if PA is null, and signal an error (i.e., do not
   905    return).
   906 
   907    Thus, to grow an array A without saving its old contents, do
   908    { xfree (A); A = NULL; A = xpalloc (NULL, &AITEMS, ...); }.
   909    The A = NULL avoids a dangling pointer if xpalloc exhausts memory
   910    and signals an error, and later this code is reexecuted and
   911    attempts to free A.  */
   912 
   913 void *
   914 xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
   915          ptrdiff_t nitems_max, ptrdiff_t item_size)
   916 {
   917   ptrdiff_t n0 = *nitems;
   918   eassume (0 < item_size && 0 < nitems_incr_min && 0 <= n0 && -1 <= nitems_max);
   919 
   920   /* The approximate size to use for initial small allocation
   921      requests.  This is the largest "small" request for the GNU C
   922      library malloc.  */
   923   enum { DEFAULT_MXFAST = 64 * sizeof (size_t) / 4 };
   924 
   925   /* If the array is tiny, grow it to about (but no greater than)
   926      DEFAULT_MXFAST bytes.  Otherwise, grow it by about 50%.
   927      Adjust the growth according to three constraints: NITEMS_INCR_MIN,
   928      NITEMS_MAX, and what the C language can represent safely.  */
   929 
   930   ptrdiff_t n, nbytes;
   931   if (ckd_add (&n, n0, n0 >> 1))
   932     n = PTRDIFF_MAX;
   933   if (0 <= nitems_max && nitems_max < n)
   934     n = nitems_max;
   935 
   936   ptrdiff_t adjusted_nbytes
   937     = ((ckd_mul (&nbytes, n, item_size) || SIZE_MAX < nbytes)
   938        ? min (PTRDIFF_MAX, SIZE_MAX)
   939        : nbytes < DEFAULT_MXFAST ? DEFAULT_MXFAST : 0);
   940   if (adjusted_nbytes)
   941     {
   942       n = adjusted_nbytes / item_size;
   943       nbytes = adjusted_nbytes - adjusted_nbytes % item_size;
   944     }
   945 
   946   if (! pa)
   947     *nitems = 0;
   948   if (n - n0 < nitems_incr_min
   949       && (ckd_add (&n, n0, nitems_incr_min)
   950           || (0 <= nitems_max && nitems_max < n)
   951           || ckd_mul (&nbytes, n, item_size)))
   952     memory_full (SIZE_MAX);
   953   pa = xrealloc (pa, nbytes);
   954   *nitems = n;
   955   return pa;
   956 }
   957 
   958 
   959 /* Like strdup, but uses xmalloc.  */
   960 
   961 char *
   962 xstrdup (const char *s)
   963 {
   964   ptrdiff_t size;
   965   eassert (s);
   966   size = strlen (s) + 1;
   967   return memcpy (xmalloc (size), s, size);
   968 }
   969 
   970 /* Like above, but duplicates Lisp string to C string.  */
   971 
   972 char *
   973 xlispstrdup (Lisp_Object string)
   974 {
   975   ptrdiff_t size = SBYTES (string) + 1;
   976   return memcpy (xmalloc (size), SSDATA (string), size);
   977 }
   978 
   979 /* Assign to *PTR a copy of STRING, freeing any storage *PTR formerly
   980    pointed to.  If STRING is null, assign it without copying anything.
   981    Allocate before freeing, to avoid a dangling pointer if allocation
   982    fails.  */
   983 
   984 void
   985 dupstring (char **ptr, char const *string)
   986 {
   987   char *old = *ptr;
   988   *ptr = string ? xstrdup (string) : 0;
   989   xfree (old);
   990 }
   991 
   992 
   993 /* Like putenv, but (1) use the equivalent of xmalloc and (2) the
   994    argument is a const pointer.  */
   995 
   996 void
   997 xputenv (char const *string)
   998 {
   999   if (putenv ((char *) string) != 0)
  1000     memory_full (0);
  1001 }
  1002 
  1003 /* Return a newly allocated memory block of SIZE bytes, remembering
  1004    to free it when unwinding.  */
  1005 void *
  1006 record_xmalloc (size_t size)
  1007 {
  1008   void *p = xmalloc (size);
  1009   record_unwind_protect_ptr (xfree, p);
  1010   return p;
  1011 }
  1012 
  1013 
  1014 /* Like malloc but used for allocating Lisp data.  NBYTES is the
  1015    number of bytes to allocate, TYPE describes the intended use of the
  1016    allocated memory block (for strings, for conses, ...).  */
  1017 
  1018 #if ! USE_LSB_TAG
  1019 void *lisp_malloc_loser EXTERNALLY_VISIBLE;
  1020 #endif
  1021 
  1022 static void *
  1023 lisp_malloc (size_t nbytes, bool clearit, enum mem_type type)
  1024 {
  1025   register void *val;
  1026 
  1027   MALLOC_BLOCK_INPUT;
  1028 
  1029 #ifdef GC_MALLOC_CHECK
  1030   allocated_mem_type = type;
  1031 #endif
  1032 
  1033   val = lmalloc (nbytes, clearit);
  1034 
  1035 #if ! USE_LSB_TAG
  1036   /* If the memory just allocated cannot be addressed thru a Lisp
  1037      object's pointer, and it needs to be,
  1038      that's equivalent to running out of memory.  */
  1039   if (val && type != MEM_TYPE_NON_LISP)
  1040     {
  1041       Lisp_Object tem;
  1042       XSETCONS (tem, (char *) val + nbytes - 1);
  1043       if ((char *) XCONS (tem) != (char *) val + nbytes - 1)
  1044         {
  1045           lisp_malloc_loser = val;
  1046           free (val);
  1047           val = 0;
  1048         }
  1049     }
  1050 #endif
  1051 
  1052 #ifndef GC_MALLOC_CHECK
  1053   if (val && type != MEM_TYPE_NON_LISP)
  1054     mem_insert (val, (char *) val + nbytes, type);
  1055 #endif
  1056 
  1057   MALLOC_UNBLOCK_INPUT;
  1058   if (!val)
  1059     memory_full (nbytes);
  1060   MALLOC_PROBE (nbytes);
  1061   return val;
  1062 }
  1063 
  1064 /* Free BLOCK.  This must be called to free memory allocated with a
  1065    call to lisp_malloc.  */
  1066 
  1067 static void
  1068 lisp_free (void *block)
  1069 {
  1070   if (pdumper_object_p (block))
  1071     return;
  1072 
  1073   MALLOC_BLOCK_INPUT;
  1074 #ifndef GC_MALLOC_CHECK
  1075   struct mem_node *m = mem_find (block);
  1076 #endif
  1077   free (block);
  1078 #ifndef GC_MALLOC_CHECK
  1079   mem_delete (m);
  1080 #endif
  1081   MALLOC_UNBLOCK_INPUT;
  1082 }
  1083 
  1084 /*****  Allocation of aligned blocks of memory to store Lisp data.  *****/
  1085 
  1086 /* The entry point is lisp_align_malloc which returns blocks of at most
  1087    BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary.  */
  1088 
  1089 /* Byte alignment of storage blocks.  */
  1090 #ifdef HAVE_UNEXEC
  1091 # define BLOCK_ALIGN (1 << 10)
  1092 #else  /* !HAVE_UNEXEC */
  1093 # define BLOCK_ALIGN (1 << 15)
  1094 #endif
  1095 verify (POWER_OF_2 (BLOCK_ALIGN));
  1096 
  1097 /* Use aligned_alloc if it or a simple substitute is available.
  1098    Aligned allocation is incompatible with unexmacosx.c, so don't use
  1099    it on Darwin if HAVE_UNEXEC.  */
  1100 
  1101 #if ! (defined DARWIN_OS && defined HAVE_UNEXEC)
  1102 # if (defined HAVE_ALIGNED_ALLOC                                        \
  1103       || (defined HYBRID_MALLOC                                         \
  1104           ? defined HAVE_POSIX_MEMALIGN                                 \
  1105           : !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC))
  1106 #  define USE_ALIGNED_ALLOC 1
  1107 # elif !defined HYBRID_MALLOC && defined HAVE_POSIX_MEMALIGN
  1108 #  define USE_ALIGNED_ALLOC 1
  1109 #  define aligned_alloc my_aligned_alloc /* Avoid collision with lisp.h.  */
  1110 static void *
  1111 aligned_alloc (size_t alignment, size_t size)
  1112 {
  1113   /* POSIX says the alignment must be a power-of-2 multiple of sizeof (void *).
  1114      Verify this for all arguments this function is given.  */
  1115   verify (BLOCK_ALIGN % sizeof (void *) == 0
  1116           && POWER_OF_2 (BLOCK_ALIGN / sizeof (void *)));
  1117   verify (MALLOC_IS_LISP_ALIGNED
  1118           || (LISP_ALIGNMENT % sizeof (void *) == 0
  1119               && POWER_OF_2 (LISP_ALIGNMENT / sizeof (void *))));
  1120   eassert (alignment == BLOCK_ALIGN
  1121            || (!MALLOC_IS_LISP_ALIGNED && alignment == LISP_ALIGNMENT));
  1122 
  1123   void *p;
  1124   return posix_memalign (&p, alignment, size) == 0 ? p : 0;
  1125 }
  1126 # endif
  1127 #endif
  1128 
  1129 /* Padding to leave at the end of a malloc'd block.  This is to give
  1130    malloc a chance to minimize the amount of memory wasted to alignment.
  1131    It should be tuned to the particular malloc library used.
  1132    On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
  1133    aligned_alloc on the other hand would ideally prefer a value of 4
  1134    because otherwise, there's 1020 bytes wasted between each ablocks.
  1135    In Emacs, testing shows that those 1020 can most of the time be
  1136    efficiently used by malloc to place other objects, so a value of 0 can
  1137    still preferable unless you have a lot of aligned blocks and virtually
  1138    nothing else.  */
  1139 #define BLOCK_PADDING 0
  1140 #define BLOCK_BYTES \
  1141   (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
  1142 
  1143 /* Internal data structures and constants.  */
  1144 
  1145 #define ABLOCKS_SIZE 16
  1146 
  1147 /* An aligned block of memory.  */
  1148 struct ablock
  1149 {
  1150   union
  1151   {
  1152     char payload[BLOCK_BYTES];
  1153     struct ablock *next_free;
  1154   } x;
  1155 
  1156   /* ABASE is the aligned base of the ablocks.  It is overloaded to
  1157      hold a virtual "busy" field that counts twice the number of used
  1158      ablock values in the parent ablocks, plus one if the real base of
  1159      the parent ablocks is ABASE (if the "busy" field is even, the
  1160      word before the first ablock holds a pointer to the real base).
  1161      The first ablock has a "busy" ABASE, and the others have an
  1162      ordinary pointer ABASE.  To tell the difference, the code assumes
  1163      that pointers, when cast to uintptr_t, are at least 2 *
  1164      ABLOCKS_SIZE + 1.  */
  1165   struct ablocks *abase;
  1166 
  1167   /* The padding of all but the last ablock is unused.  The padding of
  1168      the last ablock in an ablocks is not allocated.  */
  1169 #if BLOCK_PADDING
  1170   char padding[BLOCK_PADDING];
  1171 #endif
  1172 };
  1173 
  1174 /* A bunch of consecutive aligned blocks.  */
  1175 struct ablocks
  1176 {
  1177   struct ablock blocks[ABLOCKS_SIZE];
  1178 };
  1179 
  1180 /* Size of the block requested from malloc or aligned_alloc.  */
  1181 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
  1182 
  1183 #define ABLOCK_ABASE(block) \
  1184   (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE)       \
  1185    ? (struct ablocks *) (block)                                 \
  1186    : (block)->abase)
  1187 
  1188 /* Virtual `busy' field.  */
  1189 #define ABLOCKS_BUSY(a_base) ((a_base)->blocks[0].abase)
  1190 
  1191 /* Pointer to the (not necessarily aligned) malloc block.  */
  1192 #ifdef USE_ALIGNED_ALLOC
  1193 #define ABLOCKS_BASE(abase) (abase)
  1194 #else
  1195 #define ABLOCKS_BASE(abase) \
  1196   (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **) (abase))[-1])
  1197 #endif
  1198 
  1199 #if GC_ASAN_POISON_OBJECTS
  1200 # define ASAN_POISON_ABLOCK(b) \
  1201   __asan_poison_memory_region (&(b)->x, sizeof ((b)->x))
  1202 # define ASAN_UNPOISON_ABLOCK(b) \
  1203   __asan_unpoison_memory_region (&(b)->x, sizeof ((b)->x))
  1204 #else
  1205 # define ASAN_POISON_ABLOCK(b) ((void) 0)
  1206 # define ASAN_UNPOISON_ABLOCK(b) ((void) 0)
  1207 #endif
  1208 
  1209 /* The list of free ablock.   */
  1210 static struct ablock *free_ablock;
  1211 
  1212 /* Allocate an aligned block of nbytes.
  1213    Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
  1214    smaller or equal to BLOCK_BYTES.  */
  1215 static void *
  1216 lisp_align_malloc (size_t nbytes, enum mem_type type)
  1217 {
  1218   void *base, *val;
  1219   struct ablocks *abase;
  1220 
  1221   eassert (nbytes <= BLOCK_BYTES);
  1222 
  1223   MALLOC_BLOCK_INPUT;
  1224 
  1225 #ifdef GC_MALLOC_CHECK
  1226   allocated_mem_type = type;
  1227 #endif
  1228 
  1229   if (!free_ablock)
  1230     {
  1231       int i;
  1232       bool aligned;
  1233 
  1234 #ifdef DOUG_LEA_MALLOC
  1235       if (!mmap_lisp_allowed_p ())
  1236         mallopt (M_MMAP_MAX, 0);
  1237 #endif
  1238 
  1239 #ifdef USE_ALIGNED_ALLOC
  1240       verify (ABLOCKS_BYTES % BLOCK_ALIGN == 0);
  1241       abase = base = aligned_alloc (BLOCK_ALIGN, ABLOCKS_BYTES);
  1242 #else
  1243       base = malloc (ABLOCKS_BYTES);
  1244       abase = pointer_align (base, BLOCK_ALIGN);
  1245 #endif
  1246 
  1247       if (base == 0)
  1248         {
  1249           MALLOC_UNBLOCK_INPUT;
  1250           memory_full (ABLOCKS_BYTES);
  1251         }
  1252 
  1253       aligned = (base == abase);
  1254       if (!aligned)
  1255         ((void **) abase)[-1] = base;
  1256 
  1257 #ifdef DOUG_LEA_MALLOC
  1258       if (!mmap_lisp_allowed_p ())
  1259           mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
  1260 #endif
  1261 
  1262 #if ! USE_LSB_TAG
  1263       /* If the memory just allocated cannot be addressed thru a Lisp
  1264          object's pointer, and it needs to be, that's equivalent to
  1265          running out of memory.  */
  1266       if (type != MEM_TYPE_NON_LISP)
  1267         {
  1268           Lisp_Object tem;
  1269           char *end = (char *) base + ABLOCKS_BYTES - 1;
  1270           XSETCONS (tem, end);
  1271           if ((char *) XCONS (tem) != end)
  1272             {
  1273               lisp_malloc_loser = base;
  1274               free (base);
  1275               MALLOC_UNBLOCK_INPUT;
  1276               memory_full (SIZE_MAX);
  1277             }
  1278         }
  1279 #endif
  1280 
  1281       /* Initialize the blocks and put them on the free list.
  1282          If `base' was not properly aligned, we can't use the last block.  */
  1283       for (i = 0; i < (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1); i++)
  1284         {
  1285           abase->blocks[i].abase = abase;
  1286           abase->blocks[i].x.next_free = free_ablock;
  1287           ASAN_POISON_ABLOCK (&abase->blocks[i]);
  1288           free_ablock = &abase->blocks[i];
  1289         }
  1290       intptr_t ialigned = aligned;
  1291       ABLOCKS_BUSY (abase) = (struct ablocks *) ialigned;
  1292 
  1293       eassert ((uintptr_t) abase % BLOCK_ALIGN == 0);
  1294       eassert (ABLOCK_ABASE (&abase->blocks[3]) == abase); /* 3 is arbitrary */
  1295       eassert (ABLOCK_ABASE (&abase->blocks[0]) == abase);
  1296       eassert (ABLOCKS_BASE (abase) == base);
  1297       eassert ((intptr_t) ABLOCKS_BUSY (abase) == aligned);
  1298     }
  1299 
  1300   ASAN_UNPOISON_ABLOCK (free_ablock);
  1301   abase = ABLOCK_ABASE (free_ablock);
  1302   ABLOCKS_BUSY (abase)
  1303     = (struct ablocks *) (2 + (intptr_t) ABLOCKS_BUSY (abase));
  1304   val = free_ablock;
  1305   free_ablock = free_ablock->x.next_free;
  1306 
  1307 #ifndef GC_MALLOC_CHECK
  1308   if (type != MEM_TYPE_NON_LISP)
  1309     mem_insert (val, (char *) val + nbytes, type);
  1310 #endif
  1311 
  1312   MALLOC_UNBLOCK_INPUT;
  1313 
  1314   MALLOC_PROBE (nbytes);
  1315 
  1316   eassert (0 == ((uintptr_t) val) % BLOCK_ALIGN);
  1317   return val;
  1318 }
  1319 
  1320 static void
  1321 lisp_align_free (void *block)
  1322 {
  1323   struct ablock *ablock = block;
  1324   struct ablocks *abase = ABLOCK_ABASE (ablock);
  1325 
  1326   MALLOC_BLOCK_INPUT;
  1327 #ifndef GC_MALLOC_CHECK
  1328   mem_delete (mem_find (block));
  1329 #endif
  1330   /* Put on free list.  */
  1331   ablock->x.next_free = free_ablock;
  1332   ASAN_POISON_ABLOCK (ablock);
  1333   free_ablock = ablock;
  1334   /* Update busy count.  */
  1335   intptr_t busy = (intptr_t) ABLOCKS_BUSY (abase) - 2;
  1336   eassume (0 <= busy && busy <= 2 * ABLOCKS_SIZE - 1);
  1337   ABLOCKS_BUSY (abase) = (struct ablocks *) busy;
  1338 
  1339   if (busy < 2)
  1340     { /* All the blocks are free.  */
  1341       int i = 0;
  1342       bool aligned = busy;
  1343       struct ablock **tem = &free_ablock;
  1344       struct ablock *atop = &abase->blocks[aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1];
  1345       while (*tem)
  1346         {
  1347 #if GC_ASAN_POISON_OBJECTS
  1348           __asan_unpoison_memory_region (&(*tem)->x,
  1349                                          sizeof ((*tem)->x));
  1350 #endif
  1351           if (*tem >= (struct ablock *) abase && *tem < atop)
  1352             {
  1353               i++;
  1354               *tem = (*tem)->x.next_free;
  1355             }
  1356           else
  1357             tem = &(*tem)->x.next_free;
  1358         }
  1359       eassert ((aligned & 1) == aligned);
  1360       eassert (i == (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1));
  1361 #ifdef USE_POSIX_MEMALIGN
  1362       eassert ((uintptr_t) ABLOCKS_BASE (abase) % BLOCK_ALIGN == 0);
  1363 #endif
  1364       free (ABLOCKS_BASE (abase));
  1365     }
  1366   MALLOC_UNBLOCK_INPUT;
  1367 }
  1368 
  1369 /* True if a malloc-returned pointer P is suitably aligned for SIZE,
  1370    where Lisp object alignment may be needed if SIZE is a multiple of
  1371    LISP_ALIGNMENT.  */
  1372 
  1373 static bool
  1374 laligned (void *p, size_t size)
  1375 {
  1376   return (MALLOC_IS_LISP_ALIGNED || (intptr_t) p % LISP_ALIGNMENT == 0
  1377           || size % LISP_ALIGNMENT != 0);
  1378 }
  1379 
  1380 /* Like malloc and realloc except return null only on failure,
  1381    the result is Lisp-aligned if SIZE is, and lrealloc's pointer
  1382    argument must be nonnull.  Code allocating C heap memory
  1383    for a Lisp object should use one of these functions to obtain a
  1384    pointer P; that way, if T is an enum Lisp_Type value and L ==
  1385    make_lisp_ptr (P, T), then XPNTR (L) == P and XTYPE (L) == T.
  1386 
  1387    If CLEARIT, arrange for the allocated memory to be cleared.
  1388    This might use calloc, as calloc can be faster than malloc+memset.
  1389 
  1390    On typical modern platforms these functions' loops do not iterate.
  1391    On now-rare (and perhaps nonexistent) platforms, the code can loop,
  1392    reallocating (typically with larger and larger sizes) until the
  1393    allocator returns a Lisp-aligned pointer.  This loop in
  1394    theory could repeat forever.  If an infinite loop is possible on a
  1395    platform, a build would surely loop and the builder can then send
  1396    us a bug report.  Adding a counter to try to detect any such loop
  1397    would complicate the code (and possibly introduce bugs, in code
  1398    that's never really exercised) for little benefit.  */
  1399 
  1400 static void *
  1401 lmalloc (size_t size, bool clearit)
  1402 {
  1403 #ifdef USE_ALIGNED_ALLOC
  1404   if (! MALLOC_IS_LISP_ALIGNED && size % LISP_ALIGNMENT == 0)
  1405     {
  1406       void *p = aligned_alloc (LISP_ALIGNMENT, size);
  1407       if (p)
  1408         {
  1409           if (clearit)
  1410             memclear (p, size);
  1411         }
  1412       else if (! (MALLOC_0_IS_NONNULL || size))
  1413         return aligned_alloc (LISP_ALIGNMENT, LISP_ALIGNMENT);
  1414       return p;
  1415     }
  1416 #endif
  1417 
  1418   while (true)
  1419     {
  1420       void *p = clearit ? calloc (1, size) : malloc (size);
  1421       if (laligned (p, size) && (MALLOC_0_IS_NONNULL || size || p))
  1422         return p;
  1423       free (p);
  1424       size_t bigger = size + LISP_ALIGNMENT;
  1425       if (size < bigger)
  1426         size = bigger;
  1427     }
  1428 }
  1429 
  1430 static void *
  1431 lrealloc (void *p, size_t size)
  1432 {
  1433   while (true)
  1434     {
  1435       p = realloc (p, size);
  1436       if (laligned (p, size) && (size || p))
  1437         return p;
  1438       size_t bigger = size + LISP_ALIGNMENT;
  1439       if (size < bigger)
  1440         size = bigger;
  1441     }
  1442 }
  1443 
  1444 
  1445 /***********************************************************************
  1446                          Interval Allocation
  1447  ***********************************************************************/
  1448 
  1449 /* Number of intervals allocated in an interval_block structure.  */
  1450 
  1451 enum { INTERVAL_BLOCK_SIZE
  1452          = ((MALLOC_SIZE_NEAR (1024) - sizeof (struct interval_block *))
  1453             / sizeof (struct interval)) };
  1454 
  1455 /* Intervals are allocated in chunks in the form of an interval_block
  1456    structure.  */
  1457 
  1458 struct interval_block
  1459 {
  1460   /* Place `intervals' first, to preserve alignment.  */
  1461   struct interval intervals[INTERVAL_BLOCK_SIZE];
  1462   struct interval_block *next;
  1463 };
  1464 
  1465 /* Current interval block.  Its `next' pointer points to older
  1466    blocks.  */
  1467 
  1468 static struct interval_block *interval_block;
  1469 
  1470 /* Index in interval_block above of the next unused interval
  1471    structure.  */
  1472 
  1473 static int interval_block_index = INTERVAL_BLOCK_SIZE;
  1474 
  1475 /* List of free intervals.  */
  1476 
  1477 static INTERVAL interval_free_list;
  1478 
  1479 #if GC_ASAN_POISON_OBJECTS
  1480 # define ASAN_POISON_INTERVAL_BLOCK(b)         \
  1481   __asan_poison_memory_region ((b)->intervals, \
  1482                                sizeof ((b)->intervals))
  1483 # define ASAN_UNPOISON_INTERVAL_BLOCK(b)         \
  1484   __asan_unpoison_memory_region ((b)->intervals, \
  1485                                  sizeof ((b)->intervals))
  1486 # define ASAN_POISON_INTERVAL(i) \
  1487   __asan_poison_memory_region ((i), sizeof (*(i)))
  1488 # define ASAN_UNPOISON_INTERVAL(i) \
  1489   __asan_unpoison_memory_region ((i), sizeof (*(i)))
  1490 #else
  1491 # define ASAN_POISON_INTERVAL_BLOCK(b) ((void) 0)
  1492 # define ASAN_UNPOISON_INTERVAL_BLOCK(b) ((void) 0)
  1493 # define ASAN_POISON_INTERVAL(i) ((void) 0)
  1494 # define ASAN_UNPOISON_INTERVAL(i) ((void) 0)
  1495 #endif
  1496 
  1497 /* Return a new interval.  */
  1498 
  1499 INTERVAL
  1500 make_interval (void)
  1501 {
  1502   INTERVAL val;
  1503 
  1504   MALLOC_BLOCK_INPUT;
  1505 
  1506   if (interval_free_list)
  1507     {
  1508       val = interval_free_list;
  1509       ASAN_UNPOISON_INTERVAL (val);
  1510       interval_free_list = INTERVAL_PARENT (interval_free_list);
  1511     }
  1512   else
  1513     {
  1514       if (interval_block_index == INTERVAL_BLOCK_SIZE)
  1515         {
  1516           struct interval_block *newi
  1517             = lisp_malloc (sizeof *newi, false, MEM_TYPE_NON_LISP);
  1518 
  1519           newi->next = interval_block;
  1520           ASAN_POISON_INTERVAL_BLOCK (newi);
  1521           interval_block = newi;
  1522           interval_block_index = 0;
  1523         }
  1524       val = &interval_block->intervals[interval_block_index++];
  1525       ASAN_UNPOISON_INTERVAL (val);
  1526     }
  1527 
  1528   MALLOC_UNBLOCK_INPUT;
  1529 
  1530   tally_consing (sizeof (struct interval));
  1531   intervals_consed++;
  1532   RESET_INTERVAL (val);
  1533   val->gcmarkbit = 0;
  1534   return val;
  1535 }
  1536 
  1537 
  1538 /* Mark Lisp objects in interval I.  */
  1539 
  1540 static void
  1541 mark_interval_tree_1 (INTERVAL i, void *dummy)
  1542 {
  1543   /* Intervals should never be shared.  So, if extra internal checking is
  1544      enabled, GC aborts if it seems to have visited an interval twice.  */
  1545   eassert (!interval_marked_p (i));
  1546   set_interval_marked (i);
  1547   mark_object (i->plist);
  1548 }
  1549 
  1550 /* Mark the interval tree rooted in I.  */
  1551 
  1552 static void
  1553 mark_interval_tree (INTERVAL i)
  1554 {
  1555   if (i && !interval_marked_p (i))
  1556     traverse_intervals_noorder (i, mark_interval_tree_1, NULL);
  1557 }
  1558 
  1559 /***********************************************************************
  1560                           String Allocation
  1561  ***********************************************************************/
  1562 
  1563 /* Lisp_Strings are allocated in string_block structures.  When a new
  1564    string_block is allocated, all the Lisp_Strings it contains are
  1565    added to a free-list string_free_list.  When a new Lisp_String is
  1566    needed, it is taken from that list.  During the sweep phase of GC,
  1567    string_blocks that are entirely free are freed, except two which
  1568    we keep.
  1569 
  1570    String data is allocated from sblock structures.  Strings larger
  1571    than LARGE_STRING_BYTES, get their own sblock, data for smaller
  1572    strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
  1573 
  1574    Sblocks consist internally of sdata structures, one for each
  1575    Lisp_String.  The sdata structure points to the Lisp_String it
  1576    belongs to.  The Lisp_String points back to the `u.data' member of
  1577    its sdata structure.
  1578 
  1579    When a Lisp_String is freed during GC, it is put back on
  1580    string_free_list, and its `data' member and its sdata's `string'
  1581    pointer is set to null.  The size of the string is recorded in the
  1582    `n.nbytes' member of the sdata.  So, sdata structures that are no
  1583    longer used, can be easily recognized, and it's easy to compact the
  1584    sblocks of small strings which we do in compact_small_strings.  */
  1585 
  1586 /* Size in bytes of an sblock structure used for small strings.  */
  1587 
  1588 enum { SBLOCK_SIZE = MALLOC_SIZE_NEAR (8192) };
  1589 
  1590 /* Strings larger than this are considered large strings.  String data
  1591    for large strings is allocated from individual sblocks.  */
  1592 
  1593 #define LARGE_STRING_BYTES 1024
  1594 
  1595 /* The layout of a nonnull string.  */
  1596 
  1597 struct sdata
  1598 {
  1599   /* Back-pointer to the string this sdata belongs to.  If null, this
  1600      structure is free, and NBYTES (in this structure or in the union below)
  1601      contains the string's byte size (the same value that STRING_BYTES
  1602      would return if STRING were non-null).  If non-null, STRING_BYTES
  1603      (STRING) is the size of the data, and DATA contains the string's
  1604      contents.  */
  1605   struct Lisp_String *string;
  1606 
  1607 #ifdef GC_CHECK_STRING_BYTES
  1608   ptrdiff_t nbytes;
  1609 #endif
  1610 
  1611   unsigned char data[FLEXIBLE_ARRAY_MEMBER];
  1612 };
  1613 
  1614 /* A union describing string memory sub-allocated from an sblock.
  1615    This is where the contents of Lisp strings are stored.  */
  1616 
  1617 typedef union
  1618 {
  1619   struct Lisp_String *string;
  1620 
  1621   /* When STRING is nonnull, this union is actually of type 'struct sdata',
  1622      which has a flexible array member.  However, if implemented by
  1623      giving this union a member of type 'struct sdata', the union
  1624      could not be the last (flexible) member of 'struct sblock',
  1625      because C99 prohibits a flexible array member from having a type
  1626      that is itself a flexible array.  So, comment this member out here,
  1627      but remember that the option's there when using this union.  */
  1628 #if 0
  1629   struct sdata u;
  1630 #endif
  1631 
  1632   /* When STRING is null.  */
  1633   struct
  1634   {
  1635     struct Lisp_String *string;
  1636     ptrdiff_t nbytes;
  1637   } n;
  1638 } sdata;
  1639 
  1640 #define SDATA_NBYTES(S) (S)->n.nbytes
  1641 #define SDATA_DATA(S)   ((struct sdata *) (S))->data
  1642 
  1643 enum { SDATA_DATA_OFFSET = offsetof (struct sdata, data) };
  1644 
  1645 /* Structure describing a block of memory which is sub-allocated to
  1646    obtain string data memory for strings.  Blocks for small strings
  1647    are of fixed size SBLOCK_SIZE.  Blocks for large strings are made
  1648    as large as needed.  */
  1649 
  1650 struct sblock
  1651 {
  1652   /* Next in list.  */
  1653   struct sblock *next;
  1654 
  1655   /* Pointer to the next free sdata block.  This points past the end
  1656      of the sblock if there isn't any space left in this block.  */
  1657   sdata *next_free;
  1658 
  1659   /* String data.  */
  1660   sdata data[FLEXIBLE_ARRAY_MEMBER];
  1661 };
  1662 
  1663 /* Number of Lisp strings in a string_block structure.  */
  1664 
  1665 enum { STRING_BLOCK_SIZE
  1666          = ((MALLOC_SIZE_NEAR (1024) - sizeof (struct string_block *))
  1667             / sizeof (struct Lisp_String)) };
  1668 
  1669 /* Structure describing a block from which Lisp_String structures
  1670    are allocated.  */
  1671 
  1672 struct string_block
  1673 {
  1674   /* Place `strings' first, to preserve alignment.  */
  1675   struct Lisp_String strings[STRING_BLOCK_SIZE];
  1676   struct string_block *next;
  1677 };
  1678 
  1679 /* Head and tail of the list of sblock structures holding Lisp string
  1680    data.  We always allocate from current_sblock.  The NEXT pointers
  1681    in the sblock structures go from oldest_sblock to current_sblock.  */
  1682 
  1683 static struct sblock *oldest_sblock, *current_sblock;
  1684 
  1685 /* List of sblocks for large strings.  */
  1686 
  1687 static struct sblock *large_sblocks;
  1688 
  1689 /* List of string_block structures.  */
  1690 
  1691 static struct string_block *string_blocks;
  1692 
  1693 /* Free-list of Lisp_Strings.  */
  1694 
  1695 static struct Lisp_String *string_free_list;
  1696 
  1697 /* Given a pointer to a Lisp_String S which is on the free-list
  1698    string_free_list, return a pointer to its successor in the
  1699    free-list.  */
  1700 
  1701 #define NEXT_FREE_LISP_STRING(S) ((S)->u.next)
  1702 
  1703 /* Return a pointer to the sdata structure belonging to Lisp string S.
  1704    S must be live, i.e. S->data must not be null.  S->data is actually
  1705    a pointer to the `u.data' member of its sdata structure; the
  1706    structure starts at a constant offset in front of that.  */
  1707 
  1708 #define SDATA_OF_STRING(S) ((sdata *) ((S)->u.s.data - SDATA_DATA_OFFSET))
  1709 
  1710 
  1711 #ifdef GC_CHECK_STRING_OVERRUN
  1712 
  1713 /* Check for overrun in string data blocks by appending a small
  1714    "cookie" after each allocated string data block, and check for the
  1715    presence of this cookie during GC.  */
  1716 # define GC_STRING_OVERRUN_COOKIE_SIZE ROUNDUP (4, alignof (sdata))
  1717 static char const string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
  1718   { '\xde', '\xad', '\xbe', '\xef', /* Perhaps some zeros here.  */ };
  1719 
  1720 #else
  1721 # define GC_STRING_OVERRUN_COOKIE_SIZE 0
  1722 #endif
  1723 
  1724 /* Return the size of an sdata structure large enough to hold N bytes
  1725    of string data.  This counts the sdata structure, the N bytes, a
  1726    terminating NUL byte, and alignment padding.  */
  1727 
  1728 static ptrdiff_t
  1729 sdata_size (ptrdiff_t n)
  1730 {
  1731   /* Reserve space for the nbytes union member even when N + 1 is less
  1732      than the size of that member.  */
  1733   ptrdiff_t unaligned_size = max (SDATA_DATA_OFFSET + n + 1,
  1734                                   sizeof (sdata));
  1735   int sdata_align = max (FLEXALIGNOF (struct sdata), alignof (sdata));
  1736   return (unaligned_size + sdata_align - 1) & ~(sdata_align - 1);
  1737 }
  1738 
  1739 /* Extra bytes to allocate for each string.  */
  1740 #define GC_STRING_EXTRA GC_STRING_OVERRUN_COOKIE_SIZE
  1741 
  1742 /* Exact bound on the number of bytes in a string, not counting the
  1743    terminating null.  A string cannot contain more bytes than
  1744    STRING_BYTES_BOUND, nor can it be so long that the size_t
  1745    arithmetic in allocate_string_data would overflow while it is
  1746    calculating a value to be passed to malloc.  */
  1747 static ptrdiff_t const STRING_BYTES_MAX =
  1748   min (STRING_BYTES_BOUND,
  1749        ((SIZE_MAX
  1750          - GC_STRING_EXTRA
  1751          - offsetof (struct sblock, data)
  1752          - SDATA_DATA_OFFSET)
  1753         & ~(sizeof (EMACS_INT) - 1)));
  1754 
  1755 /* Initialize string allocation.  Called from init_alloc_once.  */
  1756 
  1757 static void
  1758 init_strings (void)
  1759 {
  1760   empty_unibyte_string = make_pure_string ("", 0, 0, 0);
  1761   staticpro (&empty_unibyte_string);
  1762   empty_multibyte_string = make_pure_string ("", 0, 0, 1);
  1763   staticpro (&empty_multibyte_string);
  1764 }
  1765 
  1766 #if GC_ASAN_POISON_OBJECTS
  1767 /* Prepare s for denoting a free sdata struct, i.e, poison all bytes
  1768    in the flexible array member, except the first SDATA_OFFSET bytes.
  1769    This is only effective for strings of size n where n > sdata_size(n).
  1770  */
  1771 # define ASAN_PREPARE_DEAD_SDATA(s, size)                          \
  1772   do {                                                             \
  1773     __asan_poison_memory_region ((s), sdata_size ((size)));        \
  1774     __asan_unpoison_memory_region (&(((s))->string),                 \
  1775                                    sizeof (struct Lisp_String *)); \
  1776     __asan_unpoison_memory_region (&SDATA_NBYTES ((s)),            \
  1777                                    sizeof (SDATA_NBYTES ((s))));   \
  1778    } while (false)
  1779 /* Prepare s for storing string data for NBYTES bytes.  */
  1780 # define ASAN_PREPARE_LIVE_SDATA(s, nbytes) \
  1781   __asan_unpoison_memory_region ((s), sdata_size ((nbytes)))
  1782 # define ASAN_POISON_SBLOCK_DATA(b, size) \
  1783   __asan_poison_memory_region ((b)->data, (size))
  1784 # define ASAN_POISON_STRING_BLOCK(b) \
  1785   __asan_poison_memory_region ((b)->strings, STRING_BLOCK_SIZE)
  1786 # define ASAN_UNPOISON_STRING_BLOCK(b) \
  1787   __asan_unpoison_memory_region ((b)->strings, STRING_BLOCK_SIZE)
  1788 # define ASAN_POISON_STRING(s) \
  1789   __asan_poison_memory_region ((s), sizeof (*(s)))
  1790 # define ASAN_UNPOISON_STRING(s) \
  1791   __asan_unpoison_memory_region ((s), sizeof (*(s)))
  1792 #else
  1793 # define ASAN_PREPARE_DEAD_SDATA(s, size) ((void) 0)
  1794 # define ASAN_PREPARE_LIVE_SDATA(s, nbytes) ((void) 0)
  1795 # define ASAN_POISON_SBLOCK_DATA(b, size) ((void) 0)
  1796 # define ASAN_POISON_STRING_BLOCK(b) ((void) 0)
  1797 # define ASAN_UNPOISON_STRING_BLOCK(b) ((void) 0)
  1798 # define ASAN_POISON_STRING(s) ((void) 0)
  1799 # define ASAN_UNPOISON_STRING(s) ((void) 0)
  1800 #endif
  1801 
  1802 #ifdef GC_CHECK_STRING_BYTES
  1803 
  1804 static int check_string_bytes_count;
  1805 
  1806 /* Like STRING_BYTES, but with debugging check.  Can be
  1807    called during GC, so pay attention to the mark bit.  */
  1808 
  1809 ptrdiff_t
  1810 string_bytes (struct Lisp_String *s)
  1811 {
  1812   ptrdiff_t nbytes =
  1813     (s->u.s.size_byte < 0 ? s->u.s.size & ~ARRAY_MARK_FLAG : s->u.s.size_byte);
  1814 
  1815   if (!PURE_P (s) && !pdumper_object_p (s) && s->u.s.data
  1816       && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
  1817     emacs_abort ();
  1818   return nbytes;
  1819 }
  1820 
  1821 /* Check validity of Lisp strings' string_bytes member in B.  */
  1822 
  1823 static void
  1824 check_sblock (struct sblock *b)
  1825 {
  1826   sdata *end = b->next_free;
  1827 
  1828   for (sdata *from = b->data; from < end; )
  1829     {
  1830       ptrdiff_t nbytes = sdata_size (from->string
  1831                                      ? string_bytes (from->string)
  1832                                      : SDATA_NBYTES (from));
  1833       from = (sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
  1834     }
  1835 }
  1836 
  1837 
  1838 /* Check validity of Lisp strings' string_bytes member.  ALL_P
  1839    means check all strings, otherwise check only most
  1840    recently allocated strings.  Used for hunting a bug.  */
  1841 
  1842 static void
  1843 check_string_bytes (bool all_p)
  1844 {
  1845   if (all_p)
  1846     {
  1847       struct sblock *b;
  1848 
  1849       for (b = large_sblocks; b; b = b->next)
  1850         {
  1851           struct Lisp_String *s = b->data[0].string;
  1852           if (s)
  1853             string_bytes (s);
  1854         }
  1855 
  1856       for (b = oldest_sblock; b; b = b->next)
  1857         check_sblock (b);
  1858     }
  1859   else if (current_sblock)
  1860     check_sblock (current_sblock);
  1861 }
  1862 
  1863 #else /* not GC_CHECK_STRING_BYTES */
  1864 
  1865 #define check_string_bytes(all) ((void) 0)
  1866 
  1867 #endif /* GC_CHECK_STRING_BYTES */
  1868 
  1869 #ifdef GC_CHECK_STRING_FREE_LIST
  1870 
  1871 /* Walk through the string free list looking for bogus next pointers.
  1872    This may catch buffer overrun from a previous string.  */
  1873 
  1874 static void
  1875 check_string_free_list (void)
  1876 {
  1877   struct Lisp_String *s;
  1878 
  1879   /* Pop a Lisp_String off the free-list.  */
  1880   s = string_free_list;
  1881   while (s != NULL)
  1882     {
  1883       if ((uintptr_t) s < 1024)
  1884         emacs_abort ();
  1885       s = NEXT_FREE_LISP_STRING (s);
  1886     }
  1887 }
  1888 #else
  1889 #define check_string_free_list()
  1890 #endif
  1891 
  1892 /* Return a new Lisp_String.  */
  1893 
  1894 static struct Lisp_String *
  1895 allocate_string (void)
  1896 {
  1897   struct Lisp_String *s;
  1898 
  1899   MALLOC_BLOCK_INPUT;
  1900 
  1901   /* If the free-list is empty, allocate a new string_block, and
  1902      add all the Lisp_Strings in it to the free-list.  */
  1903   if (string_free_list == NULL)
  1904     {
  1905       struct string_block *b = lisp_malloc (sizeof *b, false, MEM_TYPE_STRING);
  1906       int i;
  1907 
  1908       b->next = string_blocks;
  1909       string_blocks = b;
  1910 
  1911       for (i = STRING_BLOCK_SIZE - 1; i >= 0; --i)
  1912         {
  1913           s = b->strings + i;
  1914           /* Every string on a free list should have NULL data pointer.  */
  1915           s->u.s.data = NULL;
  1916           NEXT_FREE_LISP_STRING (s) = string_free_list;
  1917           string_free_list = s;
  1918         }
  1919       ASAN_POISON_STRING_BLOCK (b);
  1920     }
  1921 
  1922   check_string_free_list ();
  1923 
  1924   /* Pop a Lisp_String off the free-list.  */
  1925   s = string_free_list;
  1926   ASAN_UNPOISON_STRING (s);
  1927   string_free_list = NEXT_FREE_LISP_STRING (s);
  1928 
  1929   MALLOC_UNBLOCK_INPUT;
  1930 
  1931   ++strings_consed;
  1932   tally_consing (sizeof *s);
  1933 
  1934 #ifdef GC_CHECK_STRING_BYTES
  1935   if (!noninteractive)
  1936     {
  1937       if (++check_string_bytes_count == 200)
  1938         {
  1939           check_string_bytes_count = 0;
  1940           check_string_bytes (1);
  1941         }
  1942       else
  1943         check_string_bytes (0);
  1944     }
  1945 #endif /* GC_CHECK_STRING_BYTES */
  1946 
  1947   return s;
  1948 }
  1949 
  1950 
  1951 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
  1952    plus a NUL byte at the end.  Allocate an sdata structure DATA for
  1953    S, and set S->u.s.data to SDATA->u.data.  Store a NUL byte at the
  1954    end of S->u.s.data.  Set S->u.s.size to NCHARS and S->u.s.size_byte
  1955    to NBYTES.  Free S->u.s.data if it was initially non-null.
  1956 
  1957    If CLEARIT, also clear the other bytes of S->u.s.data.  */
  1958 
  1959 static void
  1960 allocate_string_data (struct Lisp_String *s,
  1961                       EMACS_INT nchars, EMACS_INT nbytes, bool clearit,
  1962                       bool immovable)
  1963 {
  1964   sdata *data;
  1965   struct sblock *b;
  1966 
  1967   if (STRING_BYTES_MAX < nbytes)
  1968     string_overflow ();
  1969 
  1970   /* Determine the number of bytes needed to store NBYTES bytes
  1971      of string data.  */
  1972   ptrdiff_t needed = sdata_size (nbytes);
  1973 
  1974   MALLOC_BLOCK_INPUT;
  1975 
  1976   if (nbytes > LARGE_STRING_BYTES || immovable)
  1977     {
  1978       size_t size = FLEXSIZEOF (struct sblock, data, needed);
  1979 
  1980 #ifdef DOUG_LEA_MALLOC
  1981       if (!mmap_lisp_allowed_p ())
  1982         mallopt (M_MMAP_MAX, 0);
  1983 #endif
  1984 
  1985       b = lisp_malloc (size + GC_STRING_EXTRA, clearit, MEM_TYPE_NON_LISP);
  1986       ASAN_POISON_SBLOCK_DATA (b, size);
  1987 
  1988 #ifdef DOUG_LEA_MALLOC
  1989       if (!mmap_lisp_allowed_p ())
  1990         mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
  1991 #endif
  1992 
  1993       data = b->data;
  1994       b->next = large_sblocks;
  1995       b->next_free = data;
  1996       large_sblocks = b;
  1997     }
  1998   else
  1999     {
  2000       b = current_sblock;
  2001 
  2002       if (b == NULL
  2003           || (SBLOCK_SIZE - GC_STRING_EXTRA
  2004               < (char *) b->next_free - (char *) b + needed))
  2005         {
  2006           /* Not enough room in the current sblock.  */
  2007           b = lisp_malloc (SBLOCK_SIZE, false, MEM_TYPE_NON_LISP);
  2008           ASAN_POISON_SBLOCK_DATA (b, SBLOCK_SIZE);
  2009 
  2010           data = b->data;
  2011           b->next = NULL;
  2012           b->next_free = data;
  2013 
  2014           if (current_sblock)
  2015             current_sblock->next = b;
  2016           else
  2017             oldest_sblock = b;
  2018           current_sblock = b;
  2019         }
  2020 
  2021       data = b->next_free;
  2022 
  2023       if (clearit)
  2024         {
  2025 #if GC_ASAN_POISON_OBJECTS
  2026           /* We are accessing SDATA_DATA (data) before it gets
  2027            * normally unpoisoned, so do it manually.  */
  2028           __asan_unpoison_memory_region (SDATA_DATA (data), nbytes);
  2029 #endif
  2030           memset (SDATA_DATA (data), 0, nbytes);
  2031         }
  2032     }
  2033 
  2034   ASAN_PREPARE_LIVE_SDATA (data, nbytes);
  2035   data->string = s;
  2036   b->next_free = (sdata *) ((char *) data + needed + GC_STRING_EXTRA);
  2037   eassert ((uintptr_t) b->next_free % alignof (sdata) == 0);
  2038 
  2039   MALLOC_UNBLOCK_INPUT;
  2040 
  2041   s->u.s.data = SDATA_DATA (data);
  2042 #ifdef GC_CHECK_STRING_BYTES
  2043   SDATA_NBYTES (data) = nbytes;
  2044 #endif
  2045   s->u.s.size = nchars;
  2046   s->u.s.size_byte = nbytes;
  2047   s->u.s.data[nbytes] = '\0';
  2048 #ifdef GC_CHECK_STRING_OVERRUN
  2049   memcpy ((char *) data + needed, string_overrun_cookie,
  2050           GC_STRING_OVERRUN_COOKIE_SIZE);
  2051 #endif
  2052 
  2053   tally_consing (needed);
  2054 }
  2055 
  2056 /* Reallocate multibyte STRING data when a single character is replaced.
  2057    The character is at byte offset CIDX_BYTE in the string.
  2058    The character being replaced is CLEN bytes long,
  2059    and the character that will replace it is NEW_CLEN bytes long.
  2060    Return the address where the caller should store the new character.  */
  2061 
  2062 unsigned char *
  2063 resize_string_data (Lisp_Object string, ptrdiff_t cidx_byte,
  2064                     int clen, int new_clen)
  2065 {
  2066   eassume (STRING_MULTIBYTE (string));
  2067   sdata *old_sdata = SDATA_OF_STRING (XSTRING (string));
  2068   ptrdiff_t nchars = SCHARS (string);
  2069   ptrdiff_t nbytes = SBYTES (string);
  2070   ptrdiff_t new_nbytes = nbytes + (new_clen - clen);
  2071   unsigned char *data = SDATA (string);
  2072   unsigned char *new_charaddr;
  2073 
  2074   if (sdata_size (nbytes) == sdata_size (new_nbytes))
  2075     {
  2076       /* No need to reallocate, as the size change falls within the
  2077          alignment slop.  */
  2078       XSTRING (string)->u.s.size_byte = new_nbytes;
  2079 #ifdef GC_CHECK_STRING_BYTES
  2080       SDATA_NBYTES (old_sdata) = new_nbytes;
  2081 #endif
  2082       new_charaddr = data + cidx_byte;
  2083       memmove (new_charaddr + new_clen, new_charaddr + clen,
  2084                nbytes - (cidx_byte + (clen - 1)));
  2085     }
  2086   else
  2087     {
  2088       allocate_string_data (XSTRING (string), nchars, new_nbytes, false, false);
  2089       unsigned char *new_data = SDATA (string);
  2090       new_charaddr = new_data + cidx_byte;
  2091       memcpy (new_charaddr + new_clen, data + cidx_byte + clen,
  2092               nbytes - (cidx_byte + clen));
  2093       memcpy (new_data, data, cidx_byte);
  2094 
  2095       /* Mark old string data as free by setting its string back-pointer
  2096          to null, and record the size of the data in it.  */
  2097       SDATA_NBYTES (old_sdata) = nbytes;
  2098       old_sdata->string = NULL;
  2099     }
  2100 
  2101   clear_string_char_byte_cache ();
  2102 
  2103   return new_charaddr;
  2104 }
  2105 
  2106 
  2107 /* Sweep and compact strings.  */
  2108 
  2109 NO_INLINE /* For better stack traces */
  2110 static void
  2111 sweep_strings (void)
  2112 {
  2113   struct string_block *b, *next;
  2114   struct string_block *live_blocks = NULL;
  2115 
  2116   string_free_list = NULL;
  2117   gcstat.total_strings = gcstat.total_free_strings = 0;
  2118   gcstat.total_string_bytes = 0;
  2119 
  2120   /* Scan strings_blocks, free Lisp_Strings that aren't marked.  */
  2121   for (b = string_blocks; b; b = next)
  2122     {
  2123       int i, nfree = 0;
  2124       struct Lisp_String *free_list_before = string_free_list;
  2125 
  2126       ASAN_UNPOISON_STRING_BLOCK (b);
  2127 
  2128       next = b->next;
  2129 
  2130       for (i = 0; i < STRING_BLOCK_SIZE; ++i)
  2131         {
  2132           struct Lisp_String *s = b->strings + i;
  2133 
  2134           ASAN_UNPOISON_STRING (s);
  2135 
  2136           if (s->u.s.data)
  2137             {
  2138               /* String was not on free-list before.  */
  2139               if (XSTRING_MARKED_P (s))
  2140                 {
  2141                   /* String is live; unmark it and its intervals.  */
  2142                   XUNMARK_STRING (s);
  2143 
  2144                   /* Do not use string_(set|get)_intervals here.  */
  2145                   s->u.s.intervals = balance_intervals (s->u.s.intervals);
  2146 
  2147                   gcstat.total_strings++;
  2148                   gcstat.total_string_bytes += STRING_BYTES (s);
  2149                 }
  2150               else
  2151                 {
  2152                   /* String is dead.  Put it on the free-list.  */
  2153                   sdata *data = SDATA_OF_STRING (s);
  2154 
  2155                   /* Save the size of S in its sdata so that we know
  2156                      how large that is.  Reset the sdata's string
  2157                      back-pointer so that we know it's free.  */
  2158 #ifdef GC_CHECK_STRING_BYTES
  2159                   if (string_bytes (s) != SDATA_NBYTES (data))
  2160                     emacs_abort ();
  2161 #else
  2162                   data->n.nbytes = STRING_BYTES (s);
  2163 #endif
  2164                   data->string = NULL;
  2165 
  2166                   /* Reset the strings's `data' member so that we
  2167                      know it's free.  */
  2168                   s->u.s.data = NULL;
  2169 
  2170                   /* Put the string on the free-list.  */
  2171                   NEXT_FREE_LISP_STRING (s) = string_free_list;
  2172                   ASAN_POISON_STRING (s);
  2173                   ASAN_PREPARE_DEAD_SDATA (data, SDATA_NBYTES (data));
  2174                   string_free_list = s;
  2175                   ++nfree;
  2176                 }
  2177             }
  2178           else
  2179             {
  2180               /* S was on the free-list before.  Put it there again.  */
  2181               NEXT_FREE_LISP_STRING (s) = string_free_list;
  2182               ASAN_POISON_STRING (s);
  2183 
  2184               string_free_list = s;
  2185               ++nfree;
  2186             }
  2187         }
  2188 
  2189       /* Free blocks that contain free Lisp_Strings only, except
  2190          the first two of them.  */
  2191       if (nfree == STRING_BLOCK_SIZE
  2192           && gcstat.total_free_strings > STRING_BLOCK_SIZE)
  2193         {
  2194           lisp_free (b);
  2195           string_free_list = free_list_before;
  2196         }
  2197       else
  2198         {
  2199           gcstat.total_free_strings += nfree;
  2200           b->next = live_blocks;
  2201           live_blocks = b;
  2202         }
  2203     }
  2204 
  2205   check_string_free_list ();
  2206 
  2207   string_blocks = live_blocks;
  2208   free_large_strings ();
  2209   compact_small_strings ();
  2210 
  2211   check_string_free_list ();
  2212 }
  2213 
  2214 
  2215 /* Free dead large strings.  */
  2216 
  2217 static void
  2218 free_large_strings (void)
  2219 {
  2220   struct sblock *b, *next;
  2221   struct sblock *live_blocks = NULL;
  2222 
  2223   for (b = large_sblocks; b; b = next)
  2224     {
  2225       next = b->next;
  2226 
  2227       if (b->data[0].string == NULL)
  2228         lisp_free (b);
  2229       else
  2230         {
  2231           b->next = live_blocks;
  2232           live_blocks = b;
  2233         }
  2234     }
  2235 
  2236   large_sblocks = live_blocks;
  2237 }
  2238 
  2239 
  2240 /* Compact data of small strings.  Free sblocks that don't contain
  2241    data of live strings after compaction.  */
  2242 
  2243 static void
  2244 compact_small_strings (void)
  2245 {
  2246   /* TB is the sblock we copy to, TO is the sdata within TB we copy
  2247      to, and TB_END is the end of TB.  */
  2248   struct sblock *tb = oldest_sblock;
  2249   if (tb)
  2250     {
  2251       sdata *tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
  2252       sdata *to = tb->data;
  2253 
  2254       /* Step through the blocks from the oldest to the youngest.  We
  2255          expect that old blocks will stabilize over time, so that less
  2256          copying will happen this way.  */
  2257       struct sblock *b = tb;
  2258       do
  2259         {
  2260           sdata *end = b->next_free;
  2261           eassert ((char *) end <= (char *) b + SBLOCK_SIZE);
  2262 
  2263           for (sdata *from = b->data; from < end; )
  2264             {
  2265               /* Compute the next FROM here because copying below may
  2266                  overwrite data we need to compute it.  */
  2267               ptrdiff_t nbytes;
  2268               struct Lisp_String *s = from->string;
  2269 
  2270 #ifdef GC_CHECK_STRING_BYTES
  2271               /* Check that the string size recorded in the string is the
  2272                  same as the one recorded in the sdata structure.  */
  2273               if (s && string_bytes (s) != SDATA_NBYTES (from))
  2274                 emacs_abort ();
  2275 #endif /* GC_CHECK_STRING_BYTES */
  2276 
  2277               nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from);
  2278               eassert (nbytes <= LARGE_STRING_BYTES);
  2279 
  2280               ptrdiff_t size = sdata_size (nbytes);
  2281               sdata *from_end = (sdata *) ((char *) from
  2282                                            + size + GC_STRING_EXTRA);
  2283 
  2284 #ifdef GC_CHECK_STRING_OVERRUN
  2285               if (memcmp (string_overrun_cookie,
  2286                           (char *) from_end - GC_STRING_OVERRUN_COOKIE_SIZE,
  2287                           GC_STRING_OVERRUN_COOKIE_SIZE))
  2288                 emacs_abort ();
  2289 #endif
  2290 
  2291               /* Non-NULL S means it's alive.  Copy its data.  */
  2292               if (s)
  2293                 {
  2294                   /* If TB is full, proceed with the next sblock.  */
  2295                   sdata *to_end = (sdata *) ((char *) to
  2296                                              + size + GC_STRING_EXTRA);
  2297                   if (to_end > tb_end)
  2298                     {
  2299                       tb->next_free = to;
  2300                       tb = tb->next;
  2301                       tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
  2302                       to = tb->data;
  2303                       to_end = (sdata *) ((char *) to + size + GC_STRING_EXTRA);
  2304                     }
  2305 
  2306                   /* Copy, and update the string's `data' pointer.  */
  2307                   if (from != to)
  2308                     {
  2309                       eassert (tb != b || to < from);
  2310                       ASAN_PREPARE_LIVE_SDATA (to, nbytes);
  2311                       memmove (to, from, size + GC_STRING_EXTRA);
  2312                       to->string->u.s.data = SDATA_DATA (to);
  2313                     }
  2314 
  2315                   /* Advance past the sdata we copied to.  */
  2316                   to = to_end;
  2317                 }
  2318               from = from_end;
  2319             }
  2320           b = b->next;
  2321         }
  2322       while (b);
  2323 
  2324       /* The rest of the sblocks following TB don't contain live data, so
  2325          we can free them.  */
  2326       for (b = tb->next; b; )
  2327         {
  2328           struct sblock *next = b->next;
  2329           lisp_free (b);
  2330           b = next;
  2331         }
  2332 
  2333       tb->next_free = to;
  2334       tb->next = NULL;
  2335     }
  2336 
  2337   current_sblock = tb;
  2338 }
  2339 
  2340 void
  2341 string_overflow (void)
  2342 {
  2343   error ("Maximum string size exceeded");
  2344 }
  2345 
  2346 static Lisp_Object make_clear_string (EMACS_INT, bool);
  2347 static Lisp_Object make_clear_multibyte_string (EMACS_INT, EMACS_INT, bool);
  2348 
  2349 DEFUN ("make-string", Fmake_string, Smake_string, 2, 3, 0,
  2350        doc: /* Return a newly created string of length LENGTH, with INIT in each element.
  2351 LENGTH must be an integer.
  2352 INIT must be an integer that represents a character.
  2353 If optional argument MULTIBYTE is non-nil, the result will be
  2354 a multibyte string even if INIT is an ASCII character.  */)
  2355   (Lisp_Object length, Lisp_Object init, Lisp_Object multibyte)
  2356 {
  2357   Lisp_Object val;
  2358   EMACS_INT nbytes;
  2359 
  2360   CHECK_FIXNAT (length);
  2361   CHECK_CHARACTER (init);
  2362 
  2363   int c = XFIXNAT (init);
  2364   bool clearit = !c;
  2365 
  2366   if (ASCII_CHAR_P (c) && NILP (multibyte))
  2367     {
  2368       nbytes = XFIXNUM (length);
  2369       val = make_clear_string (nbytes, clearit);
  2370       if (nbytes && !clearit)
  2371         {
  2372           memset (SDATA (val), c, nbytes);
  2373           SDATA (val)[nbytes] = 0;
  2374         }
  2375     }
  2376   else
  2377     {
  2378       unsigned char str[MAX_MULTIBYTE_LENGTH];
  2379       ptrdiff_t len = CHAR_STRING (c, str);
  2380       EMACS_INT string_len = XFIXNUM (length);
  2381 
  2382       if (ckd_mul (&nbytes, len, string_len))
  2383         string_overflow ();
  2384       val = make_clear_multibyte_string (string_len, nbytes, clearit);
  2385       if (!clearit)
  2386         {
  2387           unsigned char *beg = SDATA (val), *end = beg + nbytes;
  2388           for (unsigned char *p = beg; p < end; p += len)
  2389             {
  2390               /* First time we just copy STR to the data of VAL.  */
  2391               if (p == beg)
  2392                 memcpy (p, str, len);
  2393               else
  2394                 {
  2395                   /* Next time we copy largest possible chunk from
  2396                      initialized to uninitialized part of VAL.  */
  2397                   len = min (p - beg, end - p);
  2398                   memcpy (p, beg, len);
  2399                 }
  2400             }
  2401         }
  2402     }
  2403 
  2404   return val;
  2405 }
  2406 
  2407 /* Fill A with 1 bits if INIT is non-nil, and with 0 bits otherwise.
  2408    Return A.  */
  2409 
  2410 Lisp_Object
  2411 bool_vector_fill (Lisp_Object a, Lisp_Object init)
  2412 {
  2413   EMACS_INT nbits = bool_vector_size (a);
  2414   if (0 < nbits)
  2415     {
  2416       unsigned char *data = bool_vector_uchar_data (a);
  2417       int pattern = NILP (init) ? 0 : (1 << BOOL_VECTOR_BITS_PER_CHAR) - 1;
  2418       ptrdiff_t nbytes = bool_vector_bytes (nbits);
  2419       int last_mask = ~ (~0u << ((nbits - 1) % BOOL_VECTOR_BITS_PER_CHAR + 1));
  2420       memset (data, pattern, nbytes - 1);
  2421       data[nbytes - 1] = pattern & last_mask;
  2422     }
  2423   return a;
  2424 }
  2425 
  2426 /* Return a newly allocated, uninitialized bool vector of size NBITS.  */
  2427 
  2428 Lisp_Object
  2429 make_uninit_bool_vector (EMACS_INT nbits)
  2430 {
  2431   Lisp_Object val;
  2432   EMACS_INT words = bool_vector_words (nbits);
  2433   EMACS_INT word_bytes = words * sizeof (bits_word);
  2434   EMACS_INT needed_elements = ((bool_header_size - header_size + word_bytes
  2435                                 + word_size - 1)
  2436                                / word_size);
  2437   if (PTRDIFF_MAX < needed_elements)
  2438     memory_full (SIZE_MAX);
  2439   struct Lisp_Bool_Vector *p
  2440     = (struct Lisp_Bool_Vector *) allocate_vector (needed_elements);
  2441   XSETVECTOR (val, p);
  2442   XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0, 0);
  2443   p->size = nbits;
  2444 
  2445   /* Clear padding at the end.  */
  2446   if (words)
  2447     p->data[words - 1] = 0;
  2448 
  2449   return val;
  2450 }
  2451 
  2452 DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
  2453        doc: /* Return a new bool-vector of length LENGTH, using INIT for each element.
  2454 LENGTH must be a number.  INIT matters only in whether it is t or nil.  */)
  2455   (Lisp_Object length, Lisp_Object init)
  2456 {
  2457   Lisp_Object val;
  2458 
  2459   CHECK_FIXNAT (length);
  2460   val = make_uninit_bool_vector (XFIXNAT (length));
  2461   return bool_vector_fill (val, init);
  2462 }
  2463 
  2464 DEFUN ("bool-vector", Fbool_vector, Sbool_vector, 0, MANY, 0,
  2465        doc: /* Return a new bool-vector with specified arguments as elements.
  2466 Allows any number of arguments, including zero.
  2467 usage: (bool-vector &rest OBJECTS)  */)
  2468   (ptrdiff_t nargs, Lisp_Object *args)
  2469 {
  2470   ptrdiff_t i;
  2471   Lisp_Object vector;
  2472 
  2473   vector = make_uninit_bool_vector (nargs);
  2474   for (i = 0; i < nargs; i++)
  2475     bool_vector_set (vector, i, !NILP (args[i]));
  2476 
  2477   return vector;
  2478 }
  2479 
  2480 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
  2481    of characters from the contents.  This string may be unibyte or
  2482    multibyte, depending on the contents.  */
  2483 
  2484 Lisp_Object
  2485 make_string (const char *contents, ptrdiff_t nbytes)
  2486 {
  2487   register Lisp_Object val;
  2488   ptrdiff_t nchars, multibyte_nbytes;
  2489 
  2490   parse_str_as_multibyte ((const unsigned char *) contents, nbytes,
  2491                           &nchars, &multibyte_nbytes);
  2492   if (nbytes == nchars || nbytes != multibyte_nbytes)
  2493     /* CONTENTS contains no multibyte sequences or contains an invalid
  2494        multibyte sequence.  We must make unibyte string.  */
  2495     val = make_unibyte_string (contents, nbytes);
  2496   else
  2497     val = make_multibyte_string (contents, nchars, nbytes);
  2498   return val;
  2499 }
  2500 
  2501 /* Make a unibyte string from LENGTH bytes at CONTENTS.  */
  2502 
  2503 Lisp_Object
  2504 make_unibyte_string (const char *contents, ptrdiff_t length)
  2505 {
  2506   register Lisp_Object val;
  2507   val = make_uninit_string (length);
  2508   memcpy (SDATA (val), contents, length);
  2509   return val;
  2510 }
  2511 
  2512 
  2513 /* Make a multibyte string from NCHARS characters occupying NBYTES
  2514    bytes at CONTENTS.  */
  2515 
  2516 Lisp_Object
  2517 make_multibyte_string (const char *contents,
  2518                        ptrdiff_t nchars, ptrdiff_t nbytes)
  2519 {
  2520   register Lisp_Object val;
  2521   val = make_uninit_multibyte_string (nchars, nbytes);
  2522   memcpy (SDATA (val), contents, nbytes);
  2523   return val;
  2524 }
  2525 
  2526 
  2527 /* Make a string from NCHARS characters occupying NBYTES bytes at
  2528    CONTENTS.  It is a multibyte string if NBYTES != NCHARS.  */
  2529 
  2530 Lisp_Object
  2531 make_string_from_bytes (const char *contents,
  2532                         ptrdiff_t nchars, ptrdiff_t nbytes)
  2533 {
  2534   register Lisp_Object val;
  2535   val = make_uninit_multibyte_string (nchars, nbytes);
  2536   memcpy (SDATA (val), contents, nbytes);
  2537   if (SBYTES (val) == SCHARS (val))
  2538     STRING_SET_UNIBYTE (val);
  2539   return val;
  2540 }
  2541 
  2542 
  2543 /* Make a string from NCHARS characters occupying NBYTES bytes at
  2544    CONTENTS.  The argument MULTIBYTE controls whether to label the
  2545    string as multibyte.  If NCHARS is negative, it counts the number of
  2546    characters by itself.  */
  2547 
  2548 Lisp_Object
  2549 make_specified_string (const char *contents,
  2550                        ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte)
  2551 {
  2552   Lisp_Object val;
  2553 
  2554   if (nchars < 0)
  2555     {
  2556       if (multibyte)
  2557         nchars = multibyte_chars_in_text ((const unsigned char *) contents,
  2558                                           nbytes);
  2559       else
  2560         nchars = nbytes;
  2561     }
  2562   val = make_uninit_multibyte_string (nchars, nbytes);
  2563   memcpy (SDATA (val), contents, nbytes);
  2564   if (!multibyte)
  2565     STRING_SET_UNIBYTE (val);
  2566   return val;
  2567 }
  2568 
  2569 
  2570 /* Return a unibyte Lisp_String set up to hold LENGTH characters
  2571    occupying LENGTH bytes.  If CLEARIT, clear its contents to null
  2572    bytes; otherwise, the contents are uninitialized.  */
  2573 
  2574 static Lisp_Object
  2575 make_clear_string (EMACS_INT length, bool clearit)
  2576 {
  2577   Lisp_Object val;
  2578 
  2579   if (!length)
  2580     return empty_unibyte_string;
  2581   val = make_clear_multibyte_string (length, length, clearit);
  2582   STRING_SET_UNIBYTE (val);
  2583   return val;
  2584 }
  2585 
  2586 /* Return a unibyte Lisp_String set up to hold LENGTH characters
  2587    occupying LENGTH bytes.  */
  2588 
  2589 Lisp_Object
  2590 make_uninit_string (EMACS_INT length)
  2591 {
  2592   return make_clear_string (length, false);
  2593 }
  2594 
  2595 
  2596 /* Return a multibyte Lisp_String set up to hold NCHARS characters
  2597    which occupy NBYTES bytes.  If CLEARIT, clear its contents to null
  2598    bytes; otherwise, the contents are uninitialized.  */
  2599 
  2600 static Lisp_Object
  2601 make_clear_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes, bool clearit)
  2602 {
  2603   Lisp_Object string;
  2604   struct Lisp_String *s;
  2605 
  2606   if (nchars < 0)
  2607     emacs_abort ();
  2608   if (!nbytes)
  2609     return empty_multibyte_string;
  2610 
  2611   s = allocate_string ();
  2612   s->u.s.intervals = NULL;
  2613   allocate_string_data (s, nchars, nbytes, clearit, false);
  2614   XSETSTRING (string, s);
  2615   string_chars_consed += nbytes;
  2616   return string;
  2617 }
  2618 
  2619 /* Return a multibyte Lisp_String set up to hold NCHARS characters
  2620    which occupy NBYTES bytes.  */
  2621 
  2622 Lisp_Object
  2623 make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes)
  2624 {
  2625   return make_clear_multibyte_string (nchars, nbytes, false);
  2626 }
  2627 
  2628 /* Print arguments to BUF according to a FORMAT, then return
  2629    a Lisp_String initialized with the data from BUF.  */
  2630 
  2631 Lisp_Object
  2632 make_formatted_string (char *buf, const char *format, ...)
  2633 {
  2634   va_list ap;
  2635   int length;
  2636 
  2637   va_start (ap, format);
  2638   length = vsprintf (buf, format, ap);
  2639   va_end (ap);
  2640   return make_string (buf, length);
  2641 }
  2642 
  2643 /* Pin a unibyte string in place so that it won't move during GC.  */
  2644 void
  2645 pin_string (Lisp_Object string)
  2646 {
  2647   eassert (STRINGP (string) && !STRING_MULTIBYTE (string));
  2648   struct Lisp_String *s = XSTRING (string);
  2649   ptrdiff_t size = STRING_BYTES (s);
  2650   unsigned char *data = s->u.s.data;
  2651 
  2652   if (!(size > LARGE_STRING_BYTES
  2653         || PURE_P (data) || pdumper_object_p (data)
  2654         || s->u.s.size_byte == -3))
  2655     {
  2656       eassert (s->u.s.size_byte == -1);
  2657       sdata *old_sdata = SDATA_OF_STRING (s);
  2658       allocate_string_data (s, size, size, false, true);
  2659       memcpy (s->u.s.data, data, size);
  2660       old_sdata->string = NULL;
  2661       SDATA_NBYTES (old_sdata) = size;
  2662       ASAN_PREPARE_DEAD_SDATA (old_sdata, size);
  2663     }
  2664   s->u.s.size_byte = -3;
  2665 }
  2666 
  2667 
  2668 /***********************************************************************
  2669                            Float Allocation
  2670  ***********************************************************************/
  2671 
  2672 /* We store float cells inside of float_blocks, allocating a new
  2673    float_block with malloc whenever necessary.  Float cells reclaimed
  2674    by GC are put on a free list to be reallocated before allocating
  2675    any new float cells from the latest float_block.  */
  2676 
  2677 #define FLOAT_BLOCK_SIZE                                        \
  2678   (((BLOCK_BYTES - sizeof (struct float_block *)                \
  2679      /* The compiler might add padding at the end.  */          \
  2680      - (sizeof (struct Lisp_Float) - sizeof (bits_word))) * CHAR_BIT) \
  2681    / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
  2682 
  2683 #define GETMARKBIT(block,n)                             \
  2684   (((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD]       \
  2685     >> ((n) % BITS_PER_BITS_WORD))                      \
  2686    & 1)
  2687 
  2688 #define SETMARKBIT(block,n)                             \
  2689   ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD]        \
  2690    |= (bits_word) 1 << ((n) % BITS_PER_BITS_WORD))
  2691 
  2692 #define UNSETMARKBIT(block,n)                           \
  2693   ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD]        \
  2694    &= ~((bits_word) 1 << ((n) % BITS_PER_BITS_WORD)))
  2695 
  2696 #define FLOAT_BLOCK(fptr) \
  2697   (eassert (!pdumper_object_p (fptr)),                                  \
  2698    ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1))))
  2699 
  2700 #define FLOAT_INDEX(fptr) \
  2701   ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
  2702 
  2703 struct float_block
  2704 {
  2705   /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job.  */
  2706   struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
  2707   bits_word gcmarkbits[1 + FLOAT_BLOCK_SIZE / BITS_PER_BITS_WORD];
  2708   struct float_block *next;
  2709 };
  2710 
  2711 #define XFLOAT_MARKED_P(fptr) \
  2712   GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
  2713 
  2714 #define XFLOAT_MARK(fptr) \
  2715   SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
  2716 
  2717 #define XFLOAT_UNMARK(fptr) \
  2718   UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
  2719 
  2720 #if GC_ASAN_POISON_OBJECTS
  2721 # define ASAN_POISON_FLOAT_BLOCK(fblk)         \
  2722   __asan_poison_memory_region ((fblk)->floats, \
  2723                                sizeof ((fblk)->floats))
  2724 # define ASAN_UNPOISON_FLOAT_BLOCK(fblk)         \
  2725   __asan_unpoison_memory_region ((fblk)->floats, \
  2726                                  sizeof ((fblk)->floats))
  2727 # define ASAN_POISON_FLOAT(p) \
  2728   __asan_poison_memory_region ((p), sizeof (struct Lisp_Float))
  2729 # define ASAN_UNPOISON_FLOAT(p) \
  2730   __asan_unpoison_memory_region ((p), sizeof (struct Lisp_Float))
  2731 #else
  2732 # define ASAN_POISON_FLOAT_BLOCK(fblk) ((void) 0)
  2733 # define ASAN_UNPOISON_FLOAT_BLOCK(fblk) ((void) 0)
  2734 # define ASAN_POISON_FLOAT(p) ((void) 0)
  2735 # define ASAN_UNPOISON_FLOAT(p) ((void) 0)
  2736 #endif
  2737 
  2738 /* Current float_block.  */
  2739 
  2740 static struct float_block *float_block;
  2741 
  2742 /* Index of first unused Lisp_Float in the current float_block.  */
  2743 
  2744 static int float_block_index = FLOAT_BLOCK_SIZE;
  2745 
  2746 /* Free-list of Lisp_Floats.  */
  2747 
  2748 static struct Lisp_Float *float_free_list;
  2749 
  2750 /* Return a new float object with value FLOAT_VALUE.  */
  2751 
  2752 Lisp_Object
  2753 make_float (double float_value)
  2754 {
  2755   register Lisp_Object val;
  2756 
  2757   MALLOC_BLOCK_INPUT;
  2758 
  2759   if (float_free_list)
  2760     {
  2761       XSETFLOAT (val, float_free_list);
  2762       ASAN_UNPOISON_FLOAT (float_free_list);
  2763       float_free_list = float_free_list->u.chain;
  2764     }
  2765   else
  2766     {
  2767       if (float_block_index == FLOAT_BLOCK_SIZE)
  2768         {
  2769           struct float_block *new
  2770             = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT);
  2771           new->next = float_block;
  2772           memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
  2773           ASAN_POISON_FLOAT_BLOCK (new);
  2774           float_block = new;
  2775           float_block_index = 0;
  2776         }
  2777       ASAN_UNPOISON_FLOAT (&float_block->floats[float_block_index]);
  2778       XSETFLOAT (val, &float_block->floats[float_block_index]);
  2779       float_block_index++;
  2780     }
  2781 
  2782   MALLOC_UNBLOCK_INPUT;
  2783 
  2784   XFLOAT_INIT (val, float_value);
  2785   eassert (!XFLOAT_MARKED_P (XFLOAT (val)));
  2786   tally_consing (sizeof (struct Lisp_Float));
  2787   floats_consed++;
  2788   return val;
  2789 }
  2790 
  2791 
  2792 
  2793 /***********************************************************************
  2794                            Cons Allocation
  2795  ***********************************************************************/
  2796 
  2797 /* We store cons cells inside of cons_blocks, allocating a new
  2798    cons_block with malloc whenever necessary.  Cons cells reclaimed by
  2799    GC are put on a free list to be reallocated before allocating
  2800    any new cons cells from the latest cons_block.  */
  2801 
  2802 #define CONS_BLOCK_SIZE                                         \
  2803   (((BLOCK_BYTES - sizeof (struct cons_block *)                 \
  2804      /* The compiler might add padding at the end.  */          \
  2805      - (sizeof (struct Lisp_Cons) - sizeof (bits_word))) * CHAR_BIT)    \
  2806    / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
  2807 
  2808 #define CONS_BLOCK(fptr) \
  2809   (eassert (!pdumper_object_p (fptr)),                                  \
  2810    ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1))))
  2811 
  2812 #define CONS_INDEX(fptr) \
  2813   (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
  2814 
  2815 struct cons_block
  2816 {
  2817   /* Place `conses' at the beginning, to ease up CONS_INDEX's job.  */
  2818   struct Lisp_Cons conses[CONS_BLOCK_SIZE];
  2819   bits_word gcmarkbits[1 + CONS_BLOCK_SIZE / BITS_PER_BITS_WORD];
  2820   struct cons_block *next;
  2821 };
  2822 
  2823 #define XCONS_MARKED_P(fptr) \
  2824   GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
  2825 
  2826 #define XMARK_CONS(fptr) \
  2827   SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
  2828 
  2829 #define XUNMARK_CONS(fptr) \
  2830   UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
  2831 
  2832 /* Minimum number of bytes of consing since GC before next GC,
  2833    when memory is full.  */
  2834 
  2835 enum { memory_full_cons_threshold = sizeof (struct cons_block) };
  2836 
  2837 /* Current cons_block.  */
  2838 
  2839 static struct cons_block *cons_block;
  2840 
  2841 /* Index of first unused Lisp_Cons in the current block.  */
  2842 
  2843 static int cons_block_index = CONS_BLOCK_SIZE;
  2844 
  2845 /* Free-list of Lisp_Cons structures.  */
  2846 
  2847 static struct Lisp_Cons *cons_free_list;
  2848 
  2849 #if GC_ASAN_POISON_OBJECTS
  2850 # define ASAN_POISON_CONS_BLOCK(b) \
  2851   __asan_poison_memory_region ((b)->conses, sizeof ((b)->conses))
  2852 # define ASAN_POISON_CONS(p) \
  2853   __asan_poison_memory_region ((p), sizeof (struct Lisp_Cons))
  2854 # define ASAN_UNPOISON_CONS(p) \
  2855   __asan_unpoison_memory_region ((p), sizeof (struct Lisp_Cons))
  2856 #else
  2857 # define ASAN_POISON_CONS_BLOCK(b) ((void) 0)
  2858 # define ASAN_POISON_CONS(p) ((void) 0)
  2859 # define ASAN_UNPOISON_CONS(p) ((void) 0)
  2860 #endif
  2861 
  2862 /* Explicitly free a cons cell by putting it on the free-list.  */
  2863 
  2864 void
  2865 free_cons (struct Lisp_Cons *ptr)
  2866 {
  2867   ptr->u.s.u.chain = cons_free_list;
  2868   ptr->u.s.car = dead_object ();
  2869   cons_free_list = ptr;
  2870   ptrdiff_t nbytes = sizeof *ptr;
  2871   tally_consing (-nbytes);
  2872   ASAN_POISON_CONS (ptr);
  2873 }
  2874 
  2875 DEFUN ("cons", Fcons, Scons, 2, 2, 0,
  2876        doc: /* Create a new cons, give it CAR and CDR as components, and return it.  */)
  2877   (Lisp_Object car, Lisp_Object cdr)
  2878 {
  2879   register Lisp_Object val;
  2880 
  2881   MALLOC_BLOCK_INPUT;
  2882 
  2883   if (cons_free_list)
  2884     {
  2885       ASAN_UNPOISON_CONS (cons_free_list);
  2886       XSETCONS (val, cons_free_list);
  2887       cons_free_list = cons_free_list->u.s.u.chain;
  2888     }
  2889   else
  2890     {
  2891       if (cons_block_index == CONS_BLOCK_SIZE)
  2892         {
  2893           struct cons_block *new
  2894             = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS);
  2895           memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
  2896           ASAN_POISON_CONS_BLOCK (new);
  2897           new->next = cons_block;
  2898           cons_block = new;
  2899           cons_block_index = 0;
  2900         }
  2901       ASAN_UNPOISON_CONS (&cons_block->conses[cons_block_index]);
  2902       XSETCONS (val, &cons_block->conses[cons_block_index]);
  2903       cons_block_index++;
  2904     }
  2905 
  2906   MALLOC_UNBLOCK_INPUT;
  2907 
  2908   XSETCAR (val, car);
  2909   XSETCDR (val, cdr);
  2910   eassert (!XCONS_MARKED_P (XCONS (val)));
  2911   consing_until_gc -= sizeof (struct Lisp_Cons);
  2912   cons_cells_consed++;
  2913   return val;
  2914 }
  2915 
  2916 /* Make a list of 1, 2, 3, 4 or 5 specified objects.  */
  2917 
  2918 Lisp_Object
  2919 list1 (Lisp_Object arg1)
  2920 {
  2921   return Fcons (arg1, Qnil);
  2922 }
  2923 
  2924 Lisp_Object
  2925 list2 (Lisp_Object arg1, Lisp_Object arg2)
  2926 {
  2927   return Fcons (arg1, Fcons (arg2, Qnil));
  2928 }
  2929 
  2930 
  2931 Lisp_Object
  2932 list3 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
  2933 {
  2934   return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
  2935 }
  2936 
  2937 Lisp_Object
  2938 list4 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4)
  2939 {
  2940   return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil))));
  2941 }
  2942 
  2943 Lisp_Object
  2944 list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4,
  2945        Lisp_Object arg5)
  2946 {
  2947   return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
  2948                                                        Fcons (arg5, Qnil)))));
  2949 }
  2950 
  2951 /* Make a list of COUNT Lisp_Objects, where ARG is the first one.
  2952    Use CONS to construct the pairs.  AP has any remaining args.  */
  2953 static Lisp_Object
  2954 cons_listn (ptrdiff_t count, Lisp_Object arg,
  2955             Lisp_Object (*cons) (Lisp_Object, Lisp_Object), va_list ap)
  2956 {
  2957   eassume (0 < count);
  2958   Lisp_Object val = cons (arg, Qnil);
  2959   Lisp_Object tail = val;
  2960   for (ptrdiff_t i = 1; i < count; i++)
  2961     {
  2962       Lisp_Object elem = cons (va_arg (ap, Lisp_Object), Qnil);
  2963       XSETCDR (tail, elem);
  2964       tail = elem;
  2965     }
  2966   return val;
  2967 }
  2968 
  2969 /* Make a list of COUNT Lisp_Objects, where ARG1 is the first one.  */
  2970 Lisp_Object
  2971 listn (ptrdiff_t count, Lisp_Object arg1, ...)
  2972 {
  2973   va_list ap;
  2974   va_start (ap, arg1);
  2975   Lisp_Object val = cons_listn (count, arg1, Fcons, ap);
  2976   va_end (ap);
  2977   return val;
  2978 }
  2979 
  2980 /* Make a pure list of COUNT Lisp_Objects, where ARG1 is the first one.  */
  2981 Lisp_Object
  2982 pure_listn (ptrdiff_t count, Lisp_Object arg1, ...)
  2983 {
  2984   va_list ap;
  2985   va_start (ap, arg1);
  2986   Lisp_Object val = cons_listn (count, arg1, pure_cons, ap);
  2987   va_end (ap);
  2988   return val;
  2989 }
  2990 
  2991 DEFUN ("list", Flist, Slist, 0, MANY, 0,
  2992        doc: /* Return a newly created list with specified arguments as elements.
  2993 Allows any number of arguments, including zero.
  2994 usage: (list &rest OBJECTS)  */)
  2995   (ptrdiff_t nargs, Lisp_Object *args)
  2996 {
  2997   register Lisp_Object val;
  2998   val = Qnil;
  2999 
  3000   while (nargs > 0)
  3001     {
  3002       nargs--;
  3003       val = Fcons (args[nargs], val);
  3004     }
  3005   return val;
  3006 }
  3007 
  3008 
  3009 DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
  3010        doc: /* Return a newly created list of length LENGTH, with each element being INIT.  */)
  3011   (Lisp_Object length, Lisp_Object init)
  3012 {
  3013   Lisp_Object val = Qnil;
  3014   CHECK_FIXNAT (length);
  3015 
  3016   for (EMACS_INT size = XFIXNAT (length); 0 < size; size--)
  3017     {
  3018       val = Fcons (init, val);
  3019       rarely_quit (size);
  3020     }
  3021 
  3022   return val;
  3023 }
  3024 
  3025 
  3026 
  3027 /***********************************************************************
  3028                            Vector Allocation
  3029  ***********************************************************************/
  3030 
  3031 /* Sometimes a vector's contents are merely a pointer internally used
  3032    in vector allocation code.  On the rare platforms where a null
  3033    pointer cannot be tagged, represent it with a Lisp 0.
  3034    Usually you don't want to touch this.  */
  3035 
  3036 static struct Lisp_Vector *
  3037 next_vector (struct Lisp_Vector *v)
  3038 {
  3039   return XUNTAG (v->contents[0], Lisp_Int0, struct Lisp_Vector);
  3040 }
  3041 
  3042 static void
  3043 set_next_vector (struct Lisp_Vector *v, struct Lisp_Vector *p)
  3044 {
  3045   v->contents[0] = make_lisp_ptr (p, Lisp_Int0);
  3046 }
  3047 
  3048 /* This value is balanced well enough to avoid too much internal overhead
  3049    for the most common cases; it's not required to be a power of two, but
  3050    it's expected to be a mult-of-ROUNDUP_SIZE (see below).  */
  3051 
  3052 enum { VECTOR_BLOCK_SIZE = 4096 };
  3053 
  3054 /* Vector size requests are a multiple of this.  */
  3055 enum { roundup_size = COMMON_MULTIPLE (LISP_ALIGNMENT, word_size) };
  3056 
  3057 /* Verify assumptions described above.  */
  3058 verify (VECTOR_BLOCK_SIZE % roundup_size == 0);
  3059 verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS));
  3060 
  3061 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time.  */
  3062 #define vroundup_ct(x) ROUNDUP (x, roundup_size)
  3063 /* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at runtime.  */
  3064 #define vroundup(x) (eassume ((x) >= 0), vroundup_ct (x))
  3065 
  3066 /* Rounding helps to maintain alignment constraints if USE_LSB_TAG.  */
  3067 
  3068 enum {VECTOR_BLOCK_BYTES = VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *))};
  3069 
  3070 /* Size of the minimal vector allocated from block.  */
  3071 
  3072 enum { VBLOCK_BYTES_MIN = vroundup_ct (header_size + sizeof (Lisp_Object)) };
  3073 
  3074 /* Size of the largest vector allocated from block.  */
  3075 
  3076 enum { VBLOCK_BYTES_MAX = vroundup_ct ((VECTOR_BLOCK_BYTES / 2) - word_size) };
  3077 
  3078 /* We maintain one free list for each possible block-allocated
  3079    vector size, and this is the number of free lists we have.  */
  3080 
  3081 enum { VECTOR_MAX_FREE_LIST_INDEX =
  3082        (VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1 };
  3083 
  3084 /* Common shortcut to advance vector pointer over a block data.  */
  3085 
  3086 static struct Lisp_Vector *
  3087 ADVANCE (struct Lisp_Vector *v, ptrdiff_t nbytes)
  3088 {
  3089   void *vv = v;
  3090   char *cv = vv;
  3091   void *p = cv + nbytes;
  3092   return p;
  3093 }
  3094 
  3095 /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS.  */
  3096 
  3097 static ptrdiff_t
  3098 VINDEX (ptrdiff_t nbytes)
  3099 {
  3100   eassume (VBLOCK_BYTES_MIN <= nbytes);
  3101   return (nbytes - VBLOCK_BYTES_MIN) / roundup_size;
  3102 }
  3103 
  3104 /* This internal type is used to maintain the list of large vectors
  3105    which are allocated at their own, e.g. outside of vector blocks.
  3106 
  3107    struct large_vector itself cannot contain a struct Lisp_Vector, as
  3108    the latter contains a flexible array member and C99 does not allow
  3109    such structs to be nested.  Instead, each struct large_vector
  3110    object LV is followed by a struct Lisp_Vector, which is at offset
  3111    large_vector_offset from LV, and whose address is therefore
  3112    large_vector_vec (&LV).  */
  3113 
  3114 struct large_vector
  3115 {
  3116   struct large_vector *next;
  3117 };
  3118 
  3119 enum
  3120 {
  3121   large_vector_offset = ROUNDUP (sizeof (struct large_vector), LISP_ALIGNMENT)
  3122 };
  3123 
  3124 static struct Lisp_Vector *
  3125 large_vector_vec (struct large_vector *p)
  3126 {
  3127   return (struct Lisp_Vector *) ((char *) p + large_vector_offset);
  3128 }
  3129 
  3130 /* This internal type is used to maintain an underlying storage
  3131    for small vectors.  */
  3132 
  3133 struct vector_block
  3134 {
  3135   char data[VECTOR_BLOCK_BYTES];
  3136   struct vector_block *next;
  3137 };
  3138 
  3139 /* Chain of vector blocks.  */
  3140 
  3141 static struct vector_block *vector_blocks;
  3142 
  3143 /* Vector free lists, where NTH item points to a chain of free
  3144    vectors of the same NBYTES size, so NTH == VINDEX (NBYTES).  */
  3145 
  3146 static struct Lisp_Vector *vector_free_lists[VECTOR_MAX_FREE_LIST_INDEX];
  3147 
  3148 /* Singly-linked list of large vectors.  */
  3149 
  3150 static struct large_vector *large_vectors;
  3151 
  3152 /* The only vector with 0 slots, allocated from pure space.  */
  3153 
  3154 Lisp_Object zero_vector;
  3155 
  3156 #if GC_ASAN_POISON_OBJECTS
  3157 # define ASAN_POISON_VECTOR_CONTENTS(v, bytes) \
  3158   __asan_poison_memory_region ((v)->contents, (bytes))
  3159 # define ASAN_UNPOISON_VECTOR_CONTENTS(v, bytes) \
  3160   __asan_unpoison_memory_region ((v)->contents, (bytes))
  3161 # define ASAN_UNPOISON_VECTOR_BLOCK(b) \
  3162   __asan_unpoison_memory_region ((b)->data, sizeof ((b)->data))
  3163 #else
  3164 # define ASAN_POISON_VECTOR_CONTENTS(v, bytes) ((void) 0)
  3165 # define ASAN_UNPOISON_VECTOR_CONTENTS(v, bytes) ((void) 0)
  3166 # define ASAN_UNPOISON_VECTOR_BLOCK(b) ((void) 0)
  3167 #endif
  3168 
  3169 /* Common shortcut to setup vector on a free list.  */
  3170 
  3171 static void
  3172 setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes)
  3173 {
  3174   eassume (header_size <= nbytes);
  3175   ptrdiff_t nwords = (nbytes - header_size) / word_size;
  3176   XSETPVECTYPESIZE (v, PVEC_FREE, 0, nwords);
  3177   eassert (nbytes % roundup_size == 0);
  3178   ptrdiff_t vindex = VINDEX (nbytes);
  3179   eassert (vindex < VECTOR_MAX_FREE_LIST_INDEX);
  3180   set_next_vector (v, vector_free_lists[vindex]);
  3181   ASAN_POISON_VECTOR_CONTENTS (v, nbytes - header_size);
  3182   vector_free_lists[vindex] = v;
  3183 }
  3184 
  3185 /* Get a new vector block.  */
  3186 
  3187 static struct vector_block *
  3188 allocate_vector_block (void)
  3189 {
  3190   struct vector_block *block = xmalloc (sizeof *block);
  3191 
  3192 #ifndef GC_MALLOC_CHECK
  3193   mem_insert (block->data, block->data + VECTOR_BLOCK_BYTES,
  3194               MEM_TYPE_VECTOR_BLOCK);
  3195 #endif
  3196 
  3197   block->next = vector_blocks;
  3198   vector_blocks = block;
  3199   return block;
  3200 }
  3201 
  3202 /* Called once to initialize vector allocation.  */
  3203 
  3204 static void
  3205 init_vectors (void)
  3206 {
  3207   zero_vector = make_pure_vector (0);
  3208   staticpro (&zero_vector);
  3209 }
  3210 
  3211 /* Allocate vector from a vector block.  */
  3212 
  3213 static struct Lisp_Vector *
  3214 allocate_vector_from_block (ptrdiff_t nbytes)
  3215 {
  3216   struct Lisp_Vector *vector;
  3217   struct vector_block *block;
  3218   size_t index, restbytes;
  3219 
  3220   eassume (VBLOCK_BYTES_MIN <= nbytes && nbytes <= VBLOCK_BYTES_MAX);
  3221   eassume (nbytes % roundup_size == 0);
  3222 
  3223   /* First, try to allocate from a free list
  3224      containing vectors of the requested size.  */
  3225   index = VINDEX (nbytes);
  3226   if (vector_free_lists[index])
  3227     {
  3228       vector = vector_free_lists[index];
  3229       ASAN_UNPOISON_VECTOR_CONTENTS (vector, nbytes - header_size);
  3230       vector_free_lists[index] = next_vector (vector);
  3231       return vector;
  3232     }
  3233 
  3234   /* Next, check free lists containing larger vectors.  Since
  3235      we will split the result, we should have remaining space
  3236      large enough to use for one-slot vector at least.  */
  3237   for (index = VINDEX (nbytes + VBLOCK_BYTES_MIN);
  3238        index < VECTOR_MAX_FREE_LIST_INDEX; index++)
  3239     if (vector_free_lists[index])
  3240       {
  3241         /* This vector is larger than requested.  */
  3242         vector = vector_free_lists[index];
  3243         ASAN_UNPOISON_VECTOR_CONTENTS (vector, nbytes - header_size);
  3244         vector_free_lists[index] = next_vector (vector);
  3245 
  3246         /* Excess bytes are used for the smaller vector,
  3247            which should be set on an appropriate free list.  */
  3248         restbytes = index * roundup_size + VBLOCK_BYTES_MIN - nbytes;
  3249         eassert (restbytes % roundup_size == 0);
  3250 #if GC_ASAN_POISON_OBJECTS
  3251         /* Ensure that accessing excess bytes does not trigger ASan.  */
  3252         __asan_unpoison_memory_region (ADVANCE (vector, nbytes),
  3253                                        restbytes);
  3254 #endif
  3255         setup_on_free_list (ADVANCE (vector, nbytes), restbytes);
  3256         return vector;
  3257       }
  3258 
  3259   /* Finally, need a new vector block.  */
  3260   block = allocate_vector_block ();
  3261 
  3262   /* New vector will be at the beginning of this block.  */
  3263   vector = (struct Lisp_Vector *) block->data;
  3264 
  3265   /* If the rest of space from this block is large enough
  3266      for one-slot vector at least, set up it on a free list.  */
  3267   restbytes = VECTOR_BLOCK_BYTES - nbytes;
  3268   if (restbytes >= VBLOCK_BYTES_MIN)
  3269     {
  3270       eassert (restbytes % roundup_size == 0);
  3271       setup_on_free_list (ADVANCE (vector, nbytes), restbytes);
  3272     }
  3273   return vector;
  3274 }
  3275 
  3276 /* Nonzero if VECTOR pointer is valid pointer inside BLOCK.  */
  3277 
  3278 #define VECTOR_IN_BLOCK(vector, block)          \
  3279   ((char *) (vector) <= (block)->data           \
  3280    + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
  3281 
  3282 /* Return the memory footprint of V in bytes.  */
  3283 
  3284 ptrdiff_t
  3285 vectorlike_nbytes (const union vectorlike_header *hdr)
  3286 {
  3287   ptrdiff_t size = hdr->size & ~ARRAY_MARK_FLAG;
  3288   ptrdiff_t nwords;
  3289 
  3290   if (size & PSEUDOVECTOR_FLAG)
  3291     {
  3292       if (PSEUDOVECTOR_TYPEP (hdr, PVEC_BOOL_VECTOR))
  3293         {
  3294           struct Lisp_Bool_Vector *bv = (struct Lisp_Bool_Vector *) hdr;
  3295           ptrdiff_t word_bytes = (bool_vector_words (bv->size)
  3296                                   * sizeof (bits_word));
  3297           ptrdiff_t boolvec_bytes = bool_header_size + word_bytes;
  3298           verify (header_size <= bool_header_size);
  3299           nwords = (boolvec_bytes - header_size + word_size - 1) / word_size;
  3300         }
  3301       else
  3302         nwords = ((size & PSEUDOVECTOR_SIZE_MASK)
  3303                   + ((size & PSEUDOVECTOR_REST_MASK)
  3304                      >> PSEUDOVECTOR_SIZE_BITS));
  3305     }
  3306   else
  3307     nwords = size;
  3308   return vroundup (header_size + word_size * nwords);
  3309 }
  3310 
  3311 /* Convert a pseudovector pointer P to its underlying struct T pointer.
  3312    Verify that the struct is small, since cleanup_vector is called
  3313    only on small vector-like objects.  */
  3314 
  3315 #define PSEUDOVEC_STRUCT(p, t) \
  3316   verify_expr ((header_size + VECSIZE (struct t) * word_size \
  3317                 <= VBLOCK_BYTES_MAX), \
  3318                (struct t *) (p))
  3319 
  3320 /* Release extra resources still in use by VECTOR, which may be any
  3321    small vector-like object.  */
  3322 
  3323 static void
  3324 cleanup_vector (struct Lisp_Vector *vector)
  3325 {
  3326   detect_suspicious_free (vector);
  3327 
  3328   if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_BIGNUM))
  3329     mpz_clear (PSEUDOVEC_STRUCT (vector, Lisp_Bignum)->value);
  3330   else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_OVERLAY))
  3331     {
  3332       struct Lisp_Overlay *ol = PSEUDOVEC_STRUCT (vector, Lisp_Overlay);
  3333       xfree (ol->interval);
  3334     }
  3335   else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FINALIZER))
  3336     unchain_finalizer (PSEUDOVEC_STRUCT (vector, Lisp_Finalizer));
  3337   else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FONT))
  3338     {
  3339       if ((vector->header.size & PSEUDOVECTOR_SIZE_MASK) == FONT_OBJECT_MAX)
  3340         {
  3341           struct font *font = PSEUDOVEC_STRUCT (vector, font);
  3342           struct font_driver const *drv = font->driver;
  3343 
  3344           /* The font driver might sometimes be NULL, e.g. if Emacs was
  3345              interrupted before it had time to set it up.  */
  3346           if (drv)
  3347             {
  3348               /* Attempt to catch subtle bugs like Bug#16140.  */
  3349               eassert (valid_font_driver (drv));
  3350               drv->close_font (font);
  3351             }
  3352         }
  3353 
  3354 #if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
  3355       /* The Android font driver needs the ability to associate extra
  3356          information with font entities.  */
  3357       if (((vector->header.size & PSEUDOVECTOR_SIZE_MASK)
  3358            == FONT_ENTITY_MAX)
  3359           && PSEUDOVEC_STRUCT (vector, font_entity)->is_android)
  3360         android_finalize_font_entity (PSEUDOVEC_STRUCT (vector, font_entity));
  3361 #endif
  3362     }
  3363   else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD))
  3364     finalize_one_thread (PSEUDOVEC_STRUCT (vector, thread_state));
  3365   else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX))
  3366     finalize_one_mutex (PSEUDOVEC_STRUCT (vector, Lisp_Mutex));
  3367   else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR))
  3368     finalize_one_condvar (PSEUDOVEC_STRUCT (vector, Lisp_CondVar));
  3369   else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MARKER))
  3370     {
  3371       /* sweep_buffer should already have unchained this from its buffer.  */
  3372       eassert (! PSEUDOVEC_STRUCT (vector, Lisp_Marker)->buffer);
  3373     }
  3374   else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_USER_PTR))
  3375     {
  3376       struct Lisp_User_Ptr *uptr = PSEUDOVEC_STRUCT (vector, Lisp_User_Ptr);
  3377       if (uptr->finalizer)
  3378         uptr->finalizer (uptr->p);
  3379     }
  3380 #ifdef HAVE_TREE_SITTER
  3381   else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_TS_PARSER))
  3382     treesit_delete_parser (PSEUDOVEC_STRUCT (vector, Lisp_TS_Parser));
  3383   else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_TS_COMPILED_QUERY))
  3384     treesit_delete_query (PSEUDOVEC_STRUCT (vector, Lisp_TS_Query));
  3385 #endif
  3386 #ifdef HAVE_MODULES
  3387   else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MODULE_FUNCTION))
  3388     {
  3389       ATTRIBUTE_MAY_ALIAS struct Lisp_Module_Function *function
  3390         = (struct Lisp_Module_Function *) vector;
  3391       module_finalize_function (function);
  3392     }
  3393 #endif
  3394 #ifdef HAVE_NATIVE_COMP
  3395   else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_NATIVE_COMP_UNIT))
  3396     {
  3397       struct Lisp_Native_Comp_Unit *cu =
  3398         PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit);
  3399       unload_comp_unit (cu);
  3400     }
  3401   else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_SUBR))
  3402     {
  3403       struct Lisp_Subr *subr =
  3404         PSEUDOVEC_STRUCT (vector, Lisp_Subr);
  3405       if (!NILP (subr->native_comp_u))
  3406         {
  3407           /* FIXME Alternative and non invasive solution to this
  3408              cast?  */
  3409           xfree ((char *)subr->symbol_name);
  3410           xfree (subr->native_c_name);
  3411         }
  3412     }
  3413 #endif
  3414 }
  3415 
  3416 /* Reclaim space used by unmarked vectors.  */
  3417 
  3418 NO_INLINE /* For better stack traces */
  3419 static void
  3420 sweep_vectors (void)
  3421 {
  3422   struct vector_block *block, **bprev = &vector_blocks;
  3423   struct large_vector *lv, **lvprev = &large_vectors;
  3424   struct Lisp_Vector *vector, *next;
  3425 
  3426   gcstat.total_vectors = 0;
  3427   gcstat.total_vector_slots = gcstat.total_free_vector_slots = 0;
  3428   memset (vector_free_lists, 0, sizeof (vector_free_lists));
  3429 
  3430   /* Looking through vector blocks.  */
  3431 
  3432   for (block = vector_blocks; block; block = *bprev)
  3433     {
  3434       bool free_this_block = false;
  3435 
  3436       for (vector = (struct Lisp_Vector *) block->data;
  3437            VECTOR_IN_BLOCK (vector, block); vector = next)
  3438         {
  3439           ASAN_UNPOISON_VECTOR_BLOCK (block);
  3440           if (XVECTOR_MARKED_P (vector))
  3441             {
  3442               XUNMARK_VECTOR (vector);
  3443               gcstat.total_vectors++;
  3444               ptrdiff_t nbytes = vector_nbytes (vector);
  3445               gcstat.total_vector_slots += nbytes / word_size;
  3446               next = ADVANCE (vector, nbytes);
  3447             }
  3448           else
  3449             {
  3450               ptrdiff_t total_bytes = 0;
  3451 
  3452               /* While NEXT is not marked, try to coalesce with VECTOR,
  3453                  thus making VECTOR of the largest possible size.  */
  3454 
  3455               next = vector;
  3456               do
  3457                 {
  3458                   cleanup_vector (next);
  3459                   ptrdiff_t nbytes = vector_nbytes (next);
  3460                   total_bytes += nbytes;
  3461                   next = ADVANCE (next, nbytes);
  3462                 }
  3463               while (VECTOR_IN_BLOCK (next, block) && !vector_marked_p (next));
  3464 
  3465               eassert (total_bytes % roundup_size == 0);
  3466 
  3467               if (vector == (struct Lisp_Vector *) block->data
  3468                   && !VECTOR_IN_BLOCK (next, block))
  3469                 /* This block should be freed because all of its
  3470                    space was coalesced into the only free vector.  */
  3471                 free_this_block = true;
  3472               else
  3473                 {
  3474                   setup_on_free_list (vector, total_bytes);
  3475                   gcstat.total_free_vector_slots += total_bytes / word_size;
  3476                 }
  3477             }
  3478         }
  3479 
  3480       if (free_this_block)
  3481         {
  3482           *bprev = block->next;
  3483 #ifndef GC_MALLOC_CHECK
  3484           mem_delete (mem_find (block->data));
  3485 #endif
  3486           xfree (block);
  3487         }
  3488       else
  3489         bprev = &block->next;
  3490     }
  3491 
  3492   /* Sweep large vectors.  */
  3493 
  3494   for (lv = large_vectors; lv; lv = *lvprev)
  3495     {
  3496       vector = large_vector_vec (lv);
  3497       if (XVECTOR_MARKED_P (vector))
  3498         {
  3499           XUNMARK_VECTOR (vector);
  3500           gcstat.total_vectors++;
  3501           gcstat.total_vector_slots
  3502             += (vector->header.size & PSEUDOVECTOR_FLAG
  3503                 ? vector_nbytes (vector) / word_size
  3504                 : header_size / word_size + vector->header.size);
  3505           lvprev = &lv->next;
  3506         }
  3507       else
  3508         {
  3509           *lvprev = lv->next;
  3510           lisp_free (lv);
  3511         }
  3512     }
  3513 }
  3514 
  3515 /* Maximum number of elements in a vector.  This is a macro so that it
  3516    can be used in an integer constant expression.  */
  3517 
  3518 #define VECTOR_ELTS_MAX \
  3519   ((ptrdiff_t) \
  3520    min (((min (PTRDIFF_MAX, SIZE_MAX) - header_size - large_vector_offset) \
  3521          / word_size), \
  3522         MOST_POSITIVE_FIXNUM))
  3523 
  3524 /* Value is a pointer to a newly allocated Lisp_Vector structure
  3525    with room for LEN Lisp_Objects.  LEN must be positive and
  3526    at most VECTOR_ELTS_MAX.  */
  3527 
  3528 static struct Lisp_Vector *
  3529 allocate_vectorlike (ptrdiff_t len, bool clearit)
  3530 {
  3531   eassert (0 < len && len <= VECTOR_ELTS_MAX);
  3532   ptrdiff_t nbytes = header_size + len * word_size;
  3533   struct Lisp_Vector *p;
  3534 
  3535   MALLOC_BLOCK_INPUT;
  3536 
  3537 #ifdef DOUG_LEA_MALLOC
  3538   if (!mmap_lisp_allowed_p ())
  3539     mallopt (M_MMAP_MAX, 0);
  3540 #endif
  3541 
  3542   if (nbytes <= VBLOCK_BYTES_MAX)
  3543     {
  3544       p = allocate_vector_from_block (vroundup (nbytes));
  3545       if (clearit)
  3546         memclear (p, nbytes);
  3547     }
  3548   else
  3549     {
  3550       struct large_vector *lv = lisp_malloc (large_vector_offset + nbytes,
  3551                                              clearit, MEM_TYPE_VECTORLIKE);
  3552       lv->next = large_vectors;
  3553       large_vectors = lv;
  3554       p = large_vector_vec (lv);
  3555     }
  3556 
  3557 #ifdef DOUG_LEA_MALLOC
  3558   if (!mmap_lisp_allowed_p ())
  3559     mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
  3560 #endif
  3561 
  3562   if (find_suspicious_object_in_range (p, (char *) p + nbytes))
  3563     emacs_abort ();
  3564 
  3565   tally_consing (nbytes);
  3566   vector_cells_consed += len;
  3567 
  3568   MALLOC_UNBLOCK_INPUT;
  3569 
  3570   return p;
  3571 }
  3572 
  3573 
  3574 /* Allocate a vector with LEN slots.  If CLEARIT, clear its slots;
  3575    otherwise the vector's slots are uninitialized.  */
  3576 
  3577 static struct Lisp_Vector *
  3578 allocate_clear_vector (ptrdiff_t len, bool clearit)
  3579 {
  3580   if (len == 0)
  3581     return XVECTOR (zero_vector);
  3582   if (VECTOR_ELTS_MAX < len)
  3583     memory_full (SIZE_MAX);
  3584   struct Lisp_Vector *v = allocate_vectorlike (len, clearit);
  3585   v->header.size = len;
  3586   return v;
  3587 }
  3588 
  3589 /* Allocate a vector with LEN uninitialized slots.  */
  3590 
  3591 struct Lisp_Vector *
  3592 allocate_vector (ptrdiff_t len)
  3593 {
  3594   return allocate_clear_vector (len, false);
  3595 }
  3596 
  3597 /* Allocate a vector with LEN nil slots.  */
  3598 
  3599 struct Lisp_Vector *
  3600 allocate_nil_vector (ptrdiff_t len)
  3601 {
  3602   return allocate_clear_vector (len, true);
  3603 }
  3604 
  3605 
  3606 /* Allocate other vector-like structures.  */
  3607 
  3608 struct Lisp_Vector *
  3609 allocate_pseudovector (int memlen, int lisplen,
  3610                        int zerolen, enum pvec_type tag)
  3611 {
  3612   /* Catch bogus values.  */
  3613   enum { size_max = (1 << PSEUDOVECTOR_SIZE_BITS) - 1 };
  3614   enum { rest_max = (1 << PSEUDOVECTOR_REST_BITS) - 1 };
  3615   verify (size_max + rest_max <= VECTOR_ELTS_MAX);
  3616   eassert (0 <= tag && tag <= PVEC_FONT);
  3617   eassert (0 <= lisplen && lisplen <= zerolen && zerolen <= memlen);
  3618   eassert (lisplen <= size_max);
  3619   eassert (memlen <= size_max + rest_max);
  3620 
  3621   struct Lisp_Vector *v = allocate_vectorlike (memlen, false);
  3622   /* Only the first LISPLEN slots will be traced normally by the GC.  */
  3623   memclear (v->contents, zerolen * word_size);
  3624   XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen);
  3625   return v;
  3626 }
  3627 
  3628 struct buffer *
  3629 allocate_buffer (void)
  3630 {
  3631   struct buffer *b
  3632     = ALLOCATE_PSEUDOVECTOR (struct buffer, cursor_in_non_selected_windows_,
  3633                              PVEC_BUFFER);
  3634   BUFFER_PVEC_INIT (b);
  3635   /* Note that the rest fields of B are not initialized.  */
  3636   return b;
  3637 }
  3638 
  3639 
  3640 /* Allocate a record with COUNT slots.  COUNT must be positive, and
  3641    includes the type slot.  */
  3642 
  3643 static struct Lisp_Vector *
  3644 allocate_record (EMACS_INT count)
  3645 {
  3646   if (count > PSEUDOVECTOR_SIZE_MASK)
  3647     error ("Attempt to allocate a record of %"pI"d slots; max is %d",
  3648            count, PSEUDOVECTOR_SIZE_MASK);
  3649   struct Lisp_Vector *p = allocate_vectorlike (count, false);
  3650   p->header.size = count;
  3651   XSETPVECTYPE (p, PVEC_RECORD);
  3652   return p;
  3653 }
  3654 
  3655 
  3656 DEFUN ("make-record", Fmake_record, Smake_record, 3, 3, 0,
  3657        doc: /* Create a new record.
  3658 TYPE is its type as returned by `type-of'; it should be either a
  3659 symbol or a type descriptor.  SLOTS is the number of non-type slots,
  3660 each initialized to INIT.  */)
  3661   (Lisp_Object type, Lisp_Object slots, Lisp_Object init)
  3662 {
  3663   CHECK_FIXNAT (slots);
  3664   EMACS_INT size = XFIXNAT (slots) + 1;
  3665   struct Lisp_Vector *p = allocate_record (size);
  3666   p->contents[0] = type;
  3667   for (ptrdiff_t i = 1; i < size; i++)
  3668     p->contents[i] = init;
  3669   return make_lisp_ptr (p, Lisp_Vectorlike);
  3670 }
  3671 
  3672 
  3673 DEFUN ("record", Frecord, Srecord, 1, MANY, 0,
  3674        doc: /* Create a new record.
  3675 TYPE is its type as returned by `type-of'; it should be either a
  3676 symbol or a type descriptor.  SLOTS is used to initialize the record
  3677 slots with shallow copies of the arguments.
  3678 usage: (record TYPE &rest SLOTS) */)
  3679   (ptrdiff_t nargs, Lisp_Object *args)
  3680 {
  3681   struct Lisp_Vector *p = allocate_record (nargs);
  3682   memcpy (p->contents, args, nargs * sizeof *args);
  3683   return make_lisp_ptr (p, Lisp_Vectorlike);
  3684 }
  3685 
  3686 
  3687 DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
  3688        doc: /* Return a newly created vector of length LENGTH, with each element being INIT.
  3689 See also the function `vector'.  */)
  3690   (Lisp_Object length, Lisp_Object init)
  3691 {
  3692   CHECK_TYPE (FIXNATP (length) && XFIXNAT (length) <= PTRDIFF_MAX,
  3693               Qwholenump, length);
  3694   return make_vector (XFIXNAT (length), init);
  3695 }
  3696 
  3697 /* Return a new vector of length LENGTH with each element being INIT.  */
  3698 
  3699 Lisp_Object
  3700 make_vector (ptrdiff_t length, Lisp_Object init)
  3701 {
  3702   bool clearit = NIL_IS_ZERO && NILP (init);
  3703   struct Lisp_Vector *p = allocate_clear_vector (length, clearit);
  3704   if (!clearit)
  3705     for (ptrdiff_t i = 0; i < length; i++)
  3706       p->contents[i] = init;
  3707   return make_lisp_ptr (p, Lisp_Vectorlike);
  3708 }
  3709 
  3710 DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
  3711        doc: /* Return a newly created vector with specified arguments as elements.
  3712 Allows any number of arguments, including zero.
  3713 usage: (vector &rest OBJECTS)  */)
  3714   (ptrdiff_t nargs, Lisp_Object *args)
  3715 {
  3716   Lisp_Object val = make_uninit_vector (nargs);
  3717   struct Lisp_Vector *p = XVECTOR (val);
  3718   memcpy (p->contents, args, nargs * sizeof *args);
  3719   return val;
  3720 }
  3721 
  3722 DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
  3723        doc: /* Create a byte-code object with specified arguments as elements.
  3724 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
  3725 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
  3726 and (optional) INTERACTIVE-SPEC.
  3727 The first four arguments are required; at most six have any
  3728 significance.
  3729 The ARGLIST can be either like the one of `lambda', in which case the arguments
  3730 will be dynamically bound before executing the byte code, or it can be an
  3731 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
  3732 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
  3733 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
  3734 argument to catch the left-over arguments.  If such an integer is used, the
  3735 arguments will not be dynamically bound but will be instead pushed on the
  3736 stack before executing the byte-code.
  3737 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS)  */)
  3738   (ptrdiff_t nargs, Lisp_Object *args)
  3739 {
  3740   if (! ((FIXNUMP (args[COMPILED_ARGLIST])
  3741           || CONSP (args[COMPILED_ARGLIST])
  3742           || NILP (args[COMPILED_ARGLIST]))
  3743          && STRINGP (args[COMPILED_BYTECODE])
  3744          && !STRING_MULTIBYTE (args[COMPILED_BYTECODE])
  3745          && VECTORP (args[COMPILED_CONSTANTS])
  3746          && FIXNATP (args[COMPILED_STACK_DEPTH])))
  3747     error ("Invalid byte-code object");
  3748 
  3749   /* Bytecode must be immovable.  */
  3750   pin_string (args[COMPILED_BYTECODE]);
  3751 
  3752   /* We used to purecopy everything here, if purify-flag was set.  This worked
  3753      OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
  3754      dangerous, since make-byte-code is used during execution to build
  3755      closures, so any closure built during the preload phase would end up
  3756      copied into pure space, including its free variables, which is sometimes
  3757      just wasteful and other times plainly wrong (e.g. those free vars may want
  3758      to be setcar'd).  */
  3759   Lisp_Object val = Fvector (nargs, args);
  3760   XSETPVECTYPE (XVECTOR (val), PVEC_COMPILED);
  3761   return val;
  3762 }
  3763 
  3764 DEFUN ("make-closure", Fmake_closure, Smake_closure, 1, MANY, 0,
  3765        doc: /* Create a byte-code closure from PROTOTYPE and CLOSURE-VARS.
  3766 Return a copy of PROTOTYPE, a byte-code object, with CLOSURE-VARS
  3767 replacing the elements in the beginning of the constant-vector.
  3768 usage: (make-closure PROTOTYPE &rest CLOSURE-VARS) */)
  3769   (ptrdiff_t nargs, Lisp_Object *args)
  3770 {
  3771   Lisp_Object protofun = args[0];
  3772   CHECK_TYPE (COMPILEDP (protofun), Qbyte_code_function_p, protofun);
  3773 
  3774   /* Create a copy of the constant vector, filling it with the closure
  3775      variables in the beginning.  (The overwritten part should just
  3776      contain placeholder values.) */
  3777   Lisp_Object proto_constvec = AREF (protofun, COMPILED_CONSTANTS);
  3778   ptrdiff_t constsize = ASIZE (proto_constvec);
  3779   ptrdiff_t nvars = nargs - 1;
  3780   if (nvars > constsize)
  3781     error ("Closure vars do not fit in constvec");
  3782   Lisp_Object constvec = make_uninit_vector (constsize);
  3783   memcpy (XVECTOR (constvec)->contents, args + 1, nvars * word_size);
  3784   memcpy (XVECTOR (constvec)->contents + nvars,
  3785           XVECTOR (proto_constvec)->contents + nvars,
  3786           (constsize - nvars) * word_size);
  3787 
  3788   /* Return a copy of the prototype function with the new constant vector. */
  3789   ptrdiff_t protosize = PVSIZE (protofun);
  3790   struct Lisp_Vector *v = allocate_vectorlike (protosize, false);
  3791   v->header = XVECTOR (protofun)->header;
  3792   memcpy (v->contents, XVECTOR (protofun)->contents, protosize * word_size);
  3793   v->contents[COMPILED_CONSTANTS] = constvec;
  3794   return make_lisp_ptr (v, Lisp_Vectorlike);
  3795 }
  3796 
  3797 
  3798 /***********************************************************************
  3799                            Symbol Allocation
  3800  ***********************************************************************/
  3801 
  3802 /* Each symbol_block is just under 1020 bytes long, since malloc
  3803    really allocates in units of powers of two and uses 4 bytes for its
  3804    own overhead.  */
  3805 
  3806 #define SYMBOL_BLOCK_SIZE \
  3807   ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
  3808 
  3809 struct symbol_block
  3810 {
  3811   /* Place `symbols' first, to preserve alignment.  */
  3812   struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
  3813   struct symbol_block *next;
  3814 };
  3815 
  3816 #if GC_ASAN_POISON_OBJECTS
  3817 # define ASAN_POISON_SYMBOL_BLOCK(s) \
  3818   __asan_poison_memory_region ((s)->symbols, sizeof ((s)->symbols))
  3819 # define ASAN_UNPOISON_SYMBOL_BLOCK(s) \
  3820   __asan_unpoison_memory_region ((s)->symbols, sizeof ((s)->symbols))
  3821 # define ASAN_POISON_SYMBOL(sym) \
  3822   __asan_poison_memory_region ((sym), sizeof (*(sym)))
  3823 # define ASAN_UNPOISON_SYMBOL(sym) \
  3824   __asan_unpoison_memory_region ((sym), sizeof (*(sym)))
  3825 
  3826 #else
  3827 # define ASAN_POISON_SYMBOL_BLOCK(s) ((void) 0)
  3828 # define ASAN_UNPOISON_SYMBOL_BLOCK(s) ((void) 0)
  3829 # define ASAN_POISON_SYMBOL(sym) ((void) 0)
  3830 # define ASAN_UNPOISON_SYMBOL(sym) ((void) 0)
  3831 #endif
  3832 
  3833 /* Current symbol block and index of first unused Lisp_Symbol
  3834    structure in it.  */
  3835 
  3836 static struct symbol_block *symbol_block;
  3837 static int symbol_block_index = SYMBOL_BLOCK_SIZE;
  3838 /* Pointer to the first symbol_block that contains pinned symbols.
  3839    Tests for 24.4 showed that at dump-time, Emacs contains about 15K symbols,
  3840    10K of which are pinned (and all but 250 of them are interned in obarray),
  3841    whereas a "typical session" has in the order of 30K symbols.
  3842    `symbol_block_pinned' lets mark_pinned_symbols scan only 15K symbols rather
  3843    than 30K to find the 10K symbols we need to mark.  */
  3844 static struct symbol_block *symbol_block_pinned;
  3845 
  3846 /* List of free symbols.  */
  3847 
  3848 static struct Lisp_Symbol *symbol_free_list;
  3849 
  3850 static void
  3851 set_symbol_name (Lisp_Object sym, Lisp_Object name)
  3852 {
  3853   XBARE_SYMBOL (sym)->u.s.name = name;
  3854 }
  3855 
  3856 void
  3857 init_symbol (Lisp_Object val, Lisp_Object name)
  3858 {
  3859   struct Lisp_Symbol *p = XBARE_SYMBOL (val);
  3860   set_symbol_name (val, name);
  3861   set_symbol_plist (val, Qnil);
  3862   p->u.s.redirect = SYMBOL_PLAINVAL;
  3863   SET_SYMBOL_VAL (p, Qunbound);
  3864   set_symbol_function (val, Qnil);
  3865   set_symbol_next (val, NULL);
  3866   p->u.s.gcmarkbit = false;
  3867   p->u.s.interned = SYMBOL_UNINTERNED;
  3868   p->u.s.trapped_write = SYMBOL_UNTRAPPED_WRITE;
  3869   p->u.s.declared_special = false;
  3870   p->u.s.pinned = false;
  3871 }
  3872 
  3873 DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
  3874        doc: /* Return a newly allocated uninterned symbol whose name is NAME.
  3875 Its value is void, and its function definition and property list are nil.  */)
  3876   (Lisp_Object name)
  3877 {
  3878   Lisp_Object val;
  3879 
  3880   CHECK_STRING (name);
  3881 
  3882   MALLOC_BLOCK_INPUT;
  3883 
  3884   if (symbol_free_list)
  3885     {
  3886       ASAN_UNPOISON_SYMBOL (symbol_free_list);
  3887       XSETSYMBOL (val, symbol_free_list);
  3888       symbol_free_list = symbol_free_list->u.s.next;
  3889     }
  3890   else
  3891     {
  3892       if (symbol_block_index == SYMBOL_BLOCK_SIZE)
  3893         {
  3894           struct symbol_block *new
  3895             = lisp_malloc (sizeof *new, false, MEM_TYPE_SYMBOL);
  3896           ASAN_POISON_SYMBOL_BLOCK (new);
  3897           new->next = symbol_block;
  3898           symbol_block = new;
  3899           symbol_block_index = 0;
  3900         }
  3901 
  3902       ASAN_UNPOISON_SYMBOL (&symbol_block->symbols[symbol_block_index]);
  3903       XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]);
  3904       symbol_block_index++;
  3905     }
  3906 
  3907   MALLOC_UNBLOCK_INPUT;
  3908 
  3909   init_symbol (val, name);
  3910   tally_consing (sizeof (struct Lisp_Symbol));
  3911   symbols_consed++;
  3912   return val;
  3913 }
  3914 
  3915 
  3916 
  3917 Lisp_Object
  3918 make_misc_ptr (void *a)
  3919 {
  3920   struct Lisp_Misc_Ptr *p = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Misc_Ptr,
  3921                                                          PVEC_MISC_PTR);
  3922   p->pointer = a;
  3923   return make_lisp_ptr (p, Lisp_Vectorlike);
  3924 }
  3925 
  3926 /* Return a new symbol with position with the specified SYMBOL and POSITION. */
  3927 Lisp_Object
  3928 build_symbol_with_pos (Lisp_Object symbol, Lisp_Object position)
  3929 {
  3930   Lisp_Object val;
  3931   struct Lisp_Symbol_With_Pos *p
  3932     = (struct Lisp_Symbol_With_Pos *) allocate_vector (2);
  3933   XSETVECTOR (val, p);
  3934   XSETPVECTYPESIZE (XVECTOR (val), PVEC_SYMBOL_WITH_POS, 2, 0);
  3935   p->sym = symbol;
  3936   p->pos = position;
  3937 
  3938   return val;
  3939 }
  3940 
  3941 /* Return a new (deleted) overlay with PLIST.  */
  3942 
  3943 Lisp_Object
  3944 build_overlay (bool front_advance, bool rear_advance,
  3945                Lisp_Object plist)
  3946 {
  3947   struct Lisp_Overlay *p = ALLOCATE_PSEUDOVECTOR (struct Lisp_Overlay, plist,
  3948                                                   PVEC_OVERLAY);
  3949   Lisp_Object overlay = make_lisp_ptr (p, Lisp_Vectorlike);
  3950   struct itree_node *node = xmalloc (sizeof (*node));
  3951   itree_node_init (node, front_advance, rear_advance, overlay);
  3952   p->interval = node;
  3953   p->buffer = NULL;
  3954   set_overlay_plist (overlay, plist);
  3955   return overlay;
  3956 }
  3957 
  3958 DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
  3959        doc: /* Return a newly allocated marker which does not point at any place.  */)
  3960   (void)
  3961 {
  3962   struct Lisp_Marker *p = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Marker,
  3963                                                        PVEC_MARKER);
  3964   p->buffer = 0;
  3965   p->bytepos = 0;
  3966   p->charpos = 0;
  3967   p->next = NULL;
  3968   p->insertion_type = 0;
  3969   p->need_adjustment = 0;
  3970   return make_lisp_ptr (p, Lisp_Vectorlike);
  3971 }
  3972 
  3973 /* Return a newly allocated marker which points into BUF
  3974    at character position CHARPOS and byte position BYTEPOS.  */
  3975 
  3976 Lisp_Object
  3977 build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos)
  3978 {
  3979   /* No dead buffers here.  */
  3980   eassert (BUFFER_LIVE_P (buf));
  3981 
  3982   /* Every character is at least one byte.  */
  3983   eassert (charpos <= bytepos);
  3984 
  3985   struct Lisp_Marker *m = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Marker,
  3986                                                        PVEC_MARKER);
  3987   m->buffer = buf;
  3988   m->charpos = charpos;
  3989   m->bytepos = bytepos;
  3990   m->insertion_type = 0;
  3991   m->need_adjustment = 0;
  3992   m->next = BUF_MARKERS (buf);
  3993   BUF_MARKERS (buf) = m;
  3994   return make_lisp_ptr (m, Lisp_Vectorlike);
  3995 }
  3996 
  3997 
  3998 /* Return a newly created vector or string with specified arguments as
  3999    elements.  If all the arguments are characters that can fit
  4000    in a string of events, make a string; otherwise, make a vector.
  4001 
  4002    Allows any number of arguments, including zero.  */
  4003 
  4004 Lisp_Object
  4005 make_event_array (ptrdiff_t nargs, Lisp_Object *args)
  4006 {
  4007   ptrdiff_t i;
  4008 
  4009   for (i = 0; i < nargs; i++)
  4010     /* The things that fit in a string
  4011        are characters that are in 0...127,
  4012        after discarding the meta bit and all the bits above it.  */
  4013     if (!FIXNUMP (args[i])
  4014         || (XFIXNUM (args[i]) & ~(-CHAR_META)) >= 0200)
  4015       return Fvector (nargs, args);
  4016 
  4017   /* Since the loop exited, we know that all the things in it are
  4018      characters, so we can make a string.  */
  4019   {
  4020     Lisp_Object result;
  4021 
  4022     result = Fmake_string (make_fixnum (nargs), make_fixnum (0), Qnil);
  4023     for (i = 0; i < nargs; i++)
  4024       {
  4025         SSET (result, i, XFIXNUM (args[i]));
  4026         /* Move the meta bit to the right place for a string char.  */
  4027         if (XFIXNUM (args[i]) & CHAR_META)
  4028           SSET (result, i, SREF (result, i) | 0x80);
  4029       }
  4030 
  4031     return result;
  4032   }
  4033 }
  4034 
  4035 #ifdef HAVE_MODULES
  4036 /* Create a new module user ptr object.  */
  4037 Lisp_Object
  4038 make_user_ptr (void (*finalizer) (void *), void *p)
  4039 {
  4040   struct Lisp_User_Ptr *uptr
  4041     = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_User_Ptr, PVEC_USER_PTR);
  4042   uptr->finalizer = finalizer;
  4043   uptr->p = p;
  4044   return make_lisp_ptr (uptr, Lisp_Vectorlike);
  4045 }
  4046 #endif
  4047 
  4048 static void
  4049 init_finalizer_list (struct Lisp_Finalizer *head)
  4050 {
  4051   head->prev = head->next = head;
  4052 }
  4053 
  4054 /* Insert FINALIZER before ELEMENT.  */
  4055 
  4056 static void
  4057 finalizer_insert (struct Lisp_Finalizer *element,
  4058                   struct Lisp_Finalizer *finalizer)
  4059 {
  4060   eassert (finalizer->prev == NULL);
  4061   eassert (finalizer->next == NULL);
  4062   finalizer->next = element;
  4063   finalizer->prev = element->prev;
  4064   finalizer->prev->next = finalizer;
  4065   element->prev = finalizer;
  4066 }
  4067 
  4068 static void
  4069 unchain_finalizer (struct Lisp_Finalizer *finalizer)
  4070 {
  4071   if (finalizer->prev != NULL)
  4072     {
  4073       eassert (finalizer->next != NULL);
  4074       finalizer->prev->next = finalizer->next;
  4075       finalizer->next->prev = finalizer->prev;
  4076       finalizer->prev = finalizer->next = NULL;
  4077     }
  4078 }
  4079 
  4080 static void
  4081 mark_finalizer_list (struct Lisp_Finalizer *head)
  4082 {
  4083   for (struct Lisp_Finalizer *finalizer = head->next;
  4084        finalizer != head;
  4085        finalizer = finalizer->next)
  4086     {
  4087       set_vectorlike_marked (&finalizer->header);
  4088       mark_object (finalizer->function);
  4089     }
  4090 }
  4091 
  4092 /* Move doomed finalizers to list DEST from list SRC.  A doomed
  4093    finalizer is one that is not GC-reachable and whose
  4094    finalizer->function is non-nil.  */
  4095 
  4096 static void
  4097 queue_doomed_finalizers (struct Lisp_Finalizer *dest,
  4098                          struct Lisp_Finalizer *src)
  4099 {
  4100   struct Lisp_Finalizer *finalizer = src->next;
  4101   while (finalizer != src)
  4102     {
  4103       struct Lisp_Finalizer *next = finalizer->next;
  4104       if (!vectorlike_marked_p (&finalizer->header)
  4105           && !NILP (finalizer->function))
  4106         {
  4107           unchain_finalizer (finalizer);
  4108           finalizer_insert (dest, finalizer);
  4109         }
  4110 
  4111       finalizer = next;
  4112     }
  4113 }
  4114 
  4115 static Lisp_Object
  4116 run_finalizer_handler (Lisp_Object args)
  4117 {
  4118   add_to_log ("finalizer failed: %S", args);
  4119   return Qnil;
  4120 }
  4121 
  4122 static void
  4123 run_finalizer_function (Lisp_Object function)
  4124 {
  4125   specpdl_ref count = SPECPDL_INDEX ();
  4126 #ifdef HAVE_PDUMPER
  4127   ++number_finalizers_run;
  4128 #endif
  4129 
  4130   specbind (Qinhibit_quit, Qt);
  4131   internal_condition_case_1 (call0, function, Qt, run_finalizer_handler);
  4132   unbind_to (count, Qnil);
  4133 }
  4134 
  4135 static void
  4136 run_finalizers (struct Lisp_Finalizer *finalizers)
  4137 {
  4138   struct Lisp_Finalizer *finalizer;
  4139   Lisp_Object function;
  4140 
  4141   while (finalizers->next != finalizers)
  4142     {
  4143       finalizer = finalizers->next;
  4144       unchain_finalizer (finalizer);
  4145       function = finalizer->function;
  4146       if (!NILP (function))
  4147         {
  4148           finalizer->function = Qnil;
  4149           run_finalizer_function (function);
  4150         }
  4151     }
  4152 }
  4153 
  4154 DEFUN ("make-finalizer", Fmake_finalizer, Smake_finalizer, 1, 1, 0,
  4155        doc: /* Make a finalizer that will run FUNCTION.
  4156 FUNCTION will be called after garbage collection when the returned
  4157 finalizer object becomes unreachable.  If the finalizer object is
  4158 reachable only through references from finalizer objects, it does not
  4159 count as reachable for the purpose of deciding whether to run
  4160 FUNCTION.  FUNCTION will be run once per finalizer object.  */)
  4161   (Lisp_Object function)
  4162 {
  4163   CHECK_TYPE (FUNCTIONP (function), Qfunctionp, function);
  4164   struct Lisp_Finalizer *finalizer
  4165     = ALLOCATE_PSEUDOVECTOR (struct Lisp_Finalizer, function, PVEC_FINALIZER);
  4166   finalizer->function = function;
  4167   finalizer->prev = finalizer->next = NULL;
  4168   finalizer_insert (&finalizers, finalizer);
  4169   return make_lisp_ptr (finalizer, Lisp_Vectorlike);
  4170 }
  4171 
  4172 
  4173 /************************************************************************
  4174                          Mark bit access functions
  4175  ************************************************************************/
  4176 
  4177 /* With the rare exception of functions implementing block-based
  4178    allocation of various types, you should not directly test or set GC
  4179    mark bits on objects.  Some objects might live in special memory
  4180    regions (e.g., a dump image) and might store their mark bits
  4181    elsewhere.  */
  4182 
  4183 static bool
  4184 vector_marked_p (const struct Lisp_Vector *v)
  4185 {
  4186   if (pdumper_object_p (v))
  4187     {
  4188       /* Look at cold_start first so that we don't have to fault in
  4189          the vector header just to tell that it's a bool vector.  */
  4190       if (pdumper_cold_object_p (v))
  4191         {
  4192           eassert (PSEUDOVECTOR_TYPE (v) == PVEC_BOOL_VECTOR);
  4193           return true;
  4194         }
  4195       return pdumper_marked_p (v);
  4196     }
  4197   return XVECTOR_MARKED_P (v);
  4198 }
  4199 
  4200 static void
  4201 set_vector_marked (struct Lisp_Vector *v)
  4202 {
  4203   if (pdumper_object_p (v))
  4204     {
  4205       eassert (PSEUDOVECTOR_TYPE (v) != PVEC_BOOL_VECTOR);
  4206       pdumper_set_marked (v);
  4207     }
  4208   else
  4209     XMARK_VECTOR (v);
  4210 }
  4211 
  4212 static bool
  4213 vectorlike_marked_p (const union vectorlike_header *header)
  4214 {
  4215   return vector_marked_p ((const struct Lisp_Vector *) header);
  4216 }
  4217 
  4218 static void
  4219 set_vectorlike_marked (union vectorlike_header *header)
  4220 {
  4221   set_vector_marked ((struct Lisp_Vector *) header);
  4222 }
  4223 
  4224 static bool
  4225 cons_marked_p (const struct Lisp_Cons *c)
  4226 {
  4227   return pdumper_object_p (c)
  4228     ? pdumper_marked_p (c)
  4229     : XCONS_MARKED_P (c);
  4230 }
  4231 
  4232 static void
  4233 set_cons_marked (struct Lisp_Cons *c)
  4234 {
  4235   if (pdumper_object_p (c))
  4236     pdumper_set_marked (c);
  4237   else
  4238     XMARK_CONS (c);
  4239 }
  4240 
  4241 static bool
  4242 string_marked_p (const struct Lisp_String *s)
  4243 {
  4244   return pdumper_object_p (s)
  4245     ? pdumper_marked_p (s)
  4246     : XSTRING_MARKED_P (s);
  4247 }
  4248 
  4249 static void
  4250 set_string_marked (struct Lisp_String *s)
  4251 {
  4252   if (pdumper_object_p (s))
  4253     pdumper_set_marked (s);
  4254   else
  4255     XMARK_STRING (s);
  4256 }
  4257 
  4258 static bool
  4259 symbol_marked_p (const struct Lisp_Symbol *s)
  4260 {
  4261   return pdumper_object_p (s)
  4262     ? pdumper_marked_p (s)
  4263     : s->u.s.gcmarkbit;
  4264 }
  4265 
  4266 static void
  4267 set_symbol_marked (struct Lisp_Symbol *s)
  4268 {
  4269   if (pdumper_object_p (s))
  4270     pdumper_set_marked (s);
  4271   else
  4272     s->u.s.gcmarkbit = true;
  4273 }
  4274 
  4275 static bool
  4276 interval_marked_p (INTERVAL i)
  4277 {
  4278   return pdumper_object_p (i)
  4279     ? pdumper_marked_p (i)
  4280     : i->gcmarkbit;
  4281 }
  4282 
  4283 static void
  4284 set_interval_marked (INTERVAL i)
  4285 {
  4286   if (pdumper_object_p (i))
  4287     pdumper_set_marked (i);
  4288   else
  4289     i->gcmarkbit = true;
  4290 }
  4291 
  4292 
  4293 /************************************************************************
  4294                            Memory Full Handling
  4295  ************************************************************************/
  4296 
  4297 
  4298 /* Called if malloc (NBYTES) returns zero.  If NBYTES == SIZE_MAX,
  4299    there may have been size_t overflow so that malloc was never
  4300    called, or perhaps malloc was invoked successfully but the
  4301    resulting pointer had problems fitting into a tagged EMACS_INT.  In
  4302    either case this counts as memory being full even though malloc did
  4303    not fail.  */
  4304 
  4305 void
  4306 memory_full (size_t nbytes)
  4307 {
  4308   if (!initialized)
  4309     fatal ("memory exhausted");
  4310 
  4311   /* Do not go into hysterics merely because a large request failed.  */
  4312   bool enough_free_memory = false;
  4313   if (SPARE_MEMORY < nbytes)
  4314     {
  4315       void *p;
  4316 
  4317       MALLOC_BLOCK_INPUT;
  4318       p = malloc (SPARE_MEMORY);
  4319       if (p)
  4320         {
  4321           free (p);
  4322           enough_free_memory = true;
  4323         }
  4324       MALLOC_UNBLOCK_INPUT;
  4325     }
  4326 
  4327   if (! enough_free_memory)
  4328     {
  4329       Vmemory_full = Qt;
  4330       consing_until_gc = min (consing_until_gc, memory_full_cons_threshold);
  4331 
  4332       /* The first time we get here, free the spare memory.  */
  4333       for (int i = 0; i < ARRAYELTS (spare_memory); i++)
  4334         if (spare_memory[i])
  4335           {
  4336             if (i == 0)
  4337               free (spare_memory[i]);
  4338             else if (i >= 1 && i <= 4)
  4339               lisp_align_free (spare_memory[i]);
  4340             else
  4341               lisp_free (spare_memory[i]);
  4342             spare_memory[i] = 0;
  4343           }
  4344     }
  4345 
  4346   /* This used to call error, but if we've run out of memory, we could
  4347      get infinite recursion trying to build the string.  */
  4348   xsignal (Qnil, Vmemory_signal_data);
  4349 }
  4350 
  4351 /* If we released our reserve (due to running out of memory),
  4352    and we have a fair amount free once again,
  4353    try to set aside another reserve in case we run out once more.
  4354 
  4355    This is called when a relocatable block is freed in ralloc.c,
  4356    and also directly from this file, in case we're not using ralloc.c.  */
  4357 
  4358 void
  4359 refill_memory_reserve (void)
  4360 {
  4361 #if !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC
  4362   if (spare_memory[0] == 0)
  4363     spare_memory[0] = malloc (SPARE_MEMORY);
  4364   if (spare_memory[1] == 0)
  4365     spare_memory[1] = lisp_align_malloc (sizeof (struct cons_block),
  4366                                                   MEM_TYPE_SPARE);
  4367   if (spare_memory[2] == 0)
  4368     spare_memory[2] = lisp_align_malloc (sizeof (struct cons_block),
  4369                                          MEM_TYPE_SPARE);
  4370   if (spare_memory[3] == 0)
  4371     spare_memory[3] = lisp_align_malloc (sizeof (struct cons_block),
  4372                                          MEM_TYPE_SPARE);
  4373   if (spare_memory[4] == 0)
  4374     spare_memory[4] = lisp_align_malloc (sizeof (struct cons_block),
  4375                                          MEM_TYPE_SPARE);
  4376   if (spare_memory[5] == 0)
  4377     spare_memory[5] = lisp_malloc (sizeof (struct string_block),
  4378                                    false, MEM_TYPE_SPARE);
  4379   if (spare_memory[6] == 0)
  4380     spare_memory[6] = lisp_malloc (sizeof (struct string_block),
  4381                                    false, MEM_TYPE_SPARE);
  4382   if (spare_memory[0] && spare_memory[1] && spare_memory[5])
  4383     Vmemory_full = Qnil;
  4384 #endif
  4385 }
  4386 
  4387 /************************************************************************
  4388                            C Stack Marking
  4389  ************************************************************************/
  4390 
  4391 /* Conservative C stack marking requires a method to identify possibly
  4392    live Lisp objects given a pointer value.  We do this by keeping
  4393    track of blocks of Lisp data that are allocated in a red-black tree
  4394    (see also the comment of mem_node which is the type of nodes in
  4395    that tree).  Function lisp_malloc adds information for an allocated
  4396    block to the red-black tree with calls to mem_insert, and function
  4397    lisp_free removes it with mem_delete.  Functions live_string_p etc
  4398    call mem_find to lookup information about a given pointer in the
  4399    tree, and use that to determine if the pointer points into a Lisp
  4400    object or not.  */
  4401 
  4402 /* Initialize this part of alloc.c.  */
  4403 
  4404 static void
  4405 mem_init (void)
  4406 {
  4407   mem_z.left = mem_z.right = MEM_NIL;
  4408   mem_z.parent = NULL;
  4409   mem_z.color = MEM_BLACK;
  4410   mem_z.start = mem_z.end = NULL;
  4411   mem_root = MEM_NIL;
  4412 }
  4413 
  4414 
  4415 /* Value is a pointer to the mem_node containing START.  Value is
  4416    MEM_NIL if there is no node in the tree containing START.  */
  4417 
  4418 static struct mem_node *
  4419 mem_find (void *start)
  4420 {
  4421   struct mem_node *p;
  4422 
  4423   if (start < min_heap_address || start > max_heap_address)
  4424     return MEM_NIL;
  4425 
  4426   /* Make the search always successful to speed up the loop below.  */
  4427   mem_z.start = start;
  4428   mem_z.end = (char *) start + 1;
  4429 
  4430   p = mem_root;
  4431   while (start < p->start || start >= p->end)
  4432     p = start < p->start ? p->left : p->right;
  4433   return p;
  4434 }
  4435 
  4436 
  4437 /* Insert a new node into the tree for a block of memory with start
  4438    address START, end address END, and type TYPE.  Value is a
  4439    pointer to the node that was inserted.  */
  4440 
  4441 static struct mem_node *
  4442 mem_insert (void *start, void *end, enum mem_type type)
  4443 {
  4444   struct mem_node *c, *parent, *x;
  4445 
  4446   if (min_heap_address == NULL || start < min_heap_address)
  4447     min_heap_address = start;
  4448   if (max_heap_address == NULL || end > max_heap_address)
  4449     max_heap_address = end;
  4450 
  4451   /* See where in the tree a node for START belongs.  In this
  4452      particular application, it shouldn't happen that a node is already
  4453      present.  For debugging purposes, let's check that.  */
  4454   c = mem_root;
  4455   parent = NULL;
  4456 
  4457   while (c != MEM_NIL)
  4458     {
  4459       parent = c;
  4460       c = start < c->start ? c->left : c->right;
  4461     }
  4462 
  4463   /* Create a new node.  */
  4464 #ifdef GC_MALLOC_CHECK
  4465   x = malloc (sizeof *x);
  4466   if (x == NULL)
  4467     emacs_abort ();
  4468 #else
  4469   x = xmalloc (sizeof *x);
  4470 #endif
  4471   x->start = start;
  4472   x->end = end;
  4473   x->type = type;
  4474   x->parent = parent;
  4475   x->left = x->right = MEM_NIL;
  4476   x->color = MEM_RED;
  4477 
  4478   /* Insert it as child of PARENT or install it as root.  */
  4479   if (parent)
  4480     {
  4481       if (start < parent->start)
  4482         parent->left = x;
  4483       else
  4484         parent->right = x;
  4485     }
  4486   else
  4487     mem_root = x;
  4488 
  4489   /* Re-establish red-black tree properties.  */
  4490   mem_insert_fixup (x);
  4491 
  4492   return x;
  4493 }
  4494 
  4495 
  4496 /* Re-establish the red-black properties of the tree, and thereby
  4497    balance the tree, after node X has been inserted; X is always red.  */
  4498 
  4499 static void
  4500 mem_insert_fixup (struct mem_node *x)
  4501 {
  4502   while (x != mem_root && x->parent->color == MEM_RED)
  4503     {
  4504       /* X is red and its parent is red.  This is a violation of
  4505          red-black tree property #3.  */
  4506 
  4507       if (x->parent == x->parent->parent->left)
  4508         {
  4509           /* We're on the left side of our grandparent, and Y is our
  4510              "uncle".  */
  4511           struct mem_node *y = x->parent->parent->right;
  4512 
  4513           if (y->color == MEM_RED)
  4514             {
  4515               /* Uncle and parent are red but should be black because
  4516                  X is red.  Change the colors accordingly and proceed
  4517                  with the grandparent.  */
  4518               x->parent->color = MEM_BLACK;
  4519               y->color = MEM_BLACK;
  4520               x->parent->parent->color = MEM_RED;
  4521               x = x->parent->parent;
  4522             }
  4523           else
  4524             {
  4525               /* Parent and uncle have different colors; parent is
  4526                  red, uncle is black.  */
  4527               if (x == x->parent->right)
  4528                 {
  4529                   x = x->parent;
  4530                   mem_rotate_left (x);
  4531                 }
  4532 
  4533               x->parent->color = MEM_BLACK;
  4534               x->parent->parent->color = MEM_RED;
  4535               mem_rotate_right (x->parent->parent);
  4536             }
  4537         }
  4538       else
  4539         {
  4540           /* This is the symmetrical case of above.  */
  4541           struct mem_node *y = x->parent->parent->left;
  4542 
  4543           if (y->color == MEM_RED)
  4544             {
  4545               x->parent->color = MEM_BLACK;
  4546               y->color = MEM_BLACK;
  4547               x->parent->parent->color = MEM_RED;
  4548               x = x->parent->parent;
  4549             }
  4550           else
  4551             {
  4552               if (x == x->parent->left)
  4553                 {
  4554                   x = x->parent;
  4555                   mem_rotate_right (x);
  4556                 }
  4557 
  4558               x->parent->color = MEM_BLACK;
  4559               x->parent->parent->color = MEM_RED;
  4560               mem_rotate_left (x->parent->parent);
  4561             }
  4562         }
  4563     }
  4564 
  4565   /* The root may have been changed to red due to the algorithm.  Set
  4566      it to black so that property #5 is satisfied.  */
  4567   mem_root->color = MEM_BLACK;
  4568 }
  4569 
  4570 
  4571 /*   (x)                   (y)
  4572      / \                   / \
  4573     a   (y)      ===>    (x)  c
  4574         / \              / \
  4575        b   c            a   b  */
  4576 
  4577 static void
  4578 mem_rotate_left (struct mem_node *x)
  4579 {
  4580   struct mem_node *y;
  4581 
  4582   /* Turn y's left sub-tree into x's right sub-tree.  */
  4583   y = x->right;
  4584   x->right = y->left;
  4585   if (y->left != MEM_NIL)
  4586     y->left->parent = x;
  4587 
  4588   /* Y's parent was x's parent.  */
  4589   if (y != MEM_NIL)
  4590     y->parent = x->parent;
  4591 
  4592   /* Get the parent to point to y instead of x.  */
  4593   if (x->parent)
  4594     {
  4595       if (x == x->parent->left)
  4596         x->parent->left = y;
  4597       else
  4598         x->parent->right = y;
  4599     }
  4600   else
  4601     mem_root = y;
  4602 
  4603   /* Put x on y's left.  */
  4604   y->left = x;
  4605   if (x != MEM_NIL)
  4606     x->parent = y;
  4607 }
  4608 
  4609 
  4610 /*     (x)                (Y)
  4611        / \                / \
  4612      (y)  c      ===>    a  (x)
  4613      / \                    / \
  4614     a   b                  b   c  */
  4615 
  4616 static void
  4617 mem_rotate_right (struct mem_node *x)
  4618 {
  4619   struct mem_node *y = x->left;
  4620 
  4621   x->left = y->right;
  4622   if (y->right != MEM_NIL)
  4623     y->right->parent = x;
  4624 
  4625   if (y != MEM_NIL)
  4626     y->parent = x->parent;
  4627   if (x->parent)
  4628     {
  4629       if (x == x->parent->right)
  4630         x->parent->right = y;
  4631       else
  4632         x->parent->left = y;
  4633     }
  4634   else
  4635     mem_root = y;
  4636 
  4637   y->right = x;
  4638   if (x != MEM_NIL)
  4639     x->parent = y;
  4640 }
  4641 
  4642 
  4643 /* Delete node Z from the tree.  If Z is null or MEM_NIL, do nothing.  */
  4644 
  4645 static void
  4646 mem_delete (struct mem_node *z)
  4647 {
  4648   struct mem_node *x, *y;
  4649 
  4650   if (!z || z == MEM_NIL)
  4651     return;
  4652 
  4653   if (z->left == MEM_NIL || z->right == MEM_NIL)
  4654     y = z;
  4655   else
  4656     {
  4657       y = z->right;
  4658       while (y->left != MEM_NIL)
  4659         y = y->left;
  4660     }
  4661 
  4662   if (y->left != MEM_NIL)
  4663     x = y->left;
  4664   else
  4665     x = y->right;
  4666 
  4667   x->parent = y->parent;
  4668   if (y->parent)
  4669     {
  4670       if (y == y->parent->left)
  4671         y->parent->left = x;
  4672       else
  4673         y->parent->right = x;
  4674     }
  4675   else
  4676     mem_root = x;
  4677 
  4678   if (y != z)
  4679     {
  4680       z->start = y->start;
  4681       z->end = y->end;
  4682       z->type = y->type;
  4683     }
  4684 
  4685   if (y->color == MEM_BLACK)
  4686     mem_delete_fixup (x);
  4687 
  4688 #ifdef GC_MALLOC_CHECK
  4689   free (y);
  4690 #else
  4691   xfree (y);
  4692 #endif
  4693 }
  4694 
  4695 
  4696 /* Re-establish the red-black properties of the tree, after a
  4697    deletion.  */
  4698 
  4699 static void
  4700 mem_delete_fixup (struct mem_node *x)
  4701 {
  4702   while (x != mem_root && x->color == MEM_BLACK)
  4703     {
  4704       if (x == x->parent->left)
  4705         {
  4706           struct mem_node *w = x->parent->right;
  4707 
  4708           if (w->color == MEM_RED)
  4709             {
  4710               w->color = MEM_BLACK;
  4711               x->parent->color = MEM_RED;
  4712               mem_rotate_left (x->parent);
  4713               w = x->parent->right;
  4714             }
  4715 
  4716           if (w->left->color == MEM_BLACK && w->right->color == MEM_BLACK)
  4717             {
  4718               w->color = MEM_RED;
  4719               x = x->parent;
  4720             }
  4721           else
  4722             {
  4723               if (w->right->color == MEM_BLACK)
  4724                 {
  4725                   w->left->color = MEM_BLACK;
  4726                   w->color = MEM_RED;
  4727                   mem_rotate_right (w);
  4728                   w = x->parent->right;
  4729                 }
  4730               w->color = x->parent->color;
  4731               x->parent->color = MEM_BLACK;
  4732               w->right->color = MEM_BLACK;
  4733               mem_rotate_left (x->parent);
  4734               x = mem_root;
  4735             }
  4736         }
  4737       else
  4738         {
  4739           struct mem_node *w = x->parent->left;
  4740 
  4741           if (w->color == MEM_RED)
  4742             {
  4743               w->color = MEM_BLACK;
  4744               x->parent->color = MEM_RED;
  4745               mem_rotate_right (x->parent);
  4746               w = x->parent->left;
  4747             }
  4748 
  4749           if (w->right->color == MEM_BLACK && w->left->color == MEM_BLACK)
  4750             {
  4751               w->color = MEM_RED;
  4752               x = x->parent;
  4753             }
  4754           else
  4755             {
  4756               if (w->left->color == MEM_BLACK)
  4757                 {
  4758                   w->right->color = MEM_BLACK;
  4759                   w->color = MEM_RED;
  4760                   mem_rotate_left (w);
  4761                   w = x->parent->left;
  4762                 }
  4763 
  4764               w->color = x->parent->color;
  4765               x->parent->color = MEM_BLACK;
  4766               w->left->color = MEM_BLACK;
  4767               mem_rotate_right (x->parent);
  4768               x = mem_root;
  4769             }
  4770         }
  4771     }
  4772 
  4773   x->color = MEM_BLACK;
  4774 }
  4775 
  4776 
  4777 /* If P is a pointer into a live Lisp string object on the heap,
  4778    return the object's address.  Otherwise, return NULL.  M points to the
  4779    mem_block for P.
  4780 
  4781    This and other *_holding functions look for a pointer anywhere into
  4782    the object, not merely for a pointer to the start of the object,
  4783    because some compilers sometimes optimize away the latter.  See
  4784    Bug#28213.  */
  4785 
  4786 static struct Lisp_String *
  4787 live_string_holding (struct mem_node *m, void *p)
  4788 {
  4789   eassert (m->type == MEM_TYPE_STRING);
  4790 #if GC_ASAN_POISON_OBJECTS
  4791   if (__asan_address_is_poisoned (p))
  4792     return NULL;
  4793 #endif
  4794 
  4795   struct string_block *b = m->start;
  4796   char *cp = p;
  4797   ptrdiff_t offset = cp - (char *) &b->strings[0];
  4798 
  4799   /* P must point into a Lisp_String structure, and it
  4800      must not be on the free-list.  */
  4801   if (0 <= offset && offset < sizeof b->strings)
  4802     {
  4803       ptrdiff_t off = offset % sizeof b->strings[0];
  4804       if (off == Lisp_String
  4805           || off == 0
  4806           || off == offsetof (struct Lisp_String, u.s.size_byte)
  4807           || off == offsetof (struct Lisp_String, u.s.intervals)
  4808           || off == offsetof (struct Lisp_String, u.s.data))
  4809         {
  4810           struct Lisp_String *s = p = cp -= off;
  4811 #if GC_ASAN_POISON_OBJECTS
  4812           if (__asan_region_is_poisoned (s, sizeof (*s)))
  4813             return NULL;
  4814 #endif
  4815           if (s->u.s.data)
  4816             return s;
  4817         }
  4818     }
  4819   return NULL;
  4820 }
  4821 
  4822 static bool
  4823 live_string_p (struct mem_node *m, void *p)
  4824 {
  4825   return live_string_holding (m, p) == p;
  4826 }
  4827 
  4828 /* If P is a pointer into a live Lisp cons object on the heap, return
  4829    the object's address.  Otherwise, return NULL.  M points to the
  4830    mem_block for P.  */
  4831 
  4832 static struct Lisp_Cons *
  4833 live_cons_holding (struct mem_node *m, void *p)
  4834 {
  4835   eassert (m->type == MEM_TYPE_CONS);
  4836 #if GC_ASAN_POISON_OBJECTS
  4837   if (__asan_address_is_poisoned (p))
  4838     return NULL;
  4839 #endif
  4840 
  4841   struct cons_block *b = m->start;
  4842   char *cp = p;
  4843   ptrdiff_t offset = cp - (char *) &b->conses[0];
  4844 
  4845   /* P must point into a Lisp_Cons, not be
  4846      one of the unused cells in the current cons block,
  4847      and not be on the free-list.  */
  4848   if (0 <= offset && offset < sizeof b->conses
  4849       && (b != cons_block
  4850           || offset / sizeof b->conses[0] < cons_block_index))
  4851     {
  4852       ptrdiff_t off = offset % sizeof b->conses[0];
  4853       if (off == Lisp_Cons
  4854           || off == 0
  4855           || off == offsetof (struct Lisp_Cons, u.s.u.cdr))
  4856         {
  4857           struct Lisp_Cons *s = p = cp -= off;
  4858 #if GC_ASAN_POISON_OBJECTS
  4859           if (__asan_region_is_poisoned (s, sizeof (*s)))
  4860             return NULL;
  4861 #endif
  4862           if (!deadp (s->u.s.car))
  4863             return s;
  4864         }
  4865     }
  4866   return NULL;
  4867 }
  4868 
  4869 static bool
  4870 live_cons_p (struct mem_node *m, void *p)
  4871 {
  4872   return live_cons_holding (m, p) == p;
  4873 }
  4874 
  4875 
  4876 /* If P is a pointer into a live Lisp symbol object on the heap,
  4877    return the object's address.  Otherwise, return NULL.  M points to the
  4878    mem_block for P.  */
  4879 
  4880 static struct Lisp_Symbol *
  4881 live_symbol_holding (struct mem_node *m, void *p)
  4882 {
  4883   eassert (m->type == MEM_TYPE_SYMBOL);
  4884 #if GC_ASAN_POISON_OBJECTS
  4885   if (__asan_address_is_poisoned (p))
  4886     return NULL;
  4887 #endif
  4888   struct symbol_block *b = m->start;
  4889   char *cp = p;
  4890   ptrdiff_t offset = cp - (char *) &b->symbols[0];
  4891 
  4892   /* P must point into the Lisp_Symbol, not be
  4893      one of the unused cells in the current symbol block,
  4894      and not be on the free-list.  */
  4895   if (0 <= offset && offset < sizeof b->symbols
  4896       && (b != symbol_block
  4897           || offset / sizeof b->symbols[0] < symbol_block_index))
  4898     {
  4899       ptrdiff_t off = offset % sizeof b->symbols[0];
  4900       if (off == Lisp_Symbol
  4901 
  4902           /* Plain '|| off == 0' would run afoul of GCC 10.2
  4903              -Wlogical-op, as Lisp_Symbol happens to be zero.  */
  4904           || (Lisp_Symbol != 0 && off == 0)
  4905 
  4906           || off == offsetof (struct Lisp_Symbol, u.s.name)
  4907           || off == offsetof (struct Lisp_Symbol, u.s.val)
  4908           || off == offsetof (struct Lisp_Symbol, u.s.function)
  4909           || off == offsetof (struct Lisp_Symbol, u.s.plist)
  4910           || off == offsetof (struct Lisp_Symbol, u.s.next))
  4911         {
  4912           struct Lisp_Symbol *s = p = cp -= off;
  4913 #if GC_ASAN_POISON_OBJECTS
  4914           if (__asan_region_is_poisoned (s, sizeof (*s)))
  4915             return NULL;
  4916 #endif
  4917           if (!deadp (s->u.s.function))
  4918             return s;
  4919         }
  4920     }
  4921   return NULL;
  4922 }
  4923 
  4924 static bool
  4925 live_symbol_p (struct mem_node *m, void *p)
  4926 {
  4927   return live_symbol_holding (m, p) == p;
  4928 }
  4929 
  4930 
  4931 /* If P is a (possibly-tagged) pointer to a live Lisp_Float on the
  4932    heap, return the address of the Lisp_Float.  Otherwise, return NULL.
  4933    M is a pointer to the mem_block for P.  */
  4934 
  4935 static struct Lisp_Float *
  4936 live_float_holding (struct mem_node *m, void *p)
  4937 {
  4938   eassert (m->type == MEM_TYPE_FLOAT);
  4939 #if GC_ASAN_POISON_OBJECTS
  4940   if (__asan_address_is_poisoned (p))
  4941     return NULL;
  4942 #endif
  4943 
  4944   struct float_block *b = m->start;
  4945   char *cp = p;
  4946   ptrdiff_t offset = cp - (char *) &b->floats[0];
  4947 
  4948   /* P must point to (or be a tagged pointer to) the start of a
  4949      Lisp_Float and not be one of the unused cells in the current
  4950      float block.  */
  4951   if (0 <= offset && offset < sizeof b->floats)
  4952     {
  4953       int off = offset % sizeof b->floats[0];
  4954       if ((off == Lisp_Float || off == 0)
  4955           && (b != float_block
  4956               || offset / sizeof b->floats[0] < float_block_index))
  4957         {
  4958           struct Lisp_Float *f = (struct Lisp_Float *) (cp - off);
  4959 #if GC_ASAN_POISON_OBJECTS
  4960           if (__asan_region_is_poisoned (f, sizeof (*f)))
  4961             return NULL;
  4962 #endif
  4963           return f;
  4964         }
  4965     }
  4966   return NULL;
  4967 }
  4968 
  4969 static bool
  4970 live_float_p (struct mem_node *m, void *p)
  4971 {
  4972   return live_float_holding (m, p) == p;
  4973 }
  4974 
  4975 /* Return VECTOR if P points within it, NULL otherwise.  */
  4976 
  4977 static struct Lisp_Vector *
  4978 live_vector_pointer (struct Lisp_Vector *vector, void *p)
  4979 {
  4980   void *vvector = vector;
  4981   char *cvector = vvector;
  4982   char *cp = p;
  4983   ptrdiff_t offset = cp - cvector;
  4984   return ((offset == Lisp_Vectorlike
  4985            || offset == 0
  4986            || (sizeof vector->header <= offset
  4987                && offset < vector_nbytes (vector)
  4988                && (! (vector->header.size & PSEUDOVECTOR_FLAG)
  4989                    ? (offsetof (struct Lisp_Vector, contents) <= offset
  4990                       && (((offset - offsetof (struct Lisp_Vector, contents))
  4991                            % word_size)
  4992                           == 0))
  4993                    /* For non-bool-vector pseudovectors, treat any pointer
  4994                       past the header as valid since it's too much of a pain
  4995                       to write special-case code for every pseudovector.  */
  4996                    : (! PSEUDOVECTOR_TYPEP (&vector->header, PVEC_BOOL_VECTOR)
  4997                       || offset == offsetof (struct Lisp_Bool_Vector, size)
  4998                       || (offsetof (struct Lisp_Bool_Vector, data) <= offset
  4999                           && (((offset
  5000                                 - offsetof (struct Lisp_Bool_Vector, data))
  5001                                % sizeof (bits_word))
  5002                               == 0))))))
  5003           ? vector : NULL);
  5004 }
  5005 
  5006 /* If P is a pointer to a live, large vector-like object, return the object.
  5007    Otherwise, return nil.
  5008    M is a pointer to the mem_block for P.  */
  5009 
  5010 static struct Lisp_Vector *
  5011 live_large_vector_holding (struct mem_node *m, void *p)
  5012 {
  5013   eassert (m->type == MEM_TYPE_VECTORLIKE);
  5014   return live_vector_pointer (large_vector_vec (m->start), p);
  5015 }
  5016 
  5017 static bool
  5018 live_large_vector_p (struct mem_node *m, void *p)
  5019 {
  5020   return live_large_vector_holding (m, p) == p;
  5021 }
  5022 
  5023 /* If P is a pointer to a live, small vector-like object, return the object.
  5024    Otherwise, return NULL.
  5025    M is a pointer to the mem_block for P.  */
  5026 
  5027 static struct Lisp_Vector *
  5028 live_small_vector_holding (struct mem_node *m, void *p)
  5029 {
  5030   eassert (m->type == MEM_TYPE_VECTOR_BLOCK);
  5031   struct Lisp_Vector *vp = p;
  5032   struct vector_block *block = m->start;
  5033   struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data;
  5034 
  5035   /* P is in the block's allocation range.  Scan the block
  5036      up to P and see whether P points to the start of some
  5037      vector which is not on a free list.  FIXME: check whether
  5038      some allocation patterns (probably a lot of short vectors)
  5039      may cause a substantial overhead of this loop.  */
  5040   while (VECTOR_IN_BLOCK (vector, block) && vector <= vp)
  5041     {
  5042       struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector));
  5043       if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE))
  5044         return live_vector_pointer (vector, vp);
  5045       vector = next;
  5046     }
  5047   return NULL;
  5048 }
  5049 
  5050 static bool
  5051 live_small_vector_p (struct mem_node *m, void *p)
  5052 {
  5053   return live_small_vector_holding (m, p) == p;
  5054 }
  5055 
  5056 /* If P points to Lisp data, mark that as live if it isn't already
  5057    marked.  */
  5058 
  5059 static void
  5060 mark_maybe_pointer (void *p, bool symbol_only)
  5061 {
  5062   struct mem_node *m;
  5063 
  5064 #if USE_VALGRIND
  5065   VALGRIND_MAKE_MEM_DEFINED (&p, sizeof (p));
  5066 #endif
  5067 
  5068   /* If the pointer is in the dump image and the dump has a record
  5069      of the object starting at the place where the pointer points, we
  5070      definitely have an object.  If the pointer is in the dump image
  5071      and the dump has no idea what the pointer is pointing at, we
  5072      definitely _don't_ have an object.  */
  5073   if (pdumper_object_p (p))
  5074     {
  5075       /* FIXME: This code assumes that every reachable pdumper object
  5076          is addressed either by a pointer to the object start, or by
  5077          the same pointer with an LSB-style tag.  This assumption
  5078          fails if a pdumper object is reachable only via machine
  5079          addresses of non-initial object components.  Although such
  5080          addressing is rare in machine code generated by C compilers
  5081          from Emacs source code, it can occur in some cases.  To fix
  5082          this problem, the pdumper code should grok non-initial
  5083          addresses, as the non-pdumper code does.  */
  5084       uintptr_t mask = VALMASK & UINTPTR_MAX;
  5085       uintptr_t masked_p = (uintptr_t) p & mask;
  5086       void *po = (void *) masked_p;
  5087       char *cp = p;
  5088       char *cpo = po;
  5089       /* Don't use pdumper_object_p_precise here! It doesn't check the
  5090          tag bits. OBJ here might be complete garbage, so we need to
  5091          verify both the pointer and the tag.  */
  5092       int type = pdumper_find_object_type (po);
  5093       if (pdumper_valid_object_type_p (type)
  5094           && (!USE_LSB_TAG || p == po || cp - cpo == type))
  5095         {
  5096           if (type == Lisp_Symbol)
  5097             mark_object (make_lisp_symbol (po));
  5098           else if (!symbol_only)
  5099             mark_object (make_lisp_ptr (po, type));
  5100         }
  5101       return;
  5102     }
  5103 
  5104   m = mem_find (p);
  5105   if (m != MEM_NIL)
  5106     {
  5107       Lisp_Object obj;
  5108 
  5109       switch (m->type)
  5110         {
  5111         case MEM_TYPE_NON_LISP:
  5112         case MEM_TYPE_SPARE:
  5113           /* Nothing to do; not a pointer to Lisp memory.  */
  5114           return;
  5115 
  5116         case MEM_TYPE_CONS:
  5117           {
  5118             if (symbol_only)
  5119               return;
  5120             struct Lisp_Cons *h = live_cons_holding (m, p);
  5121             if (!h)
  5122               return;
  5123             obj = make_lisp_ptr (h, Lisp_Cons);
  5124           }
  5125           break;
  5126 
  5127         case MEM_TYPE_STRING:
  5128           {
  5129             if (symbol_only)
  5130               return;
  5131             struct Lisp_String *h = live_string_holding (m, p);
  5132             if (!h)
  5133               return;
  5134             obj = make_lisp_ptr (h, Lisp_String);
  5135           }
  5136           break;
  5137 
  5138         case MEM_TYPE_SYMBOL:
  5139           {
  5140             struct Lisp_Symbol *h = live_symbol_holding (m, p);
  5141             if (!h)
  5142               return;
  5143             obj = make_lisp_symbol (h);
  5144           }
  5145           break;
  5146 
  5147         case MEM_TYPE_FLOAT:
  5148           {
  5149             if (symbol_only)
  5150               return;
  5151             struct Lisp_Float *h = live_float_holding (m, p);
  5152             if (!h)
  5153               return;
  5154             obj = make_lisp_ptr (h, Lisp_Float);
  5155           }
  5156           break;
  5157 
  5158         case MEM_TYPE_VECTORLIKE:
  5159           {
  5160             if (symbol_only)
  5161               return;
  5162             struct Lisp_Vector *h = live_large_vector_holding (m, p);
  5163             if (!h)
  5164               return;
  5165             obj = make_lisp_ptr (h, Lisp_Vectorlike);
  5166           }
  5167           break;
  5168 
  5169         case MEM_TYPE_VECTOR_BLOCK:
  5170           {
  5171             if (symbol_only)
  5172               return;
  5173             struct Lisp_Vector *h = live_small_vector_holding (m, p);
  5174             if (!h)
  5175               return;
  5176             obj = make_lisp_ptr (h, Lisp_Vectorlike);
  5177           }
  5178           break;
  5179 
  5180         default:
  5181           emacs_abort ();
  5182         }
  5183 
  5184       mark_object (obj);
  5185     }
  5186 }
  5187 
  5188 
  5189 /* Alignment of pointer values.  Use alignof, as it sometimes returns
  5190    a smaller alignment than GCC's __alignof__ and mark_memory might
  5191    miss objects if __alignof__ were used.  */
  5192 #define GC_POINTER_ALIGNMENT alignof (void *)
  5193 
  5194 /* Mark Lisp objects referenced from the address range START..END
  5195    or END..START.  */
  5196 
  5197 void ATTRIBUTE_NO_SANITIZE_ADDRESS
  5198 mark_memory (void const *start, void const *end)
  5199 {
  5200   char const *pp;
  5201 
  5202   /* Make START the pointer to the start of the memory region,
  5203      if it isn't already.  */
  5204   if (end < start)
  5205     {
  5206       void const *tem = start;
  5207       start = end;
  5208       end = tem;
  5209     }
  5210 
  5211   eassert (((uintptr_t) start) % GC_POINTER_ALIGNMENT == 0);
  5212 
  5213   /* Mark Lisp data pointed to.  This is necessary because, in some
  5214      situations, the C compiler optimizes Lisp objects away, so that
  5215      only a pointer to them remains.  Example:
  5216 
  5217      DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
  5218      ()
  5219      {
  5220        Lisp_Object obj = build_string ("test");
  5221        struct Lisp_String *s = XSTRING (obj);
  5222        garbage_collect ();
  5223        fprintf (stderr, "test '%s'\n", s->u.s.data);
  5224        return Qnil;
  5225      }
  5226 
  5227      Here, `obj' isn't really used, and the compiler optimizes it
  5228      away.  The only reference to the life string is through the
  5229      pointer `s'.  */
  5230 
  5231   for (pp = start; (void const *) pp < end; pp += GC_POINTER_ALIGNMENT)
  5232     {
  5233       void *p = *(void *const *) pp;
  5234       mark_maybe_pointer (p, false);
  5235 
  5236       /* Unmask any struct Lisp_Symbol pointer that make_lisp_symbol
  5237          previously disguised by adding the address of 'lispsym'.
  5238          On a host with 32-bit pointers and 64-bit Lisp_Objects,
  5239          a Lisp_Object might be split into registers saved into
  5240          non-adjacent words and P might be the low-order word's value.  */
  5241       intptr_t ip;
  5242       ckd_add (&ip, (intptr_t) p, (intptr_t) lispsym);
  5243       mark_maybe_pointer ((void *) ip, true);
  5244     }
  5245 }
  5246 
  5247 #ifndef HAVE___BUILTIN_UNWIND_INIT
  5248 
  5249 # ifdef GC_SETJMP_WORKS
  5250 static void
  5251 test_setjmp (void)
  5252 {
  5253 }
  5254 # else
  5255 
  5256 static bool setjmp_tested_p;
  5257 static int longjmps_done;
  5258 
  5259 #  define SETJMP_WILL_LIKELY_WORK "\
  5260 \n\
  5261 Emacs garbage collector has been changed to use conservative stack\n\
  5262 marking.  Emacs has determined that the method it uses to do the\n\
  5263 marking will likely work on your system, but this isn't sure.\n\
  5264 \n\
  5265 If you are a system-programmer, or can get the help of a local wizard\n\
  5266 who is, please take a look at the function mark_c_stack in alloc.c, and\n\
  5267 verify that the methods used are appropriate for your system.\n\
  5268 \n\
  5269 Please mail the result to <emacs-devel@gnu.org>.\n\
  5270 "
  5271 
  5272 #  define SETJMP_WILL_NOT_WORK "\
  5273 \n\
  5274 Emacs garbage collector has been changed to use conservative stack\n\
  5275 marking.  Emacs has determined that the default method it uses to do the\n\
  5276 marking will not work on your system.  We will need a system-dependent\n\
  5277 solution for your system.\n\
  5278 \n\
  5279 Please take a look at the function mark_c_stack in alloc.c, and\n\
  5280 try to find a way to make it work on your system.\n\
  5281 \n\
  5282 Note that you may get false negatives, depending on the compiler.\n\
  5283 In particular, you need to use -O with GCC for this test.\n\
  5284 \n\
  5285 Please mail the result to <emacs-devel@gnu.org>.\n\
  5286 "
  5287 
  5288 
  5289 /* Perform a quick check if it looks like setjmp saves registers in a
  5290    jmp_buf.  Print a message to stderr saying so.  When this test
  5291    succeeds, this is _not_ a proof that setjmp is sufficient for
  5292    conservative stack marking.  Only the sources or a disassembly
  5293    can prove that.  */
  5294 
  5295 static void
  5296 test_setjmp (void)
  5297 {
  5298   if (setjmp_tested_p)
  5299     return;
  5300   setjmp_tested_p = true;
  5301   char buf[10];
  5302   register int x;
  5303   sys_jmp_buf jbuf;
  5304 
  5305   /* Arrange for X to be put in a register.  */
  5306   sprintf (buf, "1");
  5307   x = strlen (buf);
  5308   x = 2 * x - 1;
  5309 
  5310   sys_setjmp (jbuf);
  5311   if (longjmps_done == 1)
  5312     {
  5313       /* Came here after the longjmp at the end of the function.
  5314 
  5315          If x == 1, the longjmp has restored the register to its
  5316          value before the setjmp, and we can hope that setjmp
  5317          saves all such registers in the jmp_buf, although that
  5318          isn't sure.
  5319 
  5320          For other values of X, either something really strange is
  5321          taking place, or the setjmp just didn't save the register.  */
  5322 
  5323       if (x == 1)
  5324         fputs (SETJMP_WILL_LIKELY_WORK, stderr);
  5325       else
  5326         {
  5327           fputs (SETJMP_WILL_NOT_WORK, stderr);
  5328           exit (1);
  5329         }
  5330     }
  5331 
  5332   ++longjmps_done;
  5333   x = 2;
  5334   if (longjmps_done == 1)
  5335     sys_longjmp (jbuf, 1);
  5336 }
  5337 # endif /* ! GC_SETJMP_WORKS */
  5338 #endif /* ! HAVE___BUILTIN_UNWIND_INIT */
  5339 
  5340 /* The type of an object near the stack top, whose address can be used
  5341    as a stack scan limit.  */
  5342 typedef union
  5343 {
  5344   /* Make sure stack_top and m_stack_bottom are properly aligned as GC
  5345      expects.  */
  5346   Lisp_Object o;
  5347   void *p;
  5348 #ifndef HAVE___BUILTIN_UNWIND_INIT
  5349   sys_jmp_buf j;
  5350   char c;
  5351 #endif
  5352 } stacktop_sentry;
  5353 
  5354 /* Set *P to the address of the top of the stack.  This must be a
  5355    macro, not a function, so that it is executed in the caller's
  5356    environment.  It is not inside a do-while so that its storage
  5357    survives the macro.  Callers should be declared NO_INLINE.  */
  5358 #ifdef HAVE___BUILTIN_UNWIND_INIT
  5359 # define SET_STACK_TOP_ADDRESS(p)       \
  5360    stacktop_sentry sentry;              \
  5361    *(p) = NEAR_STACK_TOP (&sentry)
  5362 #else
  5363 # define SET_STACK_TOP_ADDRESS(p)               \
  5364    stacktop_sentry sentry;                      \
  5365    test_setjmp ();                              \
  5366    sys_setjmp (sentry.j);                       \
  5367    *(p) = NEAR_STACK_TOP (&sentry + (stack_bottom < &sentry.c))
  5368 #endif
  5369 
  5370 /* Mark live Lisp objects on the C stack.
  5371 
  5372    There are several system-dependent problems to consider when
  5373    porting this to new architectures:
  5374 
  5375    Processor Registers
  5376 
  5377    We have to mark Lisp objects in CPU registers that can hold local
  5378    variables or are used to pass parameters.
  5379 
  5380    If __builtin_unwind_init is available, it should suffice to save
  5381    registers.
  5382 
  5383    Otherwise, assume that calling setjmp saves registers we need
  5384    to see in a jmp_buf which itself lies on the stack.  This doesn't
  5385    have to be true!  It must be verified for each system, possibly
  5386    by taking a look at the source code of setjmp.
  5387 
  5388    Stack Layout
  5389 
  5390    Architectures differ in the way their processor stack is organized.
  5391    For example, the stack might look like this
  5392 
  5393      +----------------+
  5394      |  Lisp_Object   |  size = 4
  5395      +----------------+
  5396      | something else |  size = 2
  5397      +----------------+
  5398      |  Lisp_Object   |  size = 4
  5399      +----------------+
  5400      |  ...           |
  5401 
  5402    In such a case, not every Lisp_Object will be aligned equally.  To
  5403    find all Lisp_Object on the stack it won't be sufficient to walk
  5404    the stack in steps of 4 bytes.  Instead, two passes will be
  5405    necessary, one starting at the start of the stack, and a second
  5406    pass starting at the start of the stack + 2.  Likewise, if the
  5407    minimal alignment of Lisp_Objects on the stack is 1, four passes
  5408    would be necessary, each one starting with one byte more offset
  5409    from the stack start.  */
  5410 
  5411 void
  5412 mark_c_stack (char const *bottom, char const *end)
  5413 {
  5414   /* This assumes that the stack is a contiguous region in memory.  If
  5415      that's not the case, something has to be done here to iterate
  5416      over the stack segments.  */
  5417   mark_memory (bottom, end);
  5418 
  5419   /* Allow for marking a secondary stack, like the register stack on the
  5420      ia64.  */
  5421 #ifdef GC_MARK_SECONDARY_STACK
  5422   GC_MARK_SECONDARY_STACK ();
  5423 #endif
  5424 }
  5425 
  5426 /* flush_stack_call_func is the trampoline function that flushes
  5427    registers to the stack, and then calls FUNC.  ARG is passed through
  5428    to FUNC verbatim.
  5429 
  5430    This function must be called whenever Emacs is about to release the
  5431    global interpreter lock.  This lets the garbage collector easily
  5432    find roots in registers on threads that are not actively running
  5433    Lisp.
  5434 
  5435    It is invalid to run any Lisp code or to allocate any GC memory
  5436    from FUNC.
  5437 
  5438    Note: all register spilling is done in flush_stack_call_func before
  5439    flush_stack_call_func1 is activated.
  5440 
  5441    flush_stack_call_func1 is responsible for identifying the stack
  5442    address range to be scanned.  It *must* be carefully kept as
  5443    noinline to make sure that registers has been spilled before it is
  5444    called, otherwise given __builtin_frame_address (0) typically
  5445    returns the frame pointer (base pointer) and not the stack pointer
  5446    [1] GC will miss to scan callee-saved registers content
  5447    (Bug#41357).
  5448 
  5449    [1] <https://gcc.gnu.org/onlinedocs/gcc/Return-Address.html>.  */
  5450 
  5451 NO_INLINE void
  5452 flush_stack_call_func1 (void (*func) (void *arg), void *arg)
  5453 {
  5454   void *end;
  5455   struct thread_state *self = current_thread;
  5456   SET_STACK_TOP_ADDRESS (&end);
  5457   self->stack_top = end;
  5458   func (arg);
  5459   eassert (current_thread == self);
  5460 }
  5461 
  5462 /* Determine whether it is safe to access memory at address P.  */
  5463 static int
  5464 valid_pointer_p (void *p)
  5465 {
  5466 #ifdef WINDOWSNT
  5467   return w32_valid_pointer_p (p, 16);
  5468 #else
  5469 
  5470   if (ADDRESS_SANITIZER)
  5471     return p ? -1 : 0;
  5472 
  5473   int fd[2];
  5474   static int under_rr_state;
  5475 
  5476   if (!under_rr_state)
  5477     under_rr_state = getenv ("RUNNING_UNDER_RR") ? -1 : 1;
  5478   if (under_rr_state < 0)
  5479     return under_rr_state;
  5480 
  5481   /* Obviously, we cannot just access it (we would SEGV trying), so we
  5482      trick the o/s to tell us whether p is a valid pointer.
  5483      Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
  5484      not validate p in that case.  */
  5485 
  5486   if (emacs_pipe (fd) == 0)
  5487     {
  5488       bool valid = emacs_write (fd[1], p, 16) == 16;
  5489       emacs_close (fd[1]);
  5490       emacs_close (fd[0]);
  5491       return valid;
  5492     }
  5493 
  5494   return -1;
  5495 #endif
  5496 }
  5497 
  5498 /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a
  5499    valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we
  5500    cannot validate OBJ.  This function can be quite slow, and is used
  5501    only in debugging.  */
  5502 
  5503 int
  5504 valid_lisp_object_p (Lisp_Object obj)
  5505 {
  5506   if (FIXNUMP (obj))
  5507     return 1;
  5508 
  5509   void *p = XPNTR (obj);
  5510   if (PURE_P (p))
  5511     return 1;
  5512 
  5513   if (BARE_SYMBOL_P (obj) && c_symbol_p (p))
  5514     return ((char *) p - (char *) lispsym) % sizeof lispsym[0] == 0;
  5515 
  5516   if (p == &buffer_defaults || p == &buffer_local_symbols)
  5517     return 2;
  5518 
  5519   if (pdumper_object_p (p))
  5520     return pdumper_object_p_precise (p) ? 1 : 0;
  5521 
  5522   struct mem_node *m = mem_find (p);
  5523 
  5524   if (m == MEM_NIL)
  5525     {
  5526       int valid = valid_pointer_p (p);
  5527       if (valid <= 0)
  5528         return valid;
  5529 
  5530       /* Strings and conses produced by AUTO_STRING etc. all get here.  */
  5531       if (SUBRP (obj) || STRINGP (obj) || CONSP (obj))
  5532         return 1;
  5533 
  5534       return 0;
  5535     }
  5536 
  5537   switch (m->type)
  5538     {
  5539     case MEM_TYPE_NON_LISP:
  5540     case MEM_TYPE_SPARE:
  5541       return 0;
  5542 
  5543     case MEM_TYPE_CONS:
  5544       return live_cons_p (m, p);
  5545 
  5546     case MEM_TYPE_STRING:
  5547       return live_string_p (m, p);
  5548 
  5549     case MEM_TYPE_SYMBOL:
  5550       return live_symbol_p (m, p);
  5551 
  5552     case MEM_TYPE_FLOAT:
  5553       return live_float_p (m, p);
  5554 
  5555     case MEM_TYPE_VECTORLIKE:
  5556       return live_large_vector_p (m, p);
  5557 
  5558     case MEM_TYPE_VECTOR_BLOCK:
  5559       return live_small_vector_p (m, p);
  5560 
  5561     default:
  5562       break;
  5563     }
  5564 
  5565   return 0;
  5566 }
  5567 
  5568 /***********************************************************************
  5569                        Pure Storage Management
  5570  ***********************************************************************/
  5571 
  5572 /* Allocate room for SIZE bytes from pure Lisp storage and return a
  5573    pointer to it.  TYPE is the Lisp type for which the memory is
  5574    allocated.  TYPE < 0 means it's not used for a Lisp object,
  5575    and that the result should have an alignment of -TYPE.
  5576 
  5577    The bytes are initially zero.
  5578 
  5579    If pure space is exhausted, allocate space from the heap.  This is
  5580    merely an expedient to let Emacs warn that pure space was exhausted
  5581    and that Emacs should be rebuilt with a larger pure space.  */
  5582 
  5583 static void *
  5584 pure_alloc (size_t size, int type)
  5585 {
  5586   void *result;
  5587   static bool pure_overflow_warned = false;
  5588 
  5589  again:
  5590   if (type >= 0)
  5591     {
  5592       /* Allocate space for a Lisp object from the beginning of the free
  5593          space with taking account of alignment.  */
  5594       result = pointer_align (purebeg + pure_bytes_used_lisp, LISP_ALIGNMENT);
  5595       pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size;
  5596     }
  5597   else
  5598     {
  5599       /* Allocate space for a non-Lisp object from the end of the free
  5600          space.  */
  5601       ptrdiff_t unaligned_non_lisp = pure_bytes_used_non_lisp + size;
  5602       char *unaligned = purebeg + pure_size - unaligned_non_lisp;
  5603       int decr = (intptr_t) unaligned & (-1 - type);
  5604       pure_bytes_used_non_lisp = unaligned_non_lisp + decr;
  5605       result = unaligned - decr;
  5606     }
  5607   pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp;
  5608 
  5609   if (pure_bytes_used <= pure_size)
  5610     return result;
  5611 
  5612   if (!pure_overflow_warned)
  5613     {
  5614       message ("Pure Lisp storage overflowed");
  5615       pure_overflow_warned = true;
  5616     }
  5617 
  5618   /* Don't allocate a large amount here,
  5619      because it might get mmap'd and then its address
  5620      might not be usable.  */
  5621   int small_amount = 10000;
  5622   eassert (size <= small_amount - LISP_ALIGNMENT);
  5623   purebeg = xzalloc (small_amount);
  5624   pure_size = small_amount;
  5625   pure_bytes_used_before_overflow += pure_bytes_used - size;
  5626   pure_bytes_used = 0;
  5627   pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
  5628 
  5629   /* Can't GC if pure storage overflowed because we can't determine
  5630      if something is a pure object or not.  */
  5631   garbage_collection_inhibited++;
  5632   goto again;
  5633 }
  5634 
  5635 /* Print a warning if PURESIZE is too small.  */
  5636 
  5637 void
  5638 check_pure_size (void)
  5639 {
  5640   if (pure_bytes_used_before_overflow)
  5641     message (("emacs:0:Pure Lisp storage overflow (approx. %jd"
  5642               " bytes needed)"),
  5643              pure_bytes_used + pure_bytes_used_before_overflow);
  5644 }
  5645 
  5646 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
  5647    the non-Lisp data pool of the pure storage, and return its start
  5648    address.  Return NULL if not found.  */
  5649 
  5650 static char *
  5651 find_string_data_in_pure (const char *data, ptrdiff_t nbytes)
  5652 {
  5653   int i;
  5654   ptrdiff_t skip, bm_skip[256], last_char_skip, infinity, start, start_max;
  5655   const unsigned char *p;
  5656   char *non_lisp_beg;
  5657 
  5658   if (pure_bytes_used_non_lisp <= nbytes)
  5659     return NULL;
  5660 
  5661   /* The Android GCC generates code like:
  5662 
  5663    0xa539e755 <+52>:    lea    0x430(%esp),%esi
  5664 => 0xa539e75c <+59>:    movdqa %xmm0,0x0(%ebp)
  5665    0xa539e761 <+64>:    add    $0x10,%ebp
  5666 
  5667    but data is not aligned appropriately, so a GP fault results.  */
  5668 
  5669 #if defined __i386__                            \
  5670   && defined HAVE_ANDROID                       \
  5671   && !defined ANDROID_STUBIFY                   \
  5672   && !defined (__clang__)
  5673   if ((intptr_t) data & 15)
  5674     return NULL;
  5675 #endif
  5676 
  5677   /* Set up the Boyer-Moore table.  */
  5678   skip = nbytes + 1;
  5679   for (i = 0; i < 256; i++)
  5680     bm_skip[i] = skip;
  5681 
  5682   p = (const unsigned char *) data;
  5683   while (--skip > 0)
  5684     bm_skip[*p++] = skip;
  5685 
  5686   last_char_skip = bm_skip['\0'];
  5687 
  5688   non_lisp_beg = purebeg + pure_size - pure_bytes_used_non_lisp;
  5689   start_max = pure_bytes_used_non_lisp - (nbytes + 1);
  5690 
  5691   /* See the comments in the function `boyer_moore' (search.c) for the
  5692      use of `infinity'.  */
  5693   infinity = pure_bytes_used_non_lisp + 1;
  5694   bm_skip['\0'] = infinity;
  5695 
  5696   p = (const unsigned char *) non_lisp_beg + nbytes;
  5697   start = 0;
  5698   do
  5699     {
  5700       /* Check the last character (== '\0').  */
  5701       do
  5702         {
  5703           start += bm_skip[*(p + start)];
  5704         }
  5705       while (start <= start_max);
  5706 
  5707       if (start < infinity)
  5708         /* Couldn't find the last character.  */
  5709         return NULL;
  5710 
  5711       /* No less than `infinity' means we could find the last
  5712          character at `p[start - infinity]'.  */
  5713       start -= infinity;
  5714 
  5715       /* Check the remaining characters.  */
  5716       if (memcmp (data, non_lisp_beg + start, nbytes) == 0)
  5717         /* Found.  */
  5718         return non_lisp_beg + start;
  5719 
  5720       start += last_char_skip;
  5721     }
  5722   while (start <= start_max);
  5723 
  5724   return NULL;
  5725 }
  5726 
  5727 
  5728 /* Return a string allocated in pure space.  DATA is a buffer holding
  5729    NCHARS characters, and NBYTES bytes of string data.  MULTIBYTE
  5730    means make the result string multibyte.
  5731 
  5732    Must get an error if pure storage is full, since if it cannot hold
  5733    a large string it may be able to hold conses that point to that
  5734    string; then the string is not protected from gc.  */
  5735 
  5736 Lisp_Object
  5737 make_pure_string (const char *data,
  5738                   ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte)
  5739 {
  5740   Lisp_Object string;
  5741   struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String);
  5742   s->u.s.data = (unsigned char *) find_string_data_in_pure (data, nbytes);
  5743   if (s->u.s.data == NULL)
  5744     {
  5745       s->u.s.data = pure_alloc (nbytes + 1, -1);
  5746       memcpy (s->u.s.data, data, nbytes);
  5747       s->u.s.data[nbytes] = '\0';
  5748     }
  5749   s->u.s.size = nchars;
  5750   s->u.s.size_byte = multibyte ? nbytes : -1;
  5751   s->u.s.intervals = NULL;
  5752   XSETSTRING (string, s);
  5753   return string;
  5754 }
  5755 
  5756 /* Return a string allocated in pure space.  Do not
  5757    allocate the string data, just point to DATA.  */
  5758 
  5759 Lisp_Object
  5760 make_pure_c_string (const char *data, ptrdiff_t nchars)
  5761 {
  5762   Lisp_Object string;
  5763   struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String);
  5764   s->u.s.size = nchars;
  5765   s->u.s.size_byte = -2;
  5766   s->u.s.data = (unsigned char *) data;
  5767   s->u.s.intervals = NULL;
  5768   XSETSTRING (string, s);
  5769   return string;
  5770 }
  5771 
  5772 static Lisp_Object purecopy (Lisp_Object obj);
  5773 
  5774 /* Return a cons allocated from pure space.  Give it pure copies
  5775    of CAR as car and CDR as cdr.  */
  5776 
  5777 Lisp_Object
  5778 pure_cons (Lisp_Object car, Lisp_Object cdr)
  5779 {
  5780   Lisp_Object new;
  5781   struct Lisp_Cons *p = pure_alloc (sizeof *p, Lisp_Cons);
  5782   XSETCONS (new, p);
  5783   XSETCAR (new, purecopy (car));
  5784   XSETCDR (new, purecopy (cdr));
  5785   return new;
  5786 }
  5787 
  5788 
  5789 /* Value is a float object with value NUM allocated from pure space.  */
  5790 
  5791 static Lisp_Object
  5792 make_pure_float (double num)
  5793 {
  5794   Lisp_Object new;
  5795   struct Lisp_Float *p = pure_alloc (sizeof *p, Lisp_Float);
  5796   XSETFLOAT (new, p);
  5797   XFLOAT_INIT (new, num);
  5798   return new;
  5799 }
  5800 
  5801 /* Value is a bignum object with value VALUE allocated from pure
  5802    space.  */
  5803 
  5804 static Lisp_Object
  5805 make_pure_bignum (Lisp_Object value)
  5806 {
  5807   mpz_t const *n = xbignum_val (value);
  5808   size_t i, nlimbs = mpz_size (*n);
  5809   size_t nbytes = nlimbs * sizeof (mp_limb_t);
  5810   mp_limb_t *pure_limbs;
  5811   mp_size_t new_size;
  5812 
  5813   struct Lisp_Bignum *b = pure_alloc (sizeof *b, Lisp_Vectorlike);
  5814   XSETPVECTYPESIZE (b, PVEC_BIGNUM, 0, VECSIZE (struct Lisp_Bignum));
  5815 
  5816   int limb_alignment = alignof (mp_limb_t);
  5817   pure_limbs = pure_alloc (nbytes, - limb_alignment);
  5818   for (i = 0; i < nlimbs; ++i)
  5819     pure_limbs[i] = mpz_getlimbn (*n, i);
  5820 
  5821   new_size = nlimbs;
  5822   if (mpz_sgn (*n) < 0)
  5823     new_size = -new_size;
  5824 
  5825   mpz_roinit_n (b->value, pure_limbs, new_size);
  5826 
  5827   return make_lisp_ptr (b, Lisp_Vectorlike);
  5828 }
  5829 
  5830 /* Return a vector with room for LEN Lisp_Objects allocated from
  5831    pure space.  */
  5832 
  5833 static Lisp_Object
  5834 make_pure_vector (ptrdiff_t len)
  5835 {
  5836   Lisp_Object new;
  5837   size_t size = header_size + len * word_size;
  5838   struct Lisp_Vector *p = pure_alloc (size, Lisp_Vectorlike);
  5839   XSETVECTOR (new, p);
  5840   XVECTOR (new)->header.size = len;
  5841   return new;
  5842 }
  5843 
  5844 /* Copy all contents and parameters of TABLE to a new table allocated
  5845    from pure space, return the purified table.  */
  5846 static struct Lisp_Hash_Table *
  5847 purecopy_hash_table (struct Lisp_Hash_Table *table)
  5848 {
  5849   eassert (NILP (table->weak));
  5850   eassert (table->purecopy);
  5851 
  5852   struct Lisp_Hash_Table *pure = pure_alloc (sizeof *pure, Lisp_Vectorlike);
  5853   struct hash_table_test pure_test = table->test;
  5854 
  5855   /* Purecopy the hash table test.  */
  5856   pure_test.name = purecopy (table->test.name);
  5857   pure_test.user_hash_function = purecopy (table->test.user_hash_function);
  5858   pure_test.user_cmp_function = purecopy (table->test.user_cmp_function);
  5859 
  5860   pure->header = table->header;
  5861   pure->weak = purecopy (Qnil);
  5862   pure->hash = purecopy (table->hash);
  5863   pure->next = purecopy (table->next);
  5864   pure->index = purecopy (table->index);
  5865   pure->count = table->count;
  5866   pure->next_free = table->next_free;
  5867   pure->purecopy = table->purecopy;
  5868   eassert (!pure->mutable);
  5869   pure->rehash_threshold = table->rehash_threshold;
  5870   pure->rehash_size = table->rehash_size;
  5871   pure->key_and_value = purecopy (table->key_and_value);
  5872   pure->test = pure_test;
  5873 
  5874   return pure;
  5875 }
  5876 
  5877 DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
  5878        doc: /* Make a copy of object OBJ in pure storage.
  5879 Recursively copies contents of vectors and cons cells.
  5880 Does not copy symbols.  Copies strings without text properties.  */)
  5881   (register Lisp_Object obj)
  5882 {
  5883   if (NILP (Vpurify_flag))
  5884     return obj;
  5885   else if (MARKERP (obj) || OVERLAYP (obj) || SYMBOLP (obj))
  5886     /* Can't purify those.  */
  5887     return obj;
  5888   else
  5889     return purecopy (obj);
  5890 }
  5891 
  5892 /* Pinned objects are marked before every GC cycle.  */
  5893 static struct pinned_object
  5894 {
  5895   Lisp_Object object;
  5896   struct pinned_object *next;
  5897 } *pinned_objects;
  5898 
  5899 static Lisp_Object
  5900 purecopy (Lisp_Object obj)
  5901 {
  5902   if (FIXNUMP (obj)
  5903       || (! SYMBOLP (obj) && PURE_P (XPNTR (obj)))
  5904       || SUBRP (obj))
  5905     return obj;    /* Already pure.  */
  5906 
  5907   if (STRINGP (obj) && XSTRING (obj)->u.s.intervals)
  5908     message_with_string ("Dropping text-properties while making string `%s' pure",
  5909                          obj, true);
  5910 
  5911   if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing.  */
  5912     {
  5913       Lisp_Object tmp = Fgethash (obj, Vpurify_flag, Qnil);
  5914       if (!NILP (tmp))
  5915         return tmp;
  5916     }
  5917 
  5918   if (CONSP (obj))
  5919     obj = pure_cons (XCAR (obj), XCDR (obj));
  5920   else if (FLOATP (obj))
  5921     obj = make_pure_float (XFLOAT_DATA (obj));
  5922   else if (STRINGP (obj))
  5923     obj = make_pure_string (SSDATA (obj), SCHARS (obj),
  5924                             SBYTES (obj),
  5925                             STRING_MULTIBYTE (obj));
  5926   else if (HASH_TABLE_P (obj))
  5927     {
  5928       struct Lisp_Hash_Table *table = XHASH_TABLE (obj);
  5929       /* Do not purify hash tables which haven't been defined with
  5930          :purecopy as non-nil or are weak - they aren't guaranteed to
  5931          not change.  */
  5932       if (!NILP (table->weak) || !table->purecopy)
  5933         {
  5934           /* Instead, add the hash table to the list of pinned objects,
  5935              so that it will be marked during GC.  */
  5936           struct pinned_object *o = xmalloc (sizeof *o);
  5937           o->object = obj;
  5938           o->next = pinned_objects;
  5939           pinned_objects = o;
  5940           return obj; /* Don't hash cons it.  */
  5941         }
  5942 
  5943       struct Lisp_Hash_Table *h = purecopy_hash_table (table);
  5944       XSET_HASH_TABLE (obj, h);
  5945     }
  5946   else if (COMPILEDP (obj) || VECTORP (obj) || RECORDP (obj))
  5947     {
  5948       struct Lisp_Vector *objp = XVECTOR (obj);
  5949       ptrdiff_t nbytes = vector_nbytes (objp);
  5950       struct Lisp_Vector *vec = pure_alloc (nbytes, Lisp_Vectorlike);
  5951       register ptrdiff_t i;
  5952       ptrdiff_t size = ASIZE (obj);
  5953       if (size & PSEUDOVECTOR_FLAG)
  5954         size &= PSEUDOVECTOR_SIZE_MASK;
  5955       memcpy (vec, objp, nbytes);
  5956       for (i = 0; i < size; i++)
  5957         vec->contents[i] = purecopy (vec->contents[i]);
  5958       /* Byte code strings must be pinned.  */
  5959       if (COMPILEDP (obj) && size >= 2 && STRINGP (vec->contents[1])
  5960           && !STRING_MULTIBYTE (vec->contents[1]))
  5961         pin_string (vec->contents[1]);
  5962       XSETVECTOR (obj, vec);
  5963     }
  5964   else if (BARE_SYMBOL_P (obj))
  5965     {
  5966       if (!XBARE_SYMBOL (obj)->u.s.pinned && !c_symbol_p (XBARE_SYMBOL (obj)))
  5967         { /* We can't purify them, but they appear in many pure objects.
  5968              Mark them as `pinned' so we know to mark them at every GC cycle.  */
  5969           XBARE_SYMBOL (obj)->u.s.pinned = true;
  5970           symbol_block_pinned = symbol_block;
  5971         }
  5972       /* Don't hash-cons it.  */
  5973       return obj;
  5974     }
  5975   else if (BIGNUMP (obj))
  5976     obj = make_pure_bignum (obj);
  5977   else
  5978     {
  5979       AUTO_STRING (fmt, "Don't know how to purify: %S");
  5980       Fsignal (Qerror, list1 (CALLN (Fformat, fmt, obj)));
  5981     }
  5982 
  5983   if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing.  */
  5984     Fputhash (obj, obj, Vpurify_flag);
  5985 
  5986   return obj;
  5987 }
  5988 
  5989 
  5990 
  5991 /***********************************************************************
  5992                           Protection from GC
  5993  ***********************************************************************/
  5994 
  5995 /* Put an entry in staticvec, pointing at the variable with address
  5996    VARADDRESS.  */
  5997 
  5998 void
  5999 staticpro (Lisp_Object const *varaddress)
  6000 {
  6001   for (int i = 0; i < staticidx; i++)
  6002     eassert (staticvec[i] != varaddress);
  6003   if (staticidx >= NSTATICS)
  6004     fatal ("NSTATICS too small; try increasing and recompiling Emacs.");
  6005   staticvec[staticidx++] = varaddress;
  6006 }
  6007 
  6008 
  6009 /***********************************************************************
  6010                           Protection from GC
  6011  ***********************************************************************/
  6012 
  6013 /* Temporarily prevent garbage collection.  Temporarily bump
  6014    consing_until_gc to speed up maybe_gc when GC is inhibited.  */
  6015 
  6016 static void
  6017 allow_garbage_collection (intmax_t consing)
  6018 {
  6019   consing_until_gc = consing - (HI_THRESHOLD - consing_until_gc);
  6020   garbage_collection_inhibited--;
  6021 }
  6022 
  6023 specpdl_ref
  6024 inhibit_garbage_collection (void)
  6025 {
  6026   specpdl_ref count = SPECPDL_INDEX ();
  6027   record_unwind_protect_intmax (allow_garbage_collection, consing_until_gc);
  6028   garbage_collection_inhibited++;
  6029   consing_until_gc = HI_THRESHOLD;
  6030   return count;
  6031 }
  6032 
  6033 /* Return the number of bytes in N objects each of size S, guarding
  6034    against overflow if size_t is narrower than byte_ct.  */
  6035 
  6036 static byte_ct
  6037 object_bytes (object_ct n, size_t s)
  6038 {
  6039   byte_ct b = s;
  6040   return n * b;
  6041 }
  6042 
  6043 /* Calculate total bytes of live objects.  */
  6044 
  6045 static byte_ct
  6046 total_bytes_of_live_objects (void)
  6047 {
  6048   byte_ct tot = 0;
  6049   tot += object_bytes (gcstat.total_conses, sizeof (struct Lisp_Cons));
  6050   tot += object_bytes (gcstat.total_symbols, sizeof (struct Lisp_Symbol));
  6051   tot += gcstat.total_string_bytes;
  6052   tot += object_bytes (gcstat.total_vector_slots, word_size);
  6053   tot += object_bytes (gcstat.total_floats, sizeof (struct Lisp_Float));
  6054   tot += object_bytes (gcstat.total_intervals, sizeof (struct interval));
  6055   tot += object_bytes (gcstat.total_strings, sizeof (struct Lisp_String));
  6056   return tot;
  6057 }
  6058 
  6059 #ifdef HAVE_WINDOW_SYSTEM
  6060 
  6061 /* Remove unmarked font-spec and font-entity objects from ENTRY, which is
  6062    (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...), and return changed entry.  */
  6063 
  6064 static Lisp_Object
  6065 compact_font_cache_entry (Lisp_Object entry)
  6066 {
  6067   Lisp_Object tail, *prev = &entry;
  6068 
  6069   for (tail = entry; CONSP (tail); tail = XCDR (tail))
  6070     {
  6071       bool drop = 0;
  6072       Lisp_Object obj = XCAR (tail);
  6073 
  6074       /* Consider OBJ if it is (font-spec . [font-entity font-entity ...]).  */
  6075       if (CONSP (obj) && GC_FONT_SPEC_P (XCAR (obj))
  6076           && !vectorlike_marked_p (&GC_XFONT_SPEC (XCAR (obj))->header)
  6077           /* Don't use VECTORP here, as that calls ASIZE, which could
  6078              hit assertion violation during GC.  */
  6079           && (VECTORLIKEP (XCDR (obj))
  6080               && ! (gc_asize (XCDR (obj)) & PSEUDOVECTOR_FLAG)))
  6081         {
  6082           ptrdiff_t i, size = gc_asize (XCDR (obj));
  6083           Lisp_Object obj_cdr = XCDR (obj);
  6084 
  6085           /* If font-spec is not marked, most likely all font-entities
  6086              are not marked too.  But we must be sure that nothing is
  6087              marked within OBJ before we really drop it.  */
  6088           for (i = 0; i < size; i++)
  6089             {
  6090               Lisp_Object objlist;
  6091 
  6092               if (vectorlike_marked_p (
  6093                     &GC_XFONT_ENTITY (AREF (obj_cdr, i))->header))
  6094                 break;
  6095 
  6096               objlist = AREF (AREF (obj_cdr, i), FONT_OBJLIST_INDEX);
  6097               for (; CONSP (objlist); objlist = XCDR (objlist))
  6098                 {
  6099                   Lisp_Object val = XCAR (objlist);
  6100                   struct font *font = GC_XFONT_OBJECT (val);
  6101 
  6102                   if (!NILP (AREF (val, FONT_TYPE_INDEX))
  6103                       && vectorlike_marked_p (&font->header))
  6104                     break;
  6105                 }
  6106               if (CONSP (objlist))
  6107                 {
  6108                   /* Found a marked font, bail out.  */
  6109                   break;
  6110                 }
  6111             }
  6112 
  6113           if (i == size)
  6114             {
  6115               /* No marked fonts were found, so this entire font
  6116                  entity can be dropped.  */
  6117               drop = 1;
  6118             }
  6119         }
  6120       if (drop)
  6121         *prev = XCDR (tail);
  6122       else
  6123         prev = xcdr_addr (tail);
  6124     }
  6125   return entry;
  6126 }
  6127 
  6128 /* Compact font caches on all terminals and mark
  6129    everything which is still here after compaction.  */
  6130 
  6131 static void
  6132 compact_font_caches (void)
  6133 {
  6134   struct terminal *t;
  6135 
  6136   for (t = terminal_list; t; t = t->next_terminal)
  6137     {
  6138       Lisp_Object cache = TERMINAL_FONT_CACHE (t);
  6139       /* Inhibit compacting the caches if the user so wishes.  Some of
  6140          the users don't mind a larger memory footprint, but do mind
  6141          slower redisplay.  */
  6142       if (!inhibit_compacting_font_caches
  6143           && CONSP (cache))
  6144         {
  6145           Lisp_Object entry;
  6146 
  6147           for (entry = XCDR (cache); CONSP (entry); entry = XCDR (entry))
  6148             XSETCAR (entry, compact_font_cache_entry (XCAR (entry)));
  6149         }
  6150       mark_object (cache);
  6151     }
  6152 }
  6153 
  6154 #else /* not HAVE_WINDOW_SYSTEM */
  6155 
  6156 #define compact_font_caches() (void)(0)
  6157 
  6158 #endif /* HAVE_WINDOW_SYSTEM */
  6159 
  6160 /* Remove (MARKER . DATA) entries with unmarked MARKER
  6161    from buffer undo LIST and return changed list.  */
  6162 
  6163 static Lisp_Object
  6164 compact_undo_list (Lisp_Object list)
  6165 {
  6166   Lisp_Object tail, *prev = &list;
  6167 
  6168   for (tail = list; CONSP (tail); tail = XCDR (tail))
  6169     {
  6170       if (CONSP (XCAR (tail))
  6171           && MARKERP (XCAR (XCAR (tail)))
  6172           && !vectorlike_marked_p (&XMARKER (XCAR (XCAR (tail)))->header))
  6173         *prev = XCDR (tail);
  6174       else
  6175         prev = xcdr_addr (tail);
  6176     }
  6177   return list;
  6178 }
  6179 
  6180 static void
  6181 mark_pinned_objects (void)
  6182 {
  6183   for (struct pinned_object *pobj = pinned_objects; pobj; pobj = pobj->next)
  6184     mark_object (pobj->object);
  6185 }
  6186 
  6187 #if defined HAVE_ANDROID && !defined (__clang__)
  6188 
  6189 /* The Android gcc is broken and needs the following version of
  6190    make_lisp_symbol.  Otherwise a mysterious ICE pops up.  */
  6191 
  6192 #define make_lisp_symbol android_make_lisp_symbol
  6193 
  6194 static Lisp_Object
  6195 android_make_lisp_symbol (struct Lisp_Symbol *sym)
  6196 {
  6197   intptr_t symoffset;
  6198 
  6199   symoffset = (intptr_t) sym;
  6200   INT_SUBTRACT_WRAPV (symoffset, (intptr_t) &lispsym,
  6201                       &symoffset);
  6202 
  6203   {
  6204     Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset);
  6205     return a;
  6206   }
  6207 }
  6208 
  6209 #endif
  6210 
  6211 static void
  6212 mark_pinned_symbols (void)
  6213 {
  6214   struct symbol_block *sblk;
  6215   int lim;
  6216   struct Lisp_Symbol *sym, *end;
  6217 
  6218   if (symbol_block_pinned == symbol_block)
  6219     lim = symbol_block_index;
  6220   else
  6221     lim = SYMBOL_BLOCK_SIZE;
  6222 
  6223   for (sblk = symbol_block_pinned; sblk; sblk = sblk->next)
  6224     {
  6225       sym = sblk->symbols, end = sym + lim;
  6226       for (; sym < end; ++sym)
  6227         if (sym->u.s.pinned)
  6228           mark_object (make_lisp_symbol (sym));
  6229 
  6230       lim = SYMBOL_BLOCK_SIZE;
  6231     }
  6232 }
  6233 
  6234 static void
  6235 visit_vectorlike_root (struct gc_root_visitor visitor,
  6236                        struct Lisp_Vector *ptr,
  6237                        enum gc_root_type type)
  6238 {
  6239   ptrdiff_t size = ptr->header.size;
  6240   ptrdiff_t i;
  6241 
  6242   if (size & PSEUDOVECTOR_FLAG)
  6243     size &= PSEUDOVECTOR_SIZE_MASK;
  6244   for (i = 0; i < size; i++)
  6245     visitor.visit (&ptr->contents[i], type, visitor.data);
  6246 }
  6247 
  6248 static void
  6249 visit_buffer_root (struct gc_root_visitor visitor,
  6250                    struct buffer *buffer,
  6251                    enum gc_root_type type)
  6252 {
  6253   /* Buffers that are roots don't have intervals, an undo list, or
  6254      other constructs that real buffers have.  */
  6255   eassert (buffer->base_buffer == NULL);
  6256   eassert (buffer->overlays == NULL);
  6257 
  6258   /* Visit the buffer-locals.  */
  6259   visit_vectorlike_root (visitor, (struct Lisp_Vector *) buffer, type);
  6260 }
  6261 
  6262 /* Visit GC roots stored in the Emacs data section.  Used by both core
  6263    GC and by the portable dumping code.
  6264 
  6265    There are other GC roots of course, but these roots are dynamic
  6266    runtime data structures that pdump doesn't care about and so we can
  6267    continue to mark those directly in garbage_collect.  */
  6268 void
  6269 visit_static_gc_roots (struct gc_root_visitor visitor)
  6270 {
  6271   visit_buffer_root (visitor,
  6272                      &buffer_defaults,
  6273                      GC_ROOT_BUFFER_LOCAL_DEFAULT);
  6274   visit_buffer_root (visitor,
  6275                      &buffer_local_symbols,
  6276                      GC_ROOT_BUFFER_LOCAL_NAME);
  6277 
  6278   for (int i = 0; i < ARRAYELTS (lispsym); i++)
  6279     {
  6280       Lisp_Object sptr = builtin_lisp_symbol (i);
  6281       visitor.visit (&sptr, GC_ROOT_C_SYMBOL, visitor.data);
  6282     }
  6283 
  6284   for (int i = 0; i < staticidx; i++)
  6285     visitor.visit (staticvec[i], GC_ROOT_STATICPRO, visitor.data);
  6286 }
  6287 
  6288 static void
  6289 mark_object_root_visitor (Lisp_Object const *root_ptr,
  6290                           enum gc_root_type type,
  6291                           void *data)
  6292 {
  6293   mark_object (*root_ptr);
  6294 }
  6295 
  6296 /* List of weak hash tables we found during marking the Lisp heap.
  6297    NULL on entry to garbage_collect and after it returns.  */
  6298 static struct Lisp_Hash_Table *weak_hash_tables;
  6299 
  6300 NO_INLINE /* For better stack traces */
  6301 static void
  6302 mark_and_sweep_weak_table_contents (void)
  6303 {
  6304   struct Lisp_Hash_Table *h;
  6305   bool marked;
  6306 
  6307   /* Mark all keys and values that are in use.  Keep on marking until
  6308      there is no more change.  This is necessary for cases like
  6309      value-weak table A containing an entry X -> Y, where Y is used in a
  6310      key-weak table B, Z -> Y.  If B comes after A in the list of weak
  6311      tables, X -> Y might be removed from A, although when looking at B
  6312      one finds that it shouldn't.  */
  6313   do
  6314     {
  6315       marked = false;
  6316       for (h = weak_hash_tables; h; h = h->next_weak)
  6317         marked |= sweep_weak_table (h, false);
  6318     }
  6319   while (marked);
  6320 
  6321   /* Remove hash table entries that aren't used.  */
  6322   while (weak_hash_tables)
  6323     {
  6324       h = weak_hash_tables;
  6325       weak_hash_tables = h->next_weak;
  6326       h->next_weak = NULL;
  6327       sweep_weak_table (h, true);
  6328     }
  6329 }
  6330 
  6331 /* Return the number of bytes to cons between GCs, given THRESHOLD and
  6332    PERCENTAGE.  When calculating a threshold based on PERCENTAGE,
  6333    assume SINCE_GC bytes have been allocated since the most recent GC.
  6334    The returned value is positive and no greater than HI_THRESHOLD.  */
  6335 static EMACS_INT
  6336 consing_threshold (intmax_t threshold, Lisp_Object percentage,
  6337                    intmax_t since_gc)
  6338 {
  6339   if (!NILP (Vmemory_full))
  6340     return memory_full_cons_threshold;
  6341   else
  6342     {
  6343       threshold = max (threshold, GC_DEFAULT_THRESHOLD / 10);
  6344       if (FLOATP (percentage))
  6345         {
  6346           double tot = (XFLOAT_DATA (percentage)
  6347                         * (total_bytes_of_live_objects () + since_gc));
  6348           if (threshold < tot)
  6349             {
  6350               if (tot < HI_THRESHOLD)
  6351                 return tot;
  6352               else
  6353                 return HI_THRESHOLD;
  6354             }
  6355         }
  6356       return min (threshold, HI_THRESHOLD);
  6357     }
  6358 }
  6359 
  6360 /* Adjust consing_until_gc and gc_threshold, given THRESHOLD and PERCENTAGE.
  6361    Return the updated consing_until_gc.  */
  6362 
  6363 static EMACS_INT
  6364 bump_consing_until_gc (intmax_t threshold, Lisp_Object percentage)
  6365 {
  6366   /* Guesstimate that half the bytes allocated since the most
  6367      recent GC are still in use.  */
  6368   EMACS_INT since_gc = (gc_threshold - consing_until_gc) >> 1;
  6369   EMACS_INT new_gc_threshold = consing_threshold (threshold, percentage,
  6370                                                   since_gc);
  6371   consing_until_gc += new_gc_threshold - gc_threshold;
  6372   gc_threshold = new_gc_threshold;
  6373   return consing_until_gc;
  6374 }
  6375 
  6376 /* Watch changes to gc-cons-threshold.  */
  6377 static Lisp_Object
  6378 watch_gc_cons_threshold (Lisp_Object symbol, Lisp_Object newval,
  6379                          Lisp_Object operation, Lisp_Object where)
  6380 {
  6381   intmax_t threshold;
  6382   if (! (INTEGERP (newval) && integer_to_intmax (newval, &threshold)))
  6383     return Qnil;
  6384   bump_consing_until_gc (threshold, Vgc_cons_percentage);
  6385   return Qnil;
  6386 }
  6387 
  6388 /* Watch changes to gc-cons-percentage.  */
  6389 static Lisp_Object
  6390 watch_gc_cons_percentage (Lisp_Object symbol, Lisp_Object newval,
  6391                           Lisp_Object operation, Lisp_Object where)
  6392 {
  6393   bump_consing_until_gc (gc_cons_threshold, newval);
  6394   return Qnil;
  6395 }
  6396 
  6397 /* It may be time to collect garbage.  Recalculate consing_until_gc,
  6398    since it might depend on current usage, and do the garbage
  6399    collection if the recalculation says so.  */
  6400 void
  6401 maybe_garbage_collect (void)
  6402 {
  6403   if (bump_consing_until_gc (gc_cons_threshold, Vgc_cons_percentage) < 0)
  6404     garbage_collect ();
  6405 }
  6406 
  6407 static inline bool mark_stack_empty_p (void);
  6408 
  6409 /* Subroutine of Fgarbage_collect that does most of the work.  */
  6410 void
  6411 garbage_collect (void)
  6412 {
  6413   Lisp_Object tail, buffer;
  6414   char stack_top_variable;
  6415   bool message_p;
  6416   specpdl_ref count = SPECPDL_INDEX ();
  6417   struct timespec start;
  6418 
  6419   eassert (weak_hash_tables == NULL);
  6420 
  6421   if (garbage_collection_inhibited)
  6422     return;
  6423 
  6424   eassert(mark_stack_empty_p ());
  6425 
  6426   /* Record this function, so it appears on the profiler's backtraces.  */
  6427   record_in_backtrace (QAutomatic_GC, 0, 0);
  6428 
  6429   /* Don't keep undo information around forever.
  6430      Do this early on, so it is no problem if the user quits.  */
  6431   FOR_EACH_LIVE_BUFFER (tail, buffer)
  6432     compact_buffer (XBUFFER (buffer));
  6433 
  6434   byte_ct tot_before = (profiler_memory_running
  6435                         ? total_bytes_of_live_objects ()
  6436                         : (byte_ct) -1);
  6437 
  6438   start = current_timespec ();
  6439 
  6440   /* In case user calls debug_print during GC,
  6441      don't let that cause a recursive GC.  */
  6442   consing_until_gc = HI_THRESHOLD;
  6443 
  6444   /* Save what's currently displayed in the echo area.  Don't do that
  6445      if we are GC'ing because we've run out of memory, since
  6446      push_message will cons, and we might have no memory for that.  */
  6447   if (NILP (Vmemory_full))
  6448     {
  6449       message_p = push_message ();
  6450       record_unwind_protect_void (pop_message_unwind);
  6451     }
  6452   else
  6453     message_p = false;
  6454 
  6455   /* Save a copy of the contents of the stack, for debugging.  */
  6456 #if MAX_SAVE_STACK > 0
  6457   if (NILP (Vpurify_flag))
  6458     {
  6459       char const *stack;
  6460       ptrdiff_t stack_size;
  6461       if (&stack_top_variable < stack_bottom)
  6462         {
  6463           stack = &stack_top_variable;
  6464           stack_size = stack_bottom - &stack_top_variable;
  6465         }
  6466       else
  6467         {
  6468           stack = stack_bottom;
  6469           stack_size = &stack_top_variable - stack_bottom;
  6470         }
  6471       if (stack_size <= MAX_SAVE_STACK)
  6472         {
  6473           if (stack_copy_size < stack_size)
  6474             {
  6475               stack_copy = xrealloc (stack_copy, stack_size);
  6476               stack_copy_size = stack_size;
  6477             }
  6478           no_sanitize_memcpy (stack_copy, stack, stack_size);
  6479         }
  6480     }
  6481 #endif /* MAX_SAVE_STACK > 0 */
  6482 
  6483   if (garbage_collection_messages)
  6484     message1_nolog ("Garbage collecting...");
  6485 
  6486   block_input ();
  6487 
  6488   shrink_regexp_cache ();
  6489 
  6490   gc_in_progress = 1;
  6491 
  6492   /* Mark all the special slots that serve as the roots of accessibility.  */
  6493 
  6494   struct gc_root_visitor visitor = { .visit = mark_object_root_visitor };
  6495   visit_static_gc_roots (visitor);
  6496 
  6497   mark_pinned_objects ();
  6498   mark_pinned_symbols ();
  6499   mark_lread ();
  6500   mark_terminals ();
  6501   mark_kboards ();
  6502   mark_threads ();
  6503 #ifdef HAVE_PGTK
  6504   mark_pgtkterm ();
  6505 #endif
  6506 
  6507 #ifdef USE_GTK
  6508   xg_mark_data ();
  6509 #endif
  6510 
  6511 #ifdef HAVE_HAIKU
  6512   mark_haiku_display ();
  6513 #endif
  6514 
  6515 #ifdef HAVE_WINDOW_SYSTEM
  6516   mark_fringe_data ();
  6517 #endif
  6518 
  6519 #ifdef HAVE_X_WINDOWS
  6520   mark_xterm ();
  6521   mark_xselect ();
  6522 #endif
  6523 
  6524 #ifdef HAVE_ANDROID
  6525   mark_androidterm ();
  6526 #ifndef ANDROID_STUBIFY
  6527   mark_sfntfont ();
  6528 #endif
  6529 #endif
  6530 
  6531 #ifdef HAVE_NS
  6532   mark_nsterm ();
  6533 #endif
  6534 
  6535   /* Everything is now marked, except for the data in font caches,
  6536      undo lists, and finalizers.  The first two are compacted by
  6537      removing an items which aren't reachable otherwise.  */
  6538 
  6539   compact_font_caches ();
  6540 
  6541   FOR_EACH_LIVE_BUFFER (tail, buffer)
  6542     {
  6543       struct buffer *nextb = XBUFFER (buffer);
  6544       if (!EQ (BVAR (nextb, undo_list), Qt))
  6545         bset_undo_list (nextb, compact_undo_list (BVAR (nextb, undo_list)));
  6546       /* Now that we have stripped the elements that need not be
  6547          in the undo_list any more, we can finally mark the list.  */
  6548       mark_object (BVAR (nextb, undo_list));
  6549     }
  6550 
  6551   /* Now pre-sweep finalizers.  Here, we add any unmarked finalizers
  6552      to doomed_finalizers so we can run their associated functions
  6553      after GC.  It's important to scan finalizers at this stage so
  6554      that we can be sure that unmarked finalizers are really
  6555      unreachable except for references from their associated functions
  6556      and from other finalizers.  */
  6557 
  6558   queue_doomed_finalizers (&doomed_finalizers, &finalizers);
  6559   mark_finalizer_list (&doomed_finalizers);
  6560 
  6561   /* Must happen after all other marking and before gc_sweep.  */
  6562   mark_and_sweep_weak_table_contents ();
  6563   eassert (weak_hash_tables == NULL);
  6564 
  6565   eassert (mark_stack_empty_p ());
  6566 
  6567   gc_sweep ();
  6568 
  6569   unmark_main_thread ();
  6570 
  6571   gc_in_progress = 0;
  6572 
  6573   consing_until_gc = gc_threshold
  6574     = consing_threshold (gc_cons_threshold, Vgc_cons_percentage, 0);
  6575 
  6576   /* Unblock *after* re-setting `consing_until_gc` in case `unblock_input`
  6577      signals an error (see bug#43389).  */
  6578   unblock_input ();
  6579 
  6580   if (garbage_collection_messages && NILP (Vmemory_full))
  6581     {
  6582       if (message_p || minibuf_level > 0)
  6583         restore_message ();
  6584       else
  6585         message1_nolog ("Garbage collecting...done");
  6586     }
  6587 
  6588   unbind_to (count, Qnil);
  6589 
  6590   /* GC is complete: now we can run our finalizer callbacks.  */
  6591   run_finalizers (&doomed_finalizers);
  6592 
  6593 #ifdef HAVE_WINDOW_SYSTEM
  6594   /* Eject unused image cache entries.  */
  6595   image_prune_animation_caches (false);
  6596 #endif
  6597 
  6598   if (!NILP (Vpost_gc_hook))
  6599     {
  6600       specpdl_ref gc_count = inhibit_garbage_collection ();
  6601       safe_run_hooks (Qpost_gc_hook);
  6602       unbind_to (gc_count, Qnil);
  6603     }
  6604 
  6605   /* Accumulate statistics.  */
  6606   if (FLOATP (Vgc_elapsed))
  6607     {
  6608       static struct timespec gc_elapsed;
  6609       gc_elapsed = timespec_add (gc_elapsed,
  6610                                  timespec_sub (current_timespec (), start));
  6611       Vgc_elapsed = make_float (timespectod (gc_elapsed));
  6612     }
  6613 
  6614   gcs_done++;
  6615 
  6616   /* Collect profiling data.  */
  6617   if (tot_before != (byte_ct) -1)
  6618     {
  6619       byte_ct tot_after = total_bytes_of_live_objects ();
  6620       if (tot_after < tot_before)
  6621         malloc_probe (min (tot_before - tot_after, SIZE_MAX));
  6622     }
  6623 }
  6624 
  6625 DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
  6626        doc: /* Reclaim storage for Lisp objects no longer needed.
  6627 Garbage collection happens automatically if you cons more than
  6628 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
  6629 `garbage-collect' normally returns a list with info on amount of space in use,
  6630 where each entry has the form (NAME SIZE USED FREE), where:
  6631 - NAME is a symbol describing the kind of objects this entry represents,
  6632 - SIZE is the number of bytes used by each one,
  6633 - USED is the number of those objects that were found live in the heap,
  6634 - FREE is the number of those objects that are not live but that Emacs
  6635   keeps around for future allocations (maybe because it does not know how
  6636   to return them to the OS).
  6637 
  6638 However, if there was overflow in pure space, and Emacs was dumped
  6639 using the \"unexec\" method, `garbage-collect' returns nil, because
  6640 real GC can't be done.
  6641 
  6642 Note that calling this function does not guarantee that absolutely all
  6643 unreachable objects will be garbage-collected.  Emacs uses a
  6644 mark-and-sweep garbage collector, but is conservative when it comes to
  6645 collecting objects in some circumstances.
  6646 
  6647 For further details, see Info node `(elisp)Garbage Collection'.  */)
  6648   (void)
  6649 {
  6650   if (garbage_collection_inhibited)
  6651     return Qnil;
  6652 
  6653   specpdl_ref count = SPECPDL_INDEX ();
  6654   specbind (Qsymbols_with_pos_enabled, Qnil);
  6655   garbage_collect ();
  6656   unbind_to (count, Qnil);
  6657   struct gcstat gcst = gcstat;
  6658 
  6659   Lisp_Object total[] = {
  6660     list4 (Qconses, make_fixnum (sizeof (struct Lisp_Cons)),
  6661            make_int (gcst.total_conses),
  6662            make_int (gcst.total_free_conses)),
  6663     list4 (Qsymbols, make_fixnum (sizeof (struct Lisp_Symbol)),
  6664            make_int (gcst.total_symbols),
  6665            make_int (gcst.total_free_symbols)),
  6666     list4 (Qstrings, make_fixnum (sizeof (struct Lisp_String)),
  6667            make_int (gcst.total_strings),
  6668            make_int (gcst.total_free_strings)),
  6669     list3 (Qstring_bytes, make_fixnum (1),
  6670            make_int (gcst.total_string_bytes)),
  6671     list3 (Qvectors,
  6672            make_fixnum (header_size + sizeof (Lisp_Object)),
  6673            make_int (gcst.total_vectors)),
  6674     list4 (Qvector_slots, make_fixnum (word_size),
  6675            make_int (gcst.total_vector_slots),
  6676            make_int (gcst.total_free_vector_slots)),
  6677     list4 (Qfloats, make_fixnum (sizeof (struct Lisp_Float)),
  6678            make_int (gcst.total_floats),
  6679            make_int (gcst.total_free_floats)),
  6680     list4 (Qintervals, make_fixnum (sizeof (struct interval)),
  6681            make_int (gcst.total_intervals),
  6682            make_int (gcst.total_free_intervals)),
  6683     list3 (Qbuffers, make_fixnum (sizeof (struct buffer)),
  6684            make_int (gcst.total_buffers)),
  6685 
  6686 #ifdef DOUG_LEA_MALLOC
  6687     list4 (Qheap, make_fixnum (1024),
  6688            make_int ((mallinfo ().uordblks + 1023) >> 10),
  6689            make_int ((mallinfo ().fordblks + 1023) >> 10)),
  6690 #endif
  6691   };
  6692   return CALLMANY (Flist, total);
  6693 }
  6694 
  6695 DEFUN ("garbage-collect-maybe", Fgarbage_collect_maybe,
  6696 Sgarbage_collect_maybe, 1, 1, 0,
  6697        doc: /* Call `garbage-collect' if enough allocation happened.
  6698 FACTOR determines what "enough" means here:
  6699 If FACTOR is a positive number N, it means to run GC if more than
  6700 1/Nth of the allocations needed to trigger automatic allocation took
  6701 place.
  6702 Therefore, as N gets higher, this is more likely to perform a GC.
  6703 Returns non-nil if GC happened, and nil otherwise.  */)
  6704   (Lisp_Object factor)
  6705 {
  6706   CHECK_FIXNAT (factor);
  6707   EMACS_INT fact = XFIXNAT (factor);
  6708 
  6709   EMACS_INT since_gc = gc_threshold - consing_until_gc;
  6710   if (fact >= 1 && since_gc > gc_threshold / fact)
  6711     {
  6712       garbage_collect ();
  6713       return Qt;
  6714     }
  6715   else
  6716     return Qnil;
  6717 }
  6718 
  6719 /* Mark Lisp objects in glyph matrix MATRIX.  Currently the
  6720    only interesting objects referenced from glyphs are strings.  */
  6721 
  6722 static void
  6723 mark_glyph_matrix (struct glyph_matrix *matrix)
  6724 {
  6725   struct glyph_row *row = matrix->rows;
  6726   struct glyph_row *end = row + matrix->nrows;
  6727 
  6728   for (; row < end; ++row)
  6729     if (row->enabled_p)
  6730       {
  6731         int area;
  6732         for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
  6733           {
  6734             struct glyph *glyph = row->glyphs[area];
  6735             struct glyph *end_glyph = glyph + row->used[area];
  6736 
  6737             for (; glyph < end_glyph; ++glyph)
  6738               if (STRINGP (glyph->object)
  6739                   && !string_marked_p (XSTRING (glyph->object)))
  6740                 mark_object (glyph->object);
  6741           }
  6742       }
  6743 }
  6744 
  6745 /* Whether to remember a few of the last marked values for debugging.  */
  6746 #define GC_REMEMBER_LAST_MARKED 0
  6747 
  6748 #if GC_REMEMBER_LAST_MARKED
  6749 enum { LAST_MARKED_SIZE = 1 << 9 }; /* Must be a power of 2.  */
  6750 Lisp_Object last_marked[LAST_MARKED_SIZE] EXTERNALLY_VISIBLE;
  6751 static int last_marked_index;
  6752 #endif
  6753 
  6754 /* Whether to enable the mark_object_loop_halt debugging feature.  */
  6755 #define GC_CDR_COUNT 0
  6756 
  6757 #if GC_CDR_COUNT
  6758 /* For debugging--call abort when we cdr down this many
  6759    links of a list, in mark_object.  In debugging,
  6760    the call to abort will hit a breakpoint.
  6761    Normally this is zero and the check never goes off.  */
  6762 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE;
  6763 #endif
  6764 
  6765 static void
  6766 mark_vectorlike (union vectorlike_header *header)
  6767 {
  6768   struct Lisp_Vector *ptr = (struct Lisp_Vector *) header;
  6769   ptrdiff_t size = ptr->header.size;
  6770 
  6771   eassert (!vector_marked_p (ptr));
  6772 
  6773   /* Bool vectors have a different case in mark_object.  */
  6774   eassert (PSEUDOVECTOR_TYPE (ptr) != PVEC_BOOL_VECTOR);
  6775 
  6776   set_vector_marked (ptr); /* Else mark it.  */
  6777   if (size & PSEUDOVECTOR_FLAG)
  6778     size &= PSEUDOVECTOR_SIZE_MASK;
  6779 
  6780   /* Note that this size is not the memory-footprint size, but only
  6781      the number of Lisp_Object fields that we should trace.
  6782      The distinction is used e.g. by Lisp_Process which places extra
  6783      non-Lisp_Object fields at the end of the structure...  */
  6784   mark_objects (ptr->contents, size);
  6785 }
  6786 
  6787 /* Like mark_vectorlike but optimized for char-tables (and
  6788    sub-char-tables) assuming that the contents are mostly integers or
  6789    symbols.  */
  6790 
  6791 static void
  6792 mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype)
  6793 {
  6794   int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
  6795   /* Consult the Lisp_Sub_Char_Table layout before changing this.  */
  6796   int i, idx = (pvectype == PVEC_SUB_CHAR_TABLE ? SUB_CHAR_TABLE_OFFSET : 0);
  6797 
  6798   eassert (!vector_marked_p (ptr));
  6799   set_vector_marked (ptr);
  6800   for (i = idx; i < size; i++)
  6801     {
  6802       Lisp_Object val = ptr->contents[i];
  6803 
  6804       if (FIXNUMP (val) ||
  6805           (BARE_SYMBOL_P (val) && symbol_marked_p (XBARE_SYMBOL (val))))
  6806         continue;
  6807       if (SUB_CHAR_TABLE_P (val))
  6808         {
  6809           if (! vector_marked_p (XVECTOR (val)))
  6810             mark_char_table (XVECTOR (val), PVEC_SUB_CHAR_TABLE);
  6811         }
  6812       else
  6813         mark_object (val);
  6814     }
  6815 }
  6816 
  6817 /* Mark the chain of overlays starting at PTR.  */
  6818 
  6819 static void
  6820 mark_overlay (struct Lisp_Overlay *ov)
  6821 {
  6822   /* We don't mark the `itree_node` object, because it is managed manually
  6823      rather than by the GC.  */
  6824   eassert (BASE_EQ (ov->interval->data, make_lisp_ptr (ov, Lisp_Vectorlike)));
  6825   set_vectorlike_marked (&ov->header);
  6826   mark_object (ov->plist);
  6827 }
  6828 
  6829 /* Mark the overlay subtree rooted at NODE.  */
  6830 
  6831 static void
  6832 mark_overlays (struct itree_node *node)
  6833 {
  6834   if (node == NULL)
  6835     return;
  6836   mark_object (node->data);
  6837   mark_overlays (node->left);
  6838   mark_overlays (node->right);
  6839 }
  6840 
  6841 /* Mark Lisp_Objects and special pointers in BUFFER.  */
  6842 
  6843 static void
  6844 mark_buffer (struct buffer *buffer)
  6845 {
  6846   /* This is handled much like other pseudovectors...  */
  6847   mark_vectorlike (&buffer->header);
  6848 
  6849   /* ...but there are some buffer-specific things.  */
  6850 
  6851   mark_interval_tree (buffer_intervals (buffer));
  6852 
  6853   /* For now, we just don't mark the undo_list.  It's done later in
  6854      a special way just before the sweep phase, and after stripping
  6855      some of its elements that are not needed any more.
  6856      Note: this later processing is only done for live buffers, so
  6857      for dead buffers, the undo_list should be nil (set by Fkill_buffer),
  6858      but just to be on the safe side, we mark it here.  */
  6859   if (!BUFFER_LIVE_P (buffer))
  6860       mark_object (BVAR (buffer, undo_list));
  6861 
  6862   if (!itree_empty_p (buffer->overlays))
  6863     mark_overlays (buffer->overlays->root);
  6864 
  6865   /* If this is an indirect buffer, mark its base buffer.  */
  6866   if (buffer->base_buffer &&
  6867       !vectorlike_marked_p (&buffer->base_buffer->header))
  6868     mark_buffer (buffer->base_buffer);
  6869 }
  6870 
  6871 /* Mark Lisp faces in the face cache C.  */
  6872 
  6873 NO_INLINE /* To reduce stack depth in mark_object.  */
  6874 static void
  6875 mark_face_cache (struct face_cache *c)
  6876 {
  6877   if (c)
  6878     {
  6879       for (int i = 0; i < c->used; i++)
  6880         {
  6881           struct face *face = FACE_FROM_ID_OR_NULL (c->f, i);
  6882 
  6883           if (face)
  6884             {
  6885               if (face->font && !vectorlike_marked_p (&face->font->header))
  6886                 mark_vectorlike (&face->font->header);
  6887 
  6888               mark_objects (face->lface, LFACE_VECTOR_SIZE);
  6889             }
  6890         }
  6891     }
  6892 }
  6893 
  6894 NO_INLINE /* To reduce stack depth in mark_object.  */
  6895 static void
  6896 mark_localized_symbol (struct Lisp_Symbol *ptr)
  6897 {
  6898   struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
  6899   Lisp_Object where = blv->where;
  6900   /* If the value is set up for a killed buffer restore its global binding.  */
  6901   if ((BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where))))
  6902     swap_in_global_binding (ptr);
  6903   mark_object (blv->where);
  6904   mark_object (blv->valcell);
  6905   mark_object (blv->defcell);
  6906 }
  6907 
  6908 /* Remove killed buffers or items whose car is a killed buffer from
  6909    LIST, and mark other items.  Return changed LIST, which is marked.  */
  6910 
  6911 static Lisp_Object
  6912 mark_discard_killed_buffers (Lisp_Object list)
  6913 {
  6914   Lisp_Object tail, *prev = &list;
  6915 
  6916   for (tail = list; CONSP (tail) && !cons_marked_p (XCONS (tail));
  6917        tail = XCDR (tail))
  6918     {
  6919       Lisp_Object tem = XCAR (tail);
  6920       if (CONSP (tem))
  6921         tem = XCAR (tem);
  6922       if (BUFFERP (tem) && !BUFFER_LIVE_P (XBUFFER (tem)))
  6923         *prev = XCDR (tail);
  6924       else
  6925         {
  6926           set_cons_marked (XCONS (tail));
  6927           mark_object (XCAR (tail));
  6928           prev = xcdr_addr (tail);
  6929         }
  6930     }
  6931   mark_object (tail);
  6932   return list;
  6933 }
  6934 
  6935 static void
  6936 mark_frame (struct Lisp_Vector *ptr)
  6937 {
  6938   struct frame *f = (struct frame *) ptr;
  6939 #ifdef HAVE_TEXT_CONVERSION
  6940   struct text_conversion_action *tem;
  6941 #endif
  6942 
  6943 
  6944   mark_vectorlike (&ptr->header);
  6945   mark_face_cache (f->face_cache);
  6946 #ifdef HAVE_WINDOW_SYSTEM
  6947   if (FRAME_WINDOW_P (f) && FRAME_OUTPUT_DATA (f))
  6948     {
  6949       struct font *font = FRAME_FONT (f);
  6950 
  6951       if (font && !vectorlike_marked_p (&font->header))
  6952         mark_vectorlike (&font->header);
  6953     }
  6954 #endif
  6955 
  6956 #ifdef HAVE_TEXT_CONVERSION
  6957   mark_object (f->conversion.compose_region_start);
  6958   mark_object (f->conversion.compose_region_end);
  6959   mark_object (f->conversion.compose_region_overlay);
  6960 
  6961   for (tem = f->conversion.actions; tem; tem = tem->next)
  6962     mark_object (tem->data);
  6963 #endif
  6964 }
  6965 
  6966 static void
  6967 mark_window (struct Lisp_Vector *ptr)
  6968 {
  6969   struct window *w = (struct window *) ptr;
  6970 
  6971   mark_vectorlike (&ptr->header);
  6972 
  6973   /* Mark glyph matrices, if any.  Marking window
  6974      matrices is sufficient because frame matrices
  6975      use the same glyph memory.  */
  6976   if (w->current_matrix)
  6977     {
  6978       mark_glyph_matrix (w->current_matrix);
  6979       mark_glyph_matrix (w->desired_matrix);
  6980     }
  6981 
  6982   /* Filter out killed buffers from both buffer lists
  6983      in attempt to help GC to reclaim killed buffers faster.
  6984      We can do it elsewhere for live windows, but this is the
  6985      best place to do it for dead windows.  */
  6986   wset_prev_buffers
  6987     (w, mark_discard_killed_buffers (w->prev_buffers));
  6988   wset_next_buffers
  6989     (w, mark_discard_killed_buffers (w->next_buffers));
  6990 }
  6991 
  6992 /* Entry of the mark stack.  */
  6993 struct mark_entry
  6994 {
  6995   ptrdiff_t n;                  /* number of values, or 0 if a single value */
  6996   union {
  6997     Lisp_Object value;          /* when n = 0 */
  6998     Lisp_Object *values;        /* when n > 0 */
  6999   } u;
  7000 };
  7001 
  7002 /* This stack is used during marking for traversing data structures without
  7003    using C recursion.  */
  7004 struct mark_stack
  7005 {
  7006   struct mark_entry *stack;     /* base of stack */
  7007   ptrdiff_t size;               /* allocated size in entries */
  7008   ptrdiff_t sp;                 /* current number of entries */
  7009 };
  7010 
  7011 static struct mark_stack mark_stk = {NULL, 0, 0};
  7012 
  7013 static inline bool
  7014 mark_stack_empty_p (void)
  7015 {
  7016   return mark_stk.sp <= 0;
  7017 }
  7018 
  7019 /* Pop and return a value from the mark stack (which must be nonempty).  */
  7020 static inline Lisp_Object
  7021 mark_stack_pop (void)
  7022 {
  7023   eassume (!mark_stack_empty_p ());
  7024   struct mark_entry *e = &mark_stk.stack[mark_stk.sp - 1];
  7025   if (e->n == 0)                /* single value */
  7026     {
  7027       --mark_stk.sp;
  7028       return e->u.value;
  7029     }
  7030   /* Array of values: pop them left to right, which seems to be slightly
  7031      faster than right to left.  */
  7032   e->n--;
  7033   if (e->n == 0)
  7034     --mark_stk.sp;              /* last value consumed */
  7035   return (++e->u.values)[-1];
  7036 }
  7037 
  7038 NO_INLINE static void
  7039 grow_mark_stack (void)
  7040 {
  7041   struct mark_stack *ms = &mark_stk;
  7042   eassert (ms->sp == ms->size);
  7043   ptrdiff_t min_incr = ms->sp == 0 ? 8192 : 1;
  7044   ms->stack = xpalloc (ms->stack, &ms->size, min_incr, -1, sizeof *ms->stack);
  7045   eassert (ms->sp < ms->size);
  7046 }
  7047 
  7048 /* Push VALUE onto the mark stack.  */
  7049 static inline void
  7050 mark_stack_push_value (Lisp_Object value)
  7051 {
  7052   if (mark_stk.sp >= mark_stk.size)
  7053     grow_mark_stack ();
  7054   mark_stk.stack[mark_stk.sp++] = (struct mark_entry){.n = 0, .u.value = value};
  7055 }
  7056 
  7057 /* Push the N values at VALUES onto the mark stack.  */
  7058 static inline void
  7059 mark_stack_push_values (Lisp_Object *values, ptrdiff_t n)
  7060 {
  7061   eassume (n >= 0);
  7062   if (n == 0)
  7063     return;
  7064   if (mark_stk.sp >= mark_stk.size)
  7065     grow_mark_stack ();
  7066   mark_stk.stack[mark_stk.sp++] = (struct mark_entry){.n = n,
  7067                                                       .u.values = values};
  7068 }
  7069 
  7070 /* Traverse and mark objects on the mark stack above BASE_SP.
  7071 
  7072    Traversal is depth-first using the mark stack for most common
  7073    object types.  Recursion is used for other types, in the hope that
  7074    they are rare enough that C stack usage is kept low.  */
  7075 static void
  7076 process_mark_stack (ptrdiff_t base_sp)
  7077 {
  7078 #if GC_CHECK_MARKED_OBJECTS
  7079   struct mem_node *m = NULL;
  7080 #endif
  7081 #if GC_CDR_COUNT
  7082   ptrdiff_t cdr_count = 0;
  7083 #endif
  7084 
  7085   eassume (mark_stk.sp >= base_sp && base_sp >= 0);
  7086 
  7087   while (mark_stk.sp > base_sp)
  7088     {
  7089       Lisp_Object obj = mark_stack_pop ();
  7090     mark_obj: ;
  7091       void *po = XPNTR (obj);
  7092       if (PURE_P (po))
  7093         continue;
  7094 
  7095 #if GC_REMEMBER_LAST_MARKED
  7096       last_marked[last_marked_index++] = obj;
  7097       last_marked_index &= LAST_MARKED_SIZE - 1;
  7098 #endif
  7099 
  7100       /* Perform some sanity checks on the objects marked here.  Abort if
  7101          we encounter an object we know is bogus.  This increases GC time
  7102          by ~80%.  */
  7103 #if GC_CHECK_MARKED_OBJECTS
  7104 
  7105       /* Check that the object pointed to by PO is known to be a Lisp
  7106          structure allocated from the heap.  */
  7107 #define CHECK_ALLOCATED()                       \
  7108       do {                                      \
  7109         if (pdumper_object_p (po))              \
  7110           {                                     \
  7111             if (!pdumper_object_p_precise (po)) \
  7112               emacs_abort ();                   \
  7113             break;                              \
  7114           }                                     \
  7115         m = mem_find (po);                      \
  7116         if (m == MEM_NIL)                       \
  7117           emacs_abort ();                       \
  7118       } while (0)
  7119 
  7120       /* Check that the object pointed to by PO is live, using predicate
  7121          function LIVEP.  */
  7122 #define CHECK_LIVE(LIVEP, MEM_TYPE)                     \
  7123       do {                                              \
  7124         if (pdumper_object_p (po))                      \
  7125           break;                                        \
  7126         if (! (m->type == MEM_TYPE && LIVEP (m, po)))   \
  7127           emacs_abort ();                               \
  7128       } while (0)
  7129 
  7130       /* Check both of the above conditions, for non-symbols.  */
  7131 #define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE)       \
  7132       do {                                              \
  7133         CHECK_ALLOCATED ();                             \
  7134         CHECK_LIVE (LIVEP, MEM_TYPE);                   \
  7135       } while (false)
  7136 
  7137       /* Check both of the above conditions, for symbols.  */
  7138 #define CHECK_ALLOCATED_AND_LIVE_SYMBOL()                       \
  7139       do {                                                      \
  7140         if (!c_symbol_p (ptr))                                  \
  7141           {                                                     \
  7142             CHECK_ALLOCATED ();                                 \
  7143             CHECK_LIVE (live_symbol_p, MEM_TYPE_SYMBOL);        \
  7144           }                                                     \
  7145       } while (false)
  7146 
  7147 #else /* not GC_CHECK_MARKED_OBJECTS */
  7148 
  7149 #define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE)       ((void) 0)
  7150 #define CHECK_ALLOCATED_AND_LIVE_SYMBOL()               ((void) 0)
  7151 
  7152 #endif /* not GC_CHECK_MARKED_OBJECTS */
  7153 
  7154       switch (XTYPE (obj))
  7155         {
  7156         case Lisp_String:
  7157           {
  7158             register struct Lisp_String *ptr = XSTRING (obj);
  7159             if (string_marked_p (ptr))
  7160               break;
  7161             CHECK_ALLOCATED_AND_LIVE (live_string_p, MEM_TYPE_STRING);
  7162             set_string_marked (ptr);
  7163             mark_interval_tree (ptr->u.s.intervals);
  7164 #ifdef GC_CHECK_STRING_BYTES
  7165             /* Check that the string size recorded in the string is the
  7166                same as the one recorded in the sdata structure.  */
  7167             string_bytes (ptr);
  7168 #endif /* GC_CHECK_STRING_BYTES */
  7169           }
  7170           break;
  7171 
  7172         case Lisp_Vectorlike:
  7173           {
  7174             register struct Lisp_Vector *ptr = XVECTOR (obj);
  7175 
  7176             if (vector_marked_p (ptr))
  7177               break;
  7178 
  7179             enum pvec_type pvectype
  7180               = PSEUDOVECTOR_TYPE (ptr);
  7181 
  7182 #ifdef GC_CHECK_MARKED_OBJECTS
  7183             if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po))
  7184               {
  7185                 m = mem_find (po);
  7186                 if (m == MEM_NIL)
  7187                   emacs_abort ();
  7188                 if (m->type == MEM_TYPE_VECTORLIKE)
  7189                   CHECK_LIVE (live_large_vector_p, MEM_TYPE_VECTORLIKE);
  7190                 else
  7191                   CHECK_LIVE (live_small_vector_p, MEM_TYPE_VECTOR_BLOCK);
  7192               }
  7193 #endif
  7194 
  7195             switch (pvectype)
  7196               {
  7197               case PVEC_BUFFER:
  7198                 mark_buffer ((struct buffer *) ptr);
  7199                 break;
  7200 
  7201               case PVEC_FRAME:
  7202                 mark_frame (ptr);
  7203                 break;
  7204 
  7205               case PVEC_WINDOW:
  7206                 mark_window (ptr);
  7207                 break;
  7208 
  7209               case PVEC_HASH_TABLE:
  7210                 {
  7211                   struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *)ptr;
  7212                   ptrdiff_t size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
  7213                   set_vector_marked (ptr);
  7214                   mark_stack_push_values (ptr->contents, size);
  7215                   mark_stack_push_value (h->test.name);
  7216                   mark_stack_push_value (h->test.user_hash_function);
  7217                   mark_stack_push_value (h->test.user_cmp_function);
  7218                   if (NILP (h->weak))
  7219                     mark_stack_push_value (h->key_and_value);
  7220                   else
  7221                     {
  7222                       /* For weak tables, mark only the vector and not its
  7223                          contents --- that's what makes it weak.  */
  7224                       eassert (h->next_weak == NULL);
  7225                       h->next_weak = weak_hash_tables;
  7226                       weak_hash_tables = h;
  7227                       set_vector_marked (XVECTOR (h->key_and_value));
  7228                     }
  7229                   break;
  7230                 }
  7231 
  7232               case PVEC_CHAR_TABLE:
  7233               case PVEC_SUB_CHAR_TABLE:
  7234                 mark_char_table (ptr, (enum pvec_type) pvectype);
  7235                 break;
  7236 
  7237               case PVEC_BOOL_VECTOR:
  7238                 /* bool vectors in a dump are permanently "marked", since
  7239                    they're in the old section and don't have mark bits.
  7240                    If we're looking at a dumped bool vector, we should
  7241                    have aborted above when we called vector_marked_p, so
  7242                    we should never get here.  */
  7243                 eassert (!pdumper_object_p (ptr));
  7244                 set_vector_marked (ptr);
  7245                 break;
  7246 
  7247               case PVEC_OVERLAY:
  7248                 mark_overlay (XOVERLAY (obj));
  7249                 break;
  7250 
  7251               case PVEC_SUBR:
  7252 #ifdef HAVE_NATIVE_COMP
  7253                 if (SUBR_NATIVE_COMPILEDP (obj))
  7254                   {
  7255                     set_vector_marked (ptr);
  7256                     struct Lisp_Subr *subr = XSUBR (obj);
  7257                     mark_stack_push_value (subr->intspec.native);
  7258                     mark_stack_push_value (subr->command_modes);
  7259                     mark_stack_push_value (subr->native_comp_u);
  7260                     mark_stack_push_value (subr->lambda_list);
  7261                     mark_stack_push_value (subr->type);
  7262                   }
  7263 #endif
  7264                 break;
  7265 
  7266               case PVEC_FREE:
  7267                 emacs_abort ();
  7268 
  7269               default:
  7270                 {
  7271                   /* A regular vector or pseudovector needing no special
  7272                      treatment.  */
  7273                   ptrdiff_t size = ptr->header.size;
  7274                   if (size & PSEUDOVECTOR_FLAG)
  7275                     size &= PSEUDOVECTOR_SIZE_MASK;
  7276                   set_vector_marked (ptr);
  7277                   mark_stack_push_values (ptr->contents, size);
  7278                 }
  7279                 break;
  7280               }
  7281           }
  7282           break;
  7283 
  7284         case Lisp_Symbol:
  7285           {
  7286             struct Lisp_Symbol *ptr = XBARE_SYMBOL (obj);
  7287           nextsym:
  7288             if (symbol_marked_p (ptr))
  7289               break;
  7290             CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
  7291             set_symbol_marked (ptr);
  7292             /* Attempt to catch bogus objects.  */
  7293             eassert (valid_lisp_object_p (ptr->u.s.function));
  7294             mark_stack_push_value (ptr->u.s.function);
  7295             mark_stack_push_value (ptr->u.s.plist);
  7296             switch (ptr->u.s.redirect)
  7297               {
  7298               case SYMBOL_PLAINVAL:
  7299                 mark_stack_push_value (SYMBOL_VAL (ptr));
  7300                 break;
  7301               case SYMBOL_VARALIAS:
  7302                 {
  7303                   Lisp_Object tem;
  7304                   XSETSYMBOL (tem, SYMBOL_ALIAS (ptr));
  7305                   mark_stack_push_value (tem);
  7306                   break;
  7307                 }
  7308               case SYMBOL_LOCALIZED:
  7309                 mark_localized_symbol (ptr);
  7310                 break;
  7311               case SYMBOL_FORWARDED:
  7312                 /* If the value is forwarded to a buffer or keyboard field,
  7313                    these are marked when we see the corresponding object.
  7314                    And if it's forwarded to a C variable, either it's not
  7315                    a Lisp_Object var, or it's staticpro'd already.  */
  7316                 break;
  7317               default: emacs_abort ();
  7318               }
  7319             if (!PURE_P (XSTRING (ptr->u.s.name)))
  7320               set_string_marked (XSTRING (ptr->u.s.name));
  7321             mark_interval_tree (string_intervals (ptr->u.s.name));
  7322             /* Inner loop to mark next symbol in this bucket, if any.  */
  7323             po = ptr = ptr->u.s.next;
  7324             if (ptr)
  7325               goto nextsym;
  7326           }
  7327           break;
  7328 
  7329         case Lisp_Cons:
  7330           {
  7331             struct Lisp_Cons *ptr = XCONS (obj);
  7332             if (cons_marked_p (ptr))
  7333               break;
  7334             CHECK_ALLOCATED_AND_LIVE (live_cons_p, MEM_TYPE_CONS);
  7335             set_cons_marked (ptr);
  7336             /* Avoid growing the stack if the cdr is nil.
  7337                In any case, make sure the car is expanded first.  */
  7338             if (!NILP (ptr->u.s.u.cdr))
  7339               {
  7340                 mark_stack_push_value (ptr->u.s.u.cdr);
  7341 #if GC_CDR_COUNT
  7342                 cdr_count++;
  7343                 if (cdr_count == mark_object_loop_halt)
  7344                   emacs_abort ();
  7345 #endif
  7346               }
  7347             /* Speedup hack for the common case (successive list elements).  */
  7348             obj = ptr->u.s.car;
  7349             goto mark_obj;
  7350           }
  7351 
  7352         case Lisp_Float:
  7353           CHECK_ALLOCATED_AND_LIVE (live_float_p, MEM_TYPE_FLOAT);
  7354           /* Do not mark floats stored in a dump image: these floats are
  7355              "cold" and do not have mark bits.  */
  7356           if (pdumper_object_p (XFLOAT (obj)))
  7357             eassert (pdumper_cold_object_p (XFLOAT (obj)));
  7358           else if (!XFLOAT_MARKED_P (XFLOAT (obj)))
  7359             XFLOAT_MARK (XFLOAT (obj));
  7360           break;
  7361 
  7362         case_Lisp_Int:
  7363           break;
  7364 
  7365         default:
  7366           emacs_abort ();
  7367         }
  7368     }
  7369 
  7370 #undef CHECK_LIVE
  7371 #undef CHECK_ALLOCATED
  7372 #undef CHECK_ALLOCATED_AND_LIVE
  7373 }
  7374 
  7375 void
  7376 mark_object (Lisp_Object obj)
  7377 {
  7378   ptrdiff_t sp = mark_stk.sp;
  7379   mark_stack_push_value (obj);
  7380   process_mark_stack (sp);
  7381 }
  7382 
  7383 void
  7384 mark_objects (Lisp_Object *objs, ptrdiff_t n)
  7385 {
  7386   ptrdiff_t sp = mark_stk.sp;
  7387   mark_stack_push_values (objs, n);
  7388   process_mark_stack (sp);
  7389 }
  7390 
  7391 /* Mark the Lisp pointers in the terminal objects.
  7392    Called by Fgarbage_collect.  */
  7393 
  7394 static void
  7395 mark_terminals (void)
  7396 {
  7397   struct terminal *t;
  7398   for (t = terminal_list; t; t = t->next_terminal)
  7399     {
  7400       eassert (t->name != NULL);
  7401 #ifdef HAVE_WINDOW_SYSTEM
  7402       /* If a terminal object is reachable from a stacpro'ed object,
  7403          it might have been marked already.  Make sure the image cache
  7404          gets marked.  */
  7405       mark_image_cache (t->image_cache);
  7406 #endif /* HAVE_WINDOW_SYSTEM */
  7407       if (!vectorlike_marked_p (&t->header))
  7408         mark_vectorlike (&t->header);
  7409     }
  7410 }
  7411 
  7412 /* Value is non-zero if OBJ will survive the current GC because it's
  7413    either marked or does not need to be marked to survive.  */
  7414 
  7415 bool
  7416 survives_gc_p (Lisp_Object obj)
  7417 {
  7418   bool survives_p;
  7419 
  7420   switch (XTYPE (obj))
  7421     {
  7422     case_Lisp_Int:
  7423       survives_p = true;
  7424       break;
  7425 
  7426     case Lisp_Symbol:
  7427       survives_p = symbol_marked_p (XBARE_SYMBOL (obj));
  7428       break;
  7429 
  7430     case Lisp_String:
  7431       survives_p = string_marked_p (XSTRING (obj));
  7432       break;
  7433 
  7434     case Lisp_Vectorlike:
  7435       survives_p =
  7436         (SUBRP (obj) && !SUBR_NATIVE_COMPILEDP (obj)) ||
  7437         vector_marked_p (XVECTOR (obj));
  7438       break;
  7439 
  7440     case Lisp_Cons:
  7441       survives_p = cons_marked_p (XCONS (obj));
  7442       break;
  7443 
  7444     case Lisp_Float:
  7445       survives_p =
  7446         XFLOAT_MARKED_P (XFLOAT (obj)) ||
  7447         pdumper_object_p (XFLOAT (obj));
  7448       break;
  7449 
  7450     default:
  7451       emacs_abort ();
  7452     }
  7453 
  7454   return survives_p || PURE_P (XPNTR (obj));
  7455 }
  7456 
  7457 
  7458 
  7459 
  7460 NO_INLINE /* For better stack traces */
  7461 static void
  7462 sweep_conses (void)
  7463 {
  7464   struct cons_block **cprev = &cons_block;
  7465   int lim = cons_block_index;
  7466   object_ct num_free = 0, num_used = 0;
  7467 
  7468   cons_free_list = 0;
  7469 
  7470   for (struct cons_block *cblk; (cblk = *cprev); )
  7471     {
  7472       int i = 0;
  7473       int this_free = 0;
  7474       int ilim = (lim + BITS_PER_BITS_WORD - 1) / BITS_PER_BITS_WORD;
  7475 
  7476       /* Scan the mark bits an int at a time.  */
  7477       for (i = 0; i < ilim; i++)
  7478         {
  7479           if (cblk->gcmarkbits[i] == BITS_WORD_MAX)
  7480             {
  7481               /* Fast path - all cons cells for this int are marked.  */
  7482               cblk->gcmarkbits[i] = 0;
  7483               num_used += BITS_PER_BITS_WORD;
  7484             }
  7485           else
  7486             {
  7487               /* Some cons cells for this int are not marked.
  7488                  Find which ones, and free them.  */
  7489               int start, pos, stop;
  7490 
  7491               start = i * BITS_PER_BITS_WORD;
  7492               stop = lim - start;
  7493               if (stop > BITS_PER_BITS_WORD)
  7494                 stop = BITS_PER_BITS_WORD;
  7495               stop += start;
  7496 
  7497               for (pos = start; pos < stop; pos++)
  7498                 {
  7499                   struct Lisp_Cons *acons = &cblk->conses[pos];
  7500                   if (!XCONS_MARKED_P (acons))
  7501                     {
  7502                       ASAN_UNPOISON_CONS (&cblk->conses[pos]);
  7503                       this_free++;
  7504                       cblk->conses[pos].u.s.u.chain = cons_free_list;
  7505                       cons_free_list = &cblk->conses[pos];
  7506                       cons_free_list->u.s.car = dead_object ();
  7507                       ASAN_POISON_CONS (&cblk->conses[pos]);
  7508                     }
  7509                   else
  7510                     {
  7511                       num_used++;
  7512                       XUNMARK_CONS (acons);
  7513                     }
  7514                 }
  7515             }
  7516         }
  7517 
  7518       lim = CONS_BLOCK_SIZE;
  7519       /* If this block contains only free conses and we have already
  7520          seen more than two blocks worth of free conses then deallocate
  7521          this block.  */
  7522       if (this_free == CONS_BLOCK_SIZE && num_free > CONS_BLOCK_SIZE)
  7523         {
  7524           *cprev = cblk->next;
  7525           /* Unhook from the free list.  */
  7526           ASAN_UNPOISON_CONS (&cblk->conses[0]);
  7527           cons_free_list = cblk->conses[0].u.s.u.chain;
  7528           lisp_align_free (cblk);
  7529         }
  7530       else
  7531         {
  7532           num_free += this_free;
  7533           cprev = &cblk->next;
  7534         }
  7535     }
  7536   gcstat.total_conses = num_used;
  7537   gcstat.total_free_conses = num_free;
  7538 }
  7539 
  7540 NO_INLINE /* For better stack traces */
  7541 static void
  7542 sweep_floats (void)
  7543 {
  7544   struct float_block **fprev = &float_block;
  7545   int lim = float_block_index;
  7546   object_ct num_free = 0, num_used = 0;
  7547 
  7548   float_free_list = 0;
  7549 
  7550   for (struct float_block *fblk; (fblk = *fprev); )
  7551     {
  7552       int this_free = 0;
  7553       ASAN_UNPOISON_FLOAT_BLOCK (fblk);
  7554       for (int i = 0; i < lim; i++)
  7555         {
  7556           struct Lisp_Float *afloat = &fblk->floats[i];
  7557           if (!XFLOAT_MARKED_P (afloat))
  7558             {
  7559               this_free++;
  7560               fblk->floats[i].u.chain = float_free_list;
  7561               ASAN_POISON_FLOAT (&fblk->floats[i]);
  7562               float_free_list = &fblk->floats[i];
  7563             }
  7564           else
  7565             {
  7566               num_used++;
  7567               XFLOAT_UNMARK (afloat);
  7568             }
  7569         }
  7570       lim = FLOAT_BLOCK_SIZE;
  7571       /* If this block contains only free floats and we have already
  7572          seen more than two blocks worth of free floats then deallocate
  7573          this block.  */
  7574       if (this_free == FLOAT_BLOCK_SIZE && num_free > FLOAT_BLOCK_SIZE)
  7575         {
  7576           *fprev = fblk->next;
  7577           /* Unhook from the free list.  */
  7578           ASAN_UNPOISON_FLOAT (&fblk->floats[0]);
  7579           float_free_list = fblk->floats[0].u.chain;
  7580           lisp_align_free (fblk);
  7581         }
  7582       else
  7583         {
  7584           num_free += this_free;
  7585           fprev = &fblk->next;
  7586         }
  7587     }
  7588   gcstat.total_floats = num_used;
  7589   gcstat.total_free_floats = num_free;
  7590 }
  7591 
  7592 NO_INLINE /* For better stack traces */
  7593 static void
  7594 sweep_intervals (void)
  7595 {
  7596   struct interval_block **iprev = &interval_block;
  7597   int lim = interval_block_index;
  7598   object_ct num_free = 0, num_used = 0;
  7599 
  7600   interval_free_list = 0;
  7601 
  7602   for (struct interval_block *iblk; (iblk = *iprev); )
  7603     {
  7604       int this_free = 0;
  7605       ASAN_UNPOISON_INTERVAL_BLOCK (iblk);
  7606       for (int i = 0; i < lim; i++)
  7607         {
  7608           if (!iblk->intervals[i].gcmarkbit)
  7609             {
  7610               set_interval_parent (&iblk->intervals[i], interval_free_list);
  7611               interval_free_list = &iblk->intervals[i];
  7612               ASAN_POISON_INTERVAL (&iblk->intervals[i]);
  7613               this_free++;
  7614             }
  7615           else
  7616             {
  7617               num_used++;
  7618               iblk->intervals[i].gcmarkbit = 0;
  7619             }
  7620         }
  7621       lim = INTERVAL_BLOCK_SIZE;
  7622       /* If this block contains only free intervals and we have already
  7623          seen more than two blocks worth of free intervals then
  7624          deallocate this block.  */
  7625       if (this_free == INTERVAL_BLOCK_SIZE && num_free > INTERVAL_BLOCK_SIZE)
  7626         {
  7627           *iprev = iblk->next;
  7628           /* Unhook from the free list.  */
  7629           ASAN_UNPOISON_INTERVAL (&iblk->intervals[0]);
  7630           interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
  7631           lisp_free (iblk);
  7632         }
  7633       else
  7634         {
  7635           num_free += this_free;
  7636           iprev = &iblk->next;
  7637         }
  7638     }
  7639   gcstat.total_intervals = num_used;
  7640   gcstat.total_free_intervals = num_free;
  7641 }
  7642 
  7643 NO_INLINE /* For better stack traces */
  7644 static void
  7645 sweep_symbols (void)
  7646 {
  7647   struct symbol_block *sblk;
  7648   struct symbol_block **sprev = &symbol_block;
  7649   int lim = symbol_block_index;
  7650   object_ct num_free = 0, num_used = ARRAYELTS (lispsym);
  7651 
  7652   symbol_free_list = NULL;
  7653 
  7654   for (int i = 0; i < ARRAYELTS (lispsym); i++)
  7655     lispsym[i].u.s.gcmarkbit = 0;
  7656 
  7657   for (sblk = symbol_block; sblk; sblk = *sprev)
  7658     {
  7659       ASAN_UNPOISON_SYMBOL_BLOCK (sblk);
  7660 
  7661       int this_free = 0;
  7662       struct Lisp_Symbol *sym = sblk->symbols;
  7663       struct Lisp_Symbol *end = sym + lim;
  7664 
  7665       for (; sym < end; ++sym)
  7666         {
  7667           if (!sym->u.s.gcmarkbit)
  7668             {
  7669               if (sym->u.s.redirect == SYMBOL_LOCALIZED)
  7670                 {
  7671                   xfree (SYMBOL_BLV (sym));
  7672                   /* At every GC we sweep all symbol_blocks and rebuild the
  7673                      symbol_free_list, so those symbols which stayed unused
  7674                      between the two will be re-swept.
  7675                      So we have to make sure we don't re-free this blv next
  7676                      time we sweep this symbol_block (bug#29066).  */
  7677                   sym->u.s.redirect = SYMBOL_PLAINVAL;
  7678                 }
  7679               sym->u.s.next = symbol_free_list;
  7680               symbol_free_list = sym;
  7681               symbol_free_list->u.s.function = dead_object ();
  7682               ASAN_POISON_SYMBOL (sym);
  7683               ++this_free;
  7684             }
  7685           else
  7686             {
  7687               ++num_used;
  7688               sym->u.s.gcmarkbit = 0;
  7689               /* Attempt to catch bogus objects.  */
  7690               eassert (valid_lisp_object_p (sym->u.s.function));
  7691             }
  7692         }
  7693 
  7694       lim = SYMBOL_BLOCK_SIZE;
  7695       /* If this block contains only free symbols and we have already
  7696          seen more than two blocks worth of free symbols then deallocate
  7697          this block.  */
  7698       if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)
  7699         {
  7700           *sprev = sblk->next;
  7701           /* Unhook from the free list.  */
  7702           ASAN_UNPOISON_SYMBOL (&sblk->symbols[0]);
  7703           symbol_free_list = sblk->symbols[0].u.s.next;
  7704           lisp_free (sblk);
  7705         }
  7706       else
  7707         {
  7708           num_free += this_free;
  7709           sprev = &sblk->next;
  7710         }
  7711     }
  7712   gcstat.total_symbols = num_used;
  7713   gcstat.total_free_symbols = num_free;
  7714 }
  7715 
  7716 /* Remove BUFFER's markers that are due to be swept.  This is needed since
  7717    we treat BUF_MARKERS and markers's `next' field as weak pointers.  */
  7718 static void
  7719 unchain_dead_markers (struct buffer *buffer)
  7720 {
  7721   struct Lisp_Marker *this, **prev = &BUF_MARKERS (buffer);
  7722 
  7723   while ((this = *prev))
  7724     if (vectorlike_marked_p (&this->header))
  7725       prev = &this->next;
  7726     else
  7727       {
  7728         this->buffer = NULL;
  7729         *prev = this->next;
  7730       }
  7731 }
  7732 
  7733 NO_INLINE /* For better stack traces */
  7734 static void
  7735 sweep_buffers (void)
  7736 {
  7737   Lisp_Object tail, buf;
  7738 
  7739   gcstat.total_buffers = 0;
  7740   FOR_EACH_LIVE_BUFFER (tail, buf)
  7741     {
  7742       struct buffer *buffer = XBUFFER (buf);
  7743       /* Do not use buffer_(set|get)_intervals here.  */
  7744       buffer->text->intervals = balance_intervals (buffer->text->intervals);
  7745       unchain_dead_markers (buffer);
  7746       gcstat.total_buffers++;
  7747     }
  7748 }
  7749 
  7750 /* Sweep: find all structures not marked, and free them.  */
  7751 static void
  7752 gc_sweep (void)
  7753 {
  7754   sweep_strings ();
  7755   check_string_bytes (!noninteractive);
  7756   sweep_conses ();
  7757   sweep_floats ();
  7758   sweep_intervals ();
  7759   sweep_symbols ();
  7760   sweep_buffers ();
  7761   sweep_vectors ();
  7762   pdumper_clear_marks ();
  7763   check_string_bytes (!noninteractive);
  7764 }
  7765 
  7766 DEFUN ("memory-info", Fmemory_info, Smemory_info, 0, 0, 0,
  7767        doc: /* Return a list of (TOTAL-RAM FREE-RAM TOTAL-SWAP FREE-SWAP).
  7768 All values are in Kbytes.  If there is no swap space,
  7769 last two values are zero.  If the system is not supported
  7770 or memory information can't be obtained, return nil.
  7771 If `default-directory' is remote, return memory information of the
  7772 respective remote host.  */)
  7773   (void)
  7774 {
  7775   Lisp_Object handler
  7776     = Ffind_file_name_handler (BVAR (current_buffer, directory),
  7777                                Qmemory_info);
  7778   if (!NILP (handler))
  7779     return call1 (handler, Qmemory_info);
  7780 
  7781 #if defined HAVE_LINUX_SYSINFO
  7782   struct sysinfo si;
  7783   uintmax_t units;
  7784 
  7785   if (sysinfo (&si))
  7786     return Qnil;
  7787 #ifdef LINUX_SYSINFO_UNIT
  7788   units = si.mem_unit;
  7789 #else
  7790   units = 1;
  7791 #endif
  7792   return list4i ((uintmax_t) si.totalram * units / 1024,
  7793                  (uintmax_t) si.freeram * units / 1024,
  7794                  (uintmax_t) si.totalswap * units / 1024,
  7795                  (uintmax_t) si.freeswap * units / 1024);
  7796 #elif defined WINDOWSNT
  7797   unsigned long long totalram, freeram, totalswap, freeswap;
  7798 
  7799   if (w32_memory_info (&totalram, &freeram, &totalswap, &freeswap) == 0)
  7800     return list4i ((uintmax_t) totalram / 1024,
  7801                    (uintmax_t) freeram / 1024,
  7802                    (uintmax_t) totalswap / 1024,
  7803                    (uintmax_t) freeswap / 1024);
  7804   else
  7805     return Qnil;
  7806 #elif defined MSDOS
  7807   unsigned long totalram, freeram, totalswap, freeswap;
  7808 
  7809   if (dos_memory_info (&totalram, &freeram, &totalswap, &freeswap) == 0)
  7810     return list4i ((uintmax_t) totalram / 1024,
  7811                    (uintmax_t) freeram / 1024,
  7812                    (uintmax_t) totalswap / 1024,
  7813                    (uintmax_t) freeswap / 1024);
  7814   else
  7815     return Qnil;
  7816 #else /* not HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
  7817   /* FIXME: add more systems.  */
  7818   return Qnil;
  7819 #endif /* HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
  7820 }
  7821 
  7822 /* Debugging aids.  */
  7823 
  7824 DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0,
  7825        doc: /* Return a list of counters that measure how much consing there has been.
  7826 Each of these counters increments for a certain kind of object.
  7827 The counters wrap around from the largest positive integer to zero.
  7828 Garbage collection does not decrease them.
  7829 The elements of the value are as follows:
  7830   (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS INTERVALS STRINGS)
  7831 All are in units of 1 = one object consed
  7832 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
  7833 objects consed.
  7834 Frames, windows, buffers, and subprocesses count as vectors
  7835   (but the contents of a buffer's text do not count here).  */)
  7836   (void)
  7837 {
  7838   return  list (make_int (cons_cells_consed),
  7839                 make_int (floats_consed),
  7840                 make_int (vector_cells_consed),
  7841                 make_int (symbols_consed),
  7842                 make_int (string_chars_consed),
  7843                 make_int (intervals_consed),
  7844                 make_int (strings_consed));
  7845 }
  7846 
  7847 #if defined GNU_LINUX && defined __GLIBC__ && \
  7848   (__GLIBC__ > 2 || __GLIBC_MINOR__ >= 10)
  7849 DEFUN ("malloc-info", Fmalloc_info, Smalloc_info, 0, 0, "",
  7850        doc: /* Report malloc information to stderr.
  7851 This function outputs to stderr an XML-formatted
  7852 description of the current state of the memory-allocation
  7853 arenas.  */)
  7854   (void)
  7855 {
  7856   if (malloc_info (0, stderr))
  7857     error ("malloc_info failed: %s", emacs_strerror (errno));
  7858   return Qnil;
  7859 }
  7860 #endif
  7861 
  7862 #ifdef HAVE_MALLOC_TRIM
  7863 DEFUN ("malloc-trim", Fmalloc_trim, Smalloc_trim, 0, 1, "",
  7864        doc: /* Release free heap memory to the OS.
  7865 This function asks libc to return unused heap memory back to the operating
  7866 system.  This function isn't guaranteed to do anything, and is mainly
  7867 meant as a debugging tool.
  7868 
  7869 If LEAVE_PADDING is given, ask the system to leave that much unused
  7870 space in the heap of the Emacs process.  This should be an integer, and if
  7871 not given, it defaults to 0.
  7872 
  7873 This function returns nil if no memory could be returned to the
  7874 system, and non-nil if some memory could be returned.  */)
  7875   (Lisp_Object leave_padding)
  7876 {
  7877   int pad = 0;
  7878 
  7879   if (! NILP (leave_padding))
  7880     {
  7881       CHECK_FIXNAT (leave_padding);
  7882       pad = XFIXNUM (leave_padding);
  7883     }
  7884 
  7885   /* 1 means that memory was released to the system.  */
  7886   if (malloc_trim (pad) == 1)
  7887     return Qt;
  7888   else
  7889     return Qnil;
  7890 }
  7891 #endif
  7892 
  7893 static bool
  7894 symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj)
  7895 {
  7896   struct Lisp_Symbol *sym = XBARE_SYMBOL (symbol);
  7897   Lisp_Object val = find_symbol_value (symbol);
  7898   return (EQ (val, obj)
  7899           || EQ (sym->u.s.function, obj)
  7900           || (!NILP (sym->u.s.function)
  7901               && COMPILEDP (sym->u.s.function)
  7902               && EQ (AREF (sym->u.s.function, COMPILED_BYTECODE), obj))
  7903           || (!NILP (val)
  7904               && COMPILEDP (val)
  7905               && EQ (AREF (val, COMPILED_BYTECODE), obj)));
  7906 }
  7907 
  7908 /* Find at most FIND_MAX symbols which have OBJ as their value or
  7909    function.  This is used in gdbinit's `xwhichsymbols' command.  */
  7910 
  7911 Lisp_Object
  7912 which_symbols (Lisp_Object obj, EMACS_INT find_max)
  7913 {
  7914    struct symbol_block *sblk;
  7915    specpdl_ref gc_count = inhibit_garbage_collection ();
  7916    Lisp_Object found = Qnil;
  7917 
  7918    if (! deadp (obj))
  7919      {
  7920        for (int i = 0; i < ARRAYELTS (lispsym); i++)
  7921          {
  7922            Lisp_Object sym = builtin_lisp_symbol (i);
  7923            if (symbol_uses_obj (sym, obj))
  7924              {
  7925                found = Fcons (sym, found);
  7926                if (--find_max == 0)
  7927                  goto out;
  7928              }
  7929          }
  7930 
  7931        for (sblk = symbol_block; sblk; sblk = sblk->next)
  7932          {
  7933            struct Lisp_Symbol *asym = sblk->symbols;
  7934            int bn;
  7935 
  7936            for (bn = 0; bn < SYMBOL_BLOCK_SIZE; bn++, asym++)
  7937              {
  7938                if (sblk == symbol_block && bn >= symbol_block_index)
  7939                  break;
  7940 
  7941                Lisp_Object sym = make_lisp_symbol (asym);
  7942                if (symbol_uses_obj (sym, obj))
  7943                  {
  7944                    found = Fcons (sym, found);
  7945                    if (--find_max == 0)
  7946                      goto out;
  7947                  }
  7948              }
  7949          }
  7950      }
  7951 
  7952   out:
  7953    return unbind_to (gc_count, found);
  7954 }
  7955 
  7956 #ifdef SUSPICIOUS_OBJECT_CHECKING
  7957 
  7958 static void *
  7959 find_suspicious_object_in_range (void *begin, void *end)
  7960 {
  7961   char *begin_a = begin;
  7962   char *end_a = end;
  7963   int i;
  7964 
  7965   for (i = 0; i < ARRAYELTS (suspicious_objects); ++i)
  7966     {
  7967       char *suspicious_object = suspicious_objects[i];
  7968       if (begin_a <= suspicious_object && suspicious_object < end_a)
  7969         return suspicious_object;
  7970     }
  7971 
  7972   return NULL;
  7973 }
  7974 
  7975 static void
  7976 note_suspicious_free (void *ptr)
  7977 {
  7978   struct suspicious_free_record *rec;
  7979 
  7980   rec = &suspicious_free_history[suspicious_free_history_index++];
  7981   if (suspicious_free_history_index ==
  7982       ARRAYELTS (suspicious_free_history))
  7983     {
  7984       suspicious_free_history_index = 0;
  7985     }
  7986 
  7987   memset (rec, 0, sizeof (*rec));
  7988   rec->suspicious_object = ptr;
  7989   backtrace (&rec->backtrace[0], ARRAYELTS (rec->backtrace));
  7990 }
  7991 
  7992 static void
  7993 detect_suspicious_free (void *ptr)
  7994 {
  7995   int i;
  7996 
  7997   eassert (ptr != NULL);
  7998 
  7999   for (i = 0; i < ARRAYELTS (suspicious_objects); ++i)
  8000     if (suspicious_objects[i] == ptr)
  8001       {
  8002         note_suspicious_free (ptr);
  8003         suspicious_objects[i] = NULL;
  8004       }
  8005 }
  8006 
  8007 #endif /* SUSPICIOUS_OBJECT_CHECKING */
  8008 
  8009 DEFUN ("suspicious-object", Fsuspicious_object, Ssuspicious_object, 1, 1, 0,
  8010        doc: /* Return OBJ, maybe marking it for extra scrutiny.
  8011 If Emacs is compiled with suspicious object checking, capture
  8012 a stack trace when OBJ is freed in order to help track down
  8013 garbage collection bugs.  Otherwise, do nothing and return OBJ.   */)
  8014    (Lisp_Object obj)
  8015 {
  8016 #ifdef SUSPICIOUS_OBJECT_CHECKING
  8017   /* Right now, we care only about vectors.  */
  8018   if (VECTORLIKEP (obj))
  8019     {
  8020       suspicious_objects[suspicious_object_index++] = XVECTOR (obj);
  8021       if (suspicious_object_index == ARRAYELTS (suspicious_objects))
  8022         suspicious_object_index = 0;
  8023     }
  8024 #endif
  8025   return obj;
  8026 }
  8027 
  8028 #ifdef ENABLE_CHECKING
  8029 
  8030 bool suppress_checking;
  8031 
  8032 void
  8033 die (const char *msg, const char *file, int line)
  8034 {
  8035   fprintf (stderr, "\r\n%s:%d: Emacs fatal error: assertion failed: %s\r\n",
  8036            file, line, msg);
  8037   terminate_due_to_signal (SIGABRT, INT_MAX);
  8038 }
  8039 
  8040 #endif /* ENABLE_CHECKING */
  8041 
  8042 #if defined (ENABLE_CHECKING) && USE_STACK_LISP_OBJECTS
  8043 
  8044 /* Stress alloca with inconveniently sized requests and check
  8045    whether all allocated areas may be used for Lisp_Object.  */
  8046 
  8047 NO_INLINE static void
  8048 verify_alloca (void)
  8049 {
  8050   int i;
  8051   enum { ALLOCA_CHECK_MAX = 256 };
  8052   /* Start from size of the smallest Lisp object.  */
  8053   for (i = sizeof (struct Lisp_Cons); i <= ALLOCA_CHECK_MAX; i++)
  8054     {
  8055       void *ptr = alloca (i);
  8056       make_lisp_ptr (ptr, Lisp_Cons);
  8057     }
  8058 }
  8059 
  8060 #else /* not ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
  8061 
  8062 #define verify_alloca() ((void) 0)
  8063 
  8064 #endif /* ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
  8065 
  8066 /* Initialization.  */
  8067 
  8068 static void init_alloc_once_for_pdumper (void);
  8069 
  8070 void
  8071 init_alloc_once (void)
  8072 {
  8073   gc_cons_threshold = GC_DEFAULT_THRESHOLD;
  8074   /* Even though Qt's contents are not set up, its address is known.  */
  8075   Vpurify_flag = Qt;
  8076 
  8077   PDUMPER_REMEMBER_SCALAR (buffer_defaults.header);
  8078   PDUMPER_REMEMBER_SCALAR (buffer_local_symbols.header);
  8079 
  8080   /* Call init_alloc_once_for_pdumper now so we run mem_init early.
  8081      Keep in mind that when we reload from a dump, we'll run _only_
  8082      init_alloc_once_for_pdumper and not init_alloc_once at all.  */
  8083   pdumper_do_now_and_after_load (init_alloc_once_for_pdumper);
  8084 
  8085   verify_alloca ();
  8086 
  8087   init_strings ();
  8088   init_vectors ();
  8089 }
  8090 
  8091 static void
  8092 init_alloc_once_for_pdumper (void)
  8093 {
  8094   purebeg = PUREBEG;
  8095   pure_size = PURESIZE;
  8096   mem_init ();
  8097 
  8098 #ifdef DOUG_LEA_MALLOC
  8099   mallopt (M_TRIM_THRESHOLD, 128 * 1024); /* Trim threshold.  */
  8100   mallopt (M_MMAP_THRESHOLD, 64 * 1024);  /* Mmap threshold.  */
  8101   mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);   /* Max. number of mmap'ed areas.  */
  8102 #endif
  8103 
  8104 
  8105   init_finalizer_list (&finalizers);
  8106   init_finalizer_list (&doomed_finalizers);
  8107   refill_memory_reserve ();
  8108 }
  8109 
  8110 void
  8111 init_alloc (void)
  8112 {
  8113   Vgc_elapsed = make_float (0.0);
  8114   gcs_done = 0;
  8115 }
  8116 
  8117 void
  8118 syms_of_alloc (void)
  8119 {
  8120   DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold,
  8121               doc: /* Number of bytes of consing between garbage collections.
  8122 Garbage collection can happen automatically once this many bytes have been
  8123 allocated since the last garbage collection.  All data types count.
  8124 
  8125 Garbage collection happens automatically only when `eval' is called.
  8126 
  8127 By binding this temporarily to a large number, you can effectively
  8128 prevent garbage collection during a part of the program.  But be
  8129 sure to get back to the normal value soon enough, to avoid system-wide
  8130 memory pressure, and never use a too-high value for prolonged periods
  8131 of time.
  8132 See also `gc-cons-percentage'.  */);
  8133 
  8134   DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage,
  8135                doc: /* Portion of the heap used for allocation.
  8136 Garbage collection can happen automatically once this portion of the heap
  8137 has been allocated since the last garbage collection.
  8138 
  8139 By binding this temporarily to a large number, you can effectively
  8140 prevent garbage collection during a part of the program.  But be
  8141 sure to get back to the normal value soon enough, to avoid system-wide
  8142 memory pressure, and never use a too-high value for prolonged periods
  8143 of time.
  8144 
  8145 If this portion is smaller than `gc-cons-threshold', this is ignored.  */);
  8146   Vgc_cons_percentage = make_float (0.1);
  8147 
  8148   DEFVAR_INT ("pure-bytes-used", pure_bytes_used,
  8149               doc: /* Number of bytes of shareable Lisp data allocated so far.  */);
  8150 
  8151   DEFVAR_INT ("cons-cells-consed", cons_cells_consed,
  8152               doc: /* Number of cons cells that have been consed so far.  */);
  8153 
  8154   DEFVAR_INT ("floats-consed", floats_consed,
  8155               doc: /* Number of floats that have been consed so far.  */);
  8156 
  8157   DEFVAR_INT ("vector-cells-consed", vector_cells_consed,
  8158               doc: /* Number of vector cells that have been consed so far.  */);
  8159 
  8160   DEFVAR_INT ("symbols-consed", symbols_consed,
  8161               doc: /* Number of symbols that have been consed so far.  */);
  8162   symbols_consed += ARRAYELTS (lispsym);
  8163 
  8164   DEFVAR_INT ("string-chars-consed", string_chars_consed,
  8165               doc: /* Number of string characters that have been consed so far.  */);
  8166 
  8167   DEFVAR_INT ("intervals-consed", intervals_consed,
  8168               doc: /* Number of intervals that have been consed so far.  */);
  8169 
  8170   DEFVAR_INT ("strings-consed", strings_consed,
  8171               doc: /* Number of strings that have been consed so far.  */);
  8172 
  8173   DEFVAR_LISP ("purify-flag", Vpurify_flag,
  8174                doc: /* Non-nil means loading Lisp code in order to dump an executable.
  8175 This means that certain objects should be allocated in shared (pure) space.
  8176 It can also be set to a hash-table, in which case this table is used to
  8177 do hash-consing of the objects allocated to pure space.  */);
  8178 
  8179   DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages,
  8180                doc: /* Non-nil means display messages at start and end of garbage collection.  */);
  8181   garbage_collection_messages = 0;
  8182 
  8183   DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook,
  8184                doc: /* Hook run after garbage collection has finished.  */);
  8185   Vpost_gc_hook = Qnil;
  8186   DEFSYM (Qpost_gc_hook, "post-gc-hook");
  8187 
  8188   DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data,
  8189                doc: /* Precomputed `signal' argument for memory-full error.  */);
  8190   /* We build this in advance because if we wait until we need it, we might
  8191      not be able to allocate the memory to hold it.  */
  8192   Vmemory_signal_data
  8193     = pure_list (Qerror,
  8194                  build_pure_c_string ("Memory exhausted--use"
  8195                                       " M-x save-some-buffers then"
  8196                                       " exit and restart Emacs"));
  8197 
  8198   DEFVAR_LISP ("memory-full", Vmemory_full,
  8199                doc: /* Non-nil means Emacs cannot get much more Lisp memory.  */);
  8200   Vmemory_full = Qnil;
  8201 
  8202   DEFSYM (Qmemory_info, "memory-info");
  8203 
  8204   DEFSYM (Qconses, "conses");
  8205   DEFSYM (Qsymbols, "symbols");
  8206   DEFSYM (Qstrings, "strings");
  8207   DEFSYM (Qvectors, "vectors");
  8208   DEFSYM (Qfloats, "floats");
  8209   DEFSYM (Qintervals, "intervals");
  8210   DEFSYM (Qbuffers, "buffers");
  8211   DEFSYM (Qstring_bytes, "string-bytes");
  8212   DEFSYM (Qvector_slots, "vector-slots");
  8213   DEFSYM (Qheap, "heap");
  8214   DEFSYM (QAutomatic_GC, "Automatic GC");
  8215 
  8216   DEFSYM (Qgc_cons_percentage, "gc-cons-percentage");
  8217   DEFSYM (Qgc_cons_threshold, "gc-cons-threshold");
  8218   DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots");
  8219 
  8220   DEFVAR_LISP ("gc-elapsed", Vgc_elapsed,
  8221                doc: /* Accumulated time elapsed in garbage collections.
  8222 The time is in seconds as a floating point value.  */);
  8223   DEFVAR_INT ("gcs-done", gcs_done,
  8224               doc: /* Accumulated number of garbage collections done.  */);
  8225 
  8226   DEFVAR_INT ("integer-width", integer_width,
  8227               doc: /* Maximum number N of bits in safely-calculated integers.
  8228 Integers with absolute values less than 2**N do not signal a range error.
  8229 N should be nonnegative.  */);
  8230 
  8231   defsubr (&Scons);
  8232   defsubr (&Slist);
  8233   defsubr (&Svector);
  8234   defsubr (&Srecord);
  8235   defsubr (&Sbool_vector);
  8236   defsubr (&Smake_byte_code);
  8237   defsubr (&Smake_closure);
  8238   defsubr (&Smake_list);
  8239   defsubr (&Smake_vector);
  8240   defsubr (&Smake_record);
  8241   defsubr (&Smake_string);
  8242   defsubr (&Smake_bool_vector);
  8243   defsubr (&Smake_symbol);
  8244   defsubr (&Smake_marker);
  8245   defsubr (&Smake_finalizer);
  8246   defsubr (&Spurecopy);
  8247   defsubr (&Sgarbage_collect);
  8248   defsubr (&Sgarbage_collect_maybe);
  8249   defsubr (&Smemory_info);
  8250   defsubr (&Smemory_use_counts);
  8251 #if defined GNU_LINUX && defined __GLIBC__ && \
  8252   (__GLIBC__ > 2 || __GLIBC_MINOR__ >= 10)
  8253 
  8254   defsubr (&Smalloc_info);
  8255 #endif
  8256 #ifdef HAVE_MALLOC_TRIM
  8257   defsubr (&Smalloc_trim);
  8258 #endif
  8259   defsubr (&Ssuspicious_object);
  8260 
  8261   Lisp_Object watcher;
  8262 
  8263   static union Aligned_Lisp_Subr Swatch_gc_cons_threshold =
  8264      {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) },
  8265        { .a4 = watch_gc_cons_threshold },
  8266        4, 4, "watch_gc_cons_threshold", {0}, lisp_h_Qnil}};
  8267   XSETSUBR (watcher, &Swatch_gc_cons_threshold.s);
  8268   Fadd_variable_watcher (Qgc_cons_threshold, watcher);
  8269 
  8270   static union Aligned_Lisp_Subr Swatch_gc_cons_percentage =
  8271      {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) },
  8272        { .a4 = watch_gc_cons_percentage },
  8273        4, 4, "watch_gc_cons_percentage", {0}, lisp_h_Qnil}};
  8274   XSETSUBR (watcher, &Swatch_gc_cons_percentage.s);
  8275   Fadd_variable_watcher (Qgc_cons_percentage, watcher);
  8276 }
  8277 
  8278 #ifdef HAVE_X_WINDOWS
  8279 enum defined_HAVE_X_WINDOWS { defined_HAVE_X_WINDOWS = true };
  8280 #else
  8281 enum defined_HAVE_X_WINDOWS { defined_HAVE_X_WINDOWS = false };
  8282 #endif
  8283 
  8284 #ifdef HAVE_PGTK
  8285 enum defined_HAVE_PGTK { defined_HAVE_PGTK = true };
  8286 #else
  8287 enum defined_HAVE_PGTK { defined_HAVE_PGTK = false };
  8288 #endif
  8289 
  8290 /* When compiled with GCC, GDB might say "No enum type named
  8291    pvec_type" if we don't have at least one symbol with that type, and
  8292    then xbacktrace could fail.  Similarly for the other enums and
  8293    their values.  Some non-GCC compilers don't like these constructs.  */
  8294 #ifdef __GNUC__
  8295 union
  8296 {
  8297   enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS;
  8298   enum char_table_specials char_table_specials;
  8299   enum char_bits char_bits;
  8300   enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE;
  8301   enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE;
  8302   enum Lisp_Bits Lisp_Bits;
  8303   enum Lisp_Compiled Lisp_Compiled;
  8304   enum maxargs maxargs;
  8305   enum MAX_ALLOCA MAX_ALLOCA;
  8306   enum More_Lisp_Bits More_Lisp_Bits;
  8307   enum pvec_type pvec_type;
  8308   enum defined_HAVE_X_WINDOWS defined_HAVE_X_WINDOWS;
  8309   enum defined_HAVE_PGTK defined_HAVE_PGTK;
  8310 } const EXTERNALLY_VISIBLE gdb_make_enums_visible = {0};
  8311 #endif  /* __GNUC__ */