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