XEmacs 21.2.28 "Hermes".
[chise/xemacs-chise.git.1] / src / alloc.c
1 /* Storage allocation and gc for XEmacs Lisp interpreter.
2    Copyright (C) 1985-1998 Free Software Foundation, Inc.
3    Copyright (C) 1995 Sun Microsystems, Inc.
4    Copyright (C) 1995, 1996 Ben Wing.
5
6 This file is part of XEmacs.
7
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
11 later version.
12
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING.  If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA.  */
22
23 /* Synched up with: FSF 19.28, Mule 2.0.  Substantially different from
24    FSF. */
25
26 /* Authorship:
27
28    FSF: Original version; a long time ago.
29    Mly: Significantly rewritten to use new 3-bit tags and
30         nicely abstracted object definitions, for 19.8.
31    JWZ: Improved code to keep track of purespace usage and
32         issue nice purespace and GC stats.
33    Ben Wing: Cleaned up frob-block lrecord code, added error-checking
34         and various changes for Mule, for 19.12.
35         Added bit vectors for 19.13.
36         Added lcrecord lists for 19.14.
37    slb: Lots of work on the purification and dump time code.
38         Synched Doug Lea malloc support from Emacs 20.2.
39    og:  Killed the purespace.  Portable dumper.
40 */
41
42 #include <config.h>
43 #include "lisp.h"
44
45 #include "backtrace.h"
46 #include "buffer.h"
47 #include "bytecode.h"
48 #include "chartab.h"
49 #include "device.h"
50 #include "elhash.h"
51 #include "events.h"
52 #include "extents.h"
53 #include "frame.h"
54 #include "glyphs.h"
55 #include "opaque.h"
56 #include "redisplay.h"
57 #include "specifier.h"
58 #include "sysfile.h"
59 #include "window.h"
60 #include "console-stream.h"
61
62 #ifdef DOUG_LEA_MALLOC
63 #include <malloc.h>
64 #endif
65
66 #ifdef HAVE_MMAP
67 #include <unistd.h>
68 #include <sys/mman.h>
69 #endif
70
71 #ifdef PDUMP
72 typedef struct
73 {
74   const struct lrecord_description *desc;
75   int count;
76 } pdump_reloc_table;
77
78 static char *pdump_rt_list = 0;
79 #endif
80
81 EXFUN (Fgarbage_collect, 0);
82
83 /* Return the true size of a struct with a variable-length array field.  */
84 #define STRETCHY_STRUCT_SIZEOF(stretchy_struct_type,            \
85                                stretchy_array_field,            \
86                                stretchy_array_length)           \
87   (offsetof (stretchy_struct_type, stretchy_array_field) +      \
88    (offsetof (stretchy_struct_type, stretchy_array_field[1]) -  \
89     offsetof (stretchy_struct_type, stretchy_array_field[0])) * \
90    (stretchy_array_length))
91
92 #if 0 /* this is _way_ too slow to be part of the standard debug options */
93 #if defined(DEBUG_XEMACS) && defined(MULE)
94 #define VERIFY_STRING_CHARS_INTEGRITY
95 #endif
96 #endif
97
98 /* Define this to use malloc/free with no freelist for all datatypes,
99    the hope being that some debugging tools may help detect
100    freed memory references */
101 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
102 #include <dmalloc.h>
103 #define ALLOC_NO_POOLS
104 #endif
105
106 #ifdef DEBUG_XEMACS
107 static int debug_allocation;
108 static int debug_allocation_backtrace_length;
109 #endif
110
111 /* Number of bytes of consing done since the last gc */
112 EMACS_INT consing_since_gc;
113 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
114
115 #define debug_allocation_backtrace()                            \
116 do {                                                            \
117   if (debug_allocation_backtrace_length > 0)                    \
118     debug_short_backtrace (debug_allocation_backtrace_length);  \
119 } while (0)
120
121 #ifdef DEBUG_XEMACS
122 #define INCREMENT_CONS_COUNTER(foosize, type)                   \
123   do {                                                          \
124     if (debug_allocation)                                       \
125       {                                                         \
126         stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
127         debug_allocation_backtrace ();                          \
128       }                                                         \
129     INCREMENT_CONS_COUNTER_1 (foosize);                         \
130   } while (0)
131 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type)           \
132   do {                                                          \
133     if (debug_allocation > 1)                                   \
134       {                                                         \
135         stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
136         debug_allocation_backtrace ();                          \
137       }                                                         \
138     INCREMENT_CONS_COUNTER_1 (foosize);                         \
139   } while (0)
140 #else
141 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
142 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
143   INCREMENT_CONS_COUNTER_1 (size)
144 #endif
145
146 #define DECREMENT_CONS_COUNTER(size) do {       \
147   consing_since_gc -= (size);                   \
148   if (consing_since_gc < 0)                     \
149     consing_since_gc = 0;                       \
150 } while (0)
151
152 /* Number of bytes of consing since gc before another gc should be done. */
153 EMACS_INT gc_cons_threshold;
154
155 /* Nonzero during gc */
156 int gc_in_progress;
157
158 /* Number of times GC has happened at this level or below.
159  * Level 0 is most volatile, contrary to usual convention.
160  *  (Of course, there's only one level at present) */
161 EMACS_INT gc_generation_number[1];
162
163 /* This is just for use by the printer, to allow things to print uniquely */
164 static int lrecord_uid_counter;
165
166 /* Nonzero when calling certain hooks or doing other things where
167    a GC would be bad */
168 int gc_currently_forbidden;
169
170 /* Hooks. */
171 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
172 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
173
174 /* "Garbage collecting" */
175 Lisp_Object Vgc_message;
176 Lisp_Object Vgc_pointer_glyph;
177 static CONST char gc_default_message[] = "Garbage collecting";
178 Lisp_Object Qgarbage_collecting;
179
180 #ifndef VIRT_ADDR_VARIES
181 extern
182 #endif /* VIRT_ADDR_VARIES */
183  EMACS_INT malloc_sbrk_used;
184
185 #ifndef VIRT_ADDR_VARIES
186 extern
187 #endif /* VIRT_ADDR_VARIES */
188  EMACS_INT malloc_sbrk_unused;
189
190 /* Non-zero means we're in the process of doing the dump */
191 int purify_flag;
192
193 #ifdef ERROR_CHECK_TYPECHECK
194
195 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
196
197 #endif
198
199 int
200 c_readonly (Lisp_Object obj)
201 {
202   return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
203 }
204
205 int
206 lisp_readonly (Lisp_Object obj)
207 {
208   return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
209 }
210
211 \f
212 /* Maximum amount of C stack to save when a GC happens.  */
213
214 #ifndef MAX_SAVE_STACK
215 #define MAX_SAVE_STACK 0 /* 16000 */
216 #endif
217
218 /* Non-zero means ignore malloc warnings.  Set during initialization.  */
219 int ignore_malloc_warnings;
220
221 \f
222 static void *breathing_space;
223
224 void
225 release_breathing_space (void)
226 {
227   if (breathing_space)
228     {
229       void *tmp = breathing_space;
230       breathing_space = 0;
231       xfree (tmp);
232     }
233 }
234
235 /* malloc calls this if it finds we are near exhausting storage */
236 void
237 malloc_warning (CONST char *str)
238 {
239   if (ignore_malloc_warnings)
240     return;
241
242   warn_when_safe
243     (Qmemory, Qcritical,
244      "%s\n"
245      "Killing some buffers may delay running out of memory.\n"
246      "However, certainly by the time you receive the 95%% warning,\n"
247      "you should clean up, kill this Emacs, and start a new one.",
248      str);
249 }
250
251 /* Called if malloc returns zero */
252 DOESNT_RETURN
253 memory_full (void)
254 {
255   /* Force a GC next time eval is called.
256      It's better to loop garbage-collecting (we might reclaim enough
257      to win) than to loop beeping and barfing "Memory exhausted"
258    */
259   consing_since_gc = gc_cons_threshold + 1;
260   release_breathing_space ();
261
262   /* Flush some histories which might conceivably contain garbalogical
263      inhibitors.  */
264   if (!NILP (Fboundp (Qvalues)))
265     Fset (Qvalues, Qnil);
266   Vcommand_history = Qnil;
267
268   error ("Memory exhausted");
269 }
270
271 /* like malloc and realloc but check for no memory left, and block input. */
272
273 #undef xmalloc
274 void *
275 xmalloc (size_t size)
276 {
277   void *val = malloc (size);
278
279   if (!val && (size != 0)) memory_full ();
280   return val;
281 }
282
283 #undef xcalloc
284 static void *
285 xcalloc (size_t nelem, size_t elsize)
286 {
287   void *val = calloc (nelem, elsize);
288
289   if (!val && (nelem != 0)) memory_full ();
290   return val;
291 }
292
293 void *
294 xmalloc_and_zero (size_t size)
295 {
296   return xcalloc (size, sizeof (char));
297 }
298
299 #undef xrealloc
300 void *
301 xrealloc (void *block, size_t size)
302 {
303   /* We must call malloc explicitly when BLOCK is 0, since some
304      reallocs don't do this.  */
305   void *val = block ? realloc (block, size) : malloc (size);
306
307   if (!val && (size != 0)) memory_full ();
308   return val;
309 }
310
311 void
312 #ifdef ERROR_CHECK_MALLOC
313 xfree_1 (void *block)
314 #else
315 xfree (void *block)
316 #endif
317 {
318 #ifdef ERROR_CHECK_MALLOC
319   /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
320      error until much later on for many system mallocs, such as
321      the one that comes with Solaris 2.3.  FMH!! */
322   assert (block != (void *) 0xDEADBEEF);
323   assert (block);
324 #endif /* ERROR_CHECK_MALLOC */
325   free (block);
326 }
327
328 #ifdef ERROR_CHECK_GC
329
330 #if SIZEOF_INT == 4
331 typedef unsigned int four_byte_t;
332 #elif SIZEOF_LONG == 4
333 typedef unsigned long four_byte_t;
334 #elif SIZEOF_SHORT == 4
335 typedef unsigned short four_byte_t;
336 #else
337 What kind of strange-ass system are we running on?
338 #endif
339
340 static void
341 deadbeef_memory (void *ptr, size_t size)
342 {
343   four_byte_t *ptr4 = (four_byte_t *) ptr;
344   size_t beefs = size >> 2;
345
346   /* In practice, size will always be a multiple of four.  */
347   while (beefs--)
348     (*ptr4++) = 0xDEADBEEF;
349 }
350
351 #else /* !ERROR_CHECK_GC */
352
353
354 #define deadbeef_memory(ptr, size)
355
356 #endif /* !ERROR_CHECK_GC */
357
358 #undef xstrdup
359 char *
360 xstrdup (CONST char *str)
361 {
362   int len = strlen (str) + 1;   /* for stupid terminating 0 */
363
364   void *val = xmalloc (len);
365   if (val == 0) return 0;
366   return (char *) memcpy (val, str, len);
367 }
368
369 #ifdef NEED_STRDUP
370 char *
371 strdup (CONST char *s)
372 {
373   return xstrdup (s);
374 }
375 #endif /* NEED_STRDUP */
376
377 \f
378 static void *
379 allocate_lisp_storage (size_t size)
380 {
381   return xmalloc (size);
382 }
383
384
385 /* lrecords are chained together through their "next.v" field.
386  * After doing the mark phase, the GC will walk this linked
387  *  list and free any record which hasn't been marked.
388  */
389 static struct lcrecord_header *all_lcrecords;
390
391 void *
392 alloc_lcrecord (size_t size, CONST struct lrecord_implementation *implementation)
393 {
394   struct lcrecord_header *lcheader;
395
396 #ifdef ERROR_CHECK_GC
397   if (implementation->static_size == 0)
398     assert (implementation->size_in_bytes_method);
399   else
400     assert (implementation->static_size == size);
401 #endif
402
403   lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
404   set_lheader_implementation (&(lcheader->lheader), implementation);
405   lcheader->next = all_lcrecords;
406 #if 1                           /* mly prefers to see small ID numbers */
407   lcheader->uid = lrecord_uid_counter++;
408 #else                           /* jwz prefers to see real addrs */
409   lcheader->uid = (int) &lcheader;
410 #endif
411   lcheader->free = 0;
412   all_lcrecords = lcheader;
413   INCREMENT_CONS_COUNTER (size, implementation->name);
414   return lcheader;
415 }
416
417 #if 0 /* Presently unused */
418 /* Very, very poor man's EGC?
419  * This may be slow and thrash pages all over the place.
420  *  Only call it if you really feel you must (and if the
421  *  lrecord was fairly recently allocated).
422  * Otherwise, just let the GC do its job -- that's what it's there for
423  */
424 void
425 free_lcrecord (struct lcrecord_header *lcrecord)
426 {
427   if (all_lcrecords == lcrecord)
428     {
429       all_lcrecords = lcrecord->next;
430     }
431   else
432     {
433       struct lrecord_header *header = all_lcrecords;
434       for (;;)
435         {
436           struct lrecord_header *next = header->next;
437           if (next == lcrecord)
438             {
439               header->next = lrecord->next;
440               break;
441             }
442           else if (next == 0)
443             abort ();
444           else
445             header = next;
446         }
447     }
448   if (lrecord->implementation->finalizer)
449     lrecord->implementation->finalizer (lrecord, 0);
450   xfree (lrecord);
451   return;
452 }
453 #endif /* Unused */
454
455
456 static void
457 disksave_object_finalization_1 (void)
458 {
459   struct lcrecord_header *header;
460
461   for (header = all_lcrecords; header; header = header->next)
462     {
463       if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
464           !header->free)
465         ((LHEADER_IMPLEMENTATION(&header->lheader)->finalizer)
466          (header, 1));
467     }
468 }
469
470 /* Semi-kludge -- lrecord_symbol_value_forward objects get stuck
471    in CONST space and you get SEGV's if you attempt to mark them.
472    This sits in lheader->implementation->marker. */
473
474 Lisp_Object
475 this_one_is_unmarkable (Lisp_Object obj)
476 {
477   abort ();
478   return Qnil;
479 }
480
481 \f
482 /************************************************************************/
483 /*                        Debugger support                              */
484 /************************************************************************/
485 /* Give gdb/dbx enough information to decode Lisp Objects.  We make
486    sure certain symbols are always defined, so gdb doesn't complain
487    about expressions in src/.gdbinit.  See src/.gdbinit or src/.dbxrc
488    to see how this is used.  */
489
490 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
491 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
492
493 #ifdef USE_UNION_TYPE
494 unsigned char dbg_USE_UNION_TYPE = 1;
495 #else
496 unsigned char dbg_USE_UNION_TYPE = 0;
497 #endif
498
499 unsigned char Lisp_Type_Int = 100;
500 unsigned char Lisp_Type_Cons = 101;
501 unsigned char Lisp_Type_String = 102;
502 unsigned char Lisp_Type_Vector = 103;
503 unsigned char Lisp_Type_Symbol = 104;
504
505 #ifndef MULE
506 unsigned char lrecord_char_table_entry;
507 unsigned char lrecord_charset;
508 #ifndef FILE_CODING
509 unsigned char lrecord_coding_system;
510 #endif
511 #endif
512
513 #if !((defined HAVE_X_WINDOWS) && \
514       (defined (HAVE_MENUBARS)   || \
515        defined (HAVE_SCROLLBARS) || \
516        defined (HAVE_DIALOGS)    || \
517        defined (HAVE_TOOLBARS)   || \
518        defined (HAVE_WIDGETS)))
519 unsigned char lrecord_popup_data;
520 #endif
521
522 #ifndef HAVE_TOOLBARS
523 unsigned char lrecord_toolbar_button;
524 #endif
525
526 #ifndef TOOLTALK
527 unsigned char lrecord_tooltalk_message;
528 unsigned char lrecord_tooltalk_pattern;
529 #endif
530
531 #ifndef HAVE_DATABASE
532 unsigned char lrecord_database;
533 #endif
534
535 unsigned char dbg_valbits = VALBITS;
536 unsigned char dbg_gctypebits = GCTYPEBITS;
537
538 /* Macros turned into functions for ease of debugging.
539    Debuggers don't know about macros! */
540 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
541 int
542 dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
543 {
544   return EQ (obj1, obj2);
545 }
546
547 \f
548 /************************************************************************/
549 /*                        Fixed-size type macros                        */
550 /************************************************************************/
551
552 /* For fixed-size types that are commonly used, we malloc() large blocks
553    of memory at a time and subdivide them into chunks of the correct
554    size for an object of that type.  This is more efficient than
555    malloc()ing each object separately because we save on malloc() time
556    and overhead due to the fewer number of malloc()ed blocks, and
557    also because we don't need any extra pointers within each object
558    to keep them threaded together for GC purposes.  For less common
559    (and frequently large-size) types, we use lcrecords, which are
560    malloc()ed individually and chained together through a pointer
561    in the lcrecord header.  lcrecords do not need to be fixed-size
562    (i.e. two objects of the same type need not have the same size;
563    however, the size of a particular object cannot vary dynamically).
564    It is also much easier to create a new lcrecord type because no
565    additional code needs to be added to alloc.c.  Finally, lcrecords
566    may be more efficient when there are only a small number of them.
567
568    The types that are stored in these large blocks (or "frob blocks")
569    are cons, float, compiled-function, symbol, marker, extent, event,
570    and string.
571
572    Note that strings are special in that they are actually stored in
573    two parts: a structure containing information about the string, and
574    the actual data associated with the string.  The former structure
575    (a struct Lisp_String) is a fixed-size structure and is managed the
576    same way as all the other such types.  This structure contains a
577    pointer to the actual string data, which is stored in structures of
578    type struct string_chars_block.  Each string_chars_block consists
579    of a pointer to a struct Lisp_String, followed by the data for that
580    string, followed by another pointer to a Lisp_String, followed by
581    the data for that string, etc.  At GC time, the data in these
582    blocks is compacted by searching sequentially through all the
583    blocks and compressing out any holes created by unmarked strings.
584    Strings that are more than a certain size (bigger than the size of
585    a string_chars_block, although something like half as big might
586    make more sense) are malloc()ed separately and not stored in
587    string_chars_blocks.  Furthermore, no one string stretches across
588    two string_chars_blocks.
589
590    Vectors are each malloc()ed separately, similar to lcrecords.
591
592    In the following discussion, we use conses, but it applies equally
593    well to the other fixed-size types.
594
595    We store cons cells inside of cons_blocks, allocating a new
596    cons_block with malloc() whenever necessary.  Cons cells reclaimed
597    by GC are put on a free list to be reallocated before allocating
598    any new cons cells from the latest cons_block.  Each cons_block is
599    just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
600    the versions in malloc.c and gmalloc.c) really allocates in units
601    of powers of two and uses 4 bytes for its own overhead.
602
603    What GC actually does is to search through all the cons_blocks,
604    from the most recently allocated to the oldest, and put all
605    cons cells that are not marked (whether or not they're already
606    free) on a cons_free_list.  The cons_free_list is a stack, and
607    so the cons cells in the oldest-allocated cons_block end up
608    at the head of the stack and are the first to be reallocated.
609    If any cons_block is entirely free, it is freed with free()
610    and its cons cells removed from the cons_free_list.  Because
611    the cons_free_list ends up basically in memory order, we have
612    a high locality of reference (assuming a reasonable turnover
613    of allocating and freeing) and have a reasonable probability
614    of entirely freeing up cons_blocks that have been more recently
615    allocated.  This stage is called the "sweep stage" of GC, and
616    is executed after the "mark stage", which involves starting
617    from all places that are known to point to in-use Lisp objects
618    (e.g. the obarray, where are all symbols are stored; the
619    current catches and condition-cases; the backtrace list of
620    currently executing functions; the gcpro list; etc.) and
621    recursively marking all objects that are accessible.
622
623    At the beginning of the sweep stage, the conses in the cons
624    blocks are in one of three states: in use and marked, in use
625    but not marked, and not in use (already freed).  Any conses
626    that are marked have been marked in the mark stage just
627    executed, because as part of the sweep stage we unmark any
628    marked objects.  The way we tell whether or not a cons cell
629    is in use is through the FREE_STRUCT_P macro.  This basically
630    looks at the first 4 bytes (or however many bytes a pointer
631    fits in) to see if all the bits in those bytes are 1.  The
632    resulting value (0xFFFFFFFF) is not a valid pointer and is
633    not a valid Lisp_Object.  All current fixed-size types have
634    a pointer or Lisp_Object as their first element with the
635    exception of strings; they have a size value, which can
636    never be less than zero, and so 0xFFFFFFFF is invalid for
637    strings as well.  Now assuming that a cons cell is in use,
638    the way we tell whether or not it is marked is to look at
639    the mark bit of its car (each Lisp_Object has one bit
640    reserved as a mark bit, in case it's needed).  Note that
641    different types of objects use different fields to indicate
642    whether the object is marked, but the principle is the same.
643
644    Conses on the free_cons_list are threaded through a pointer
645    stored in the bytes directly after the bytes that are set
646    to 0xFFFFFFFF (we cannot overwrite these because the cons
647    is still in a cons_block and needs to remain marked as
648    not in use for the next time that GC happens).  This
649    implies that all fixed-size types must be at least big
650    enough to store two pointers, which is indeed the case
651    for all current fixed-size types.
652
653    Some types of objects need additional "finalization" done
654    when an object is converted from in use to not in use;
655    this is the purpose of the ADDITIONAL_FREE_type macro.
656    For example, markers need to be removed from the chain
657    of markers that is kept in each buffer.  This is because
658    markers in a buffer automatically disappear if the marker
659    is no longer referenced anywhere (the same does not
660    apply to extents, however).
661
662    WARNING: Things are in an extremely bizarre state when
663    the ADDITIONAL_FREE_type macros are called, so beware!
664
665    When ERROR_CHECK_GC is defined, we do things differently
666    so as to maximize our chances of catching places where
667    there is insufficient GCPROing.  The thing we want to
668    avoid is having an object that we're using but didn't
669    GCPRO get freed by GC and then reallocated while we're
670    in the process of using it -- this will result in something
671    seemingly unrelated getting trashed, and is extremely
672    difficult to track down.  If the object gets freed but
673    not reallocated, we can usually catch this because we
674    set all bytes of a freed object to 0xDEADBEEF. (The
675    first four bytes, however, are 0xFFFFFFFF, and the next
676    four are a pointer used to chain freed objects together;
677    we play some tricks with this pointer to make it more
678    bogus, so crashes are more likely to occur right away.)
679
680    We want freed objects to stay free as long as possible,
681    so instead of doing what we do above, we maintain the
682    free objects in a first-in first-out queue.  We also
683    don't recompute the free list each GC, unlike above;
684    this ensures that the queue ordering is preserved.
685    [This means that we are likely to have worse locality
686    of reference, and that we can never free a frob block
687    once it's allocated. (Even if we know that all cells
688    in it are free, there's no easy way to remove all those
689    cells from the free list because the objects on the
690    free list are unlikely to be in memory order.)]
691    Furthermore, we never take objects off the free list
692    unless there's a large number (usually 1000, but
693    varies depending on type) of them already on the list.
694    This way, we ensure that an object that gets freed will
695    remain free for the next 1000 (or whatever) times that
696    an object of that type is allocated.  */
697
698 #ifndef MALLOC_OVERHEAD
699 #ifdef GNU_MALLOC
700 #define MALLOC_OVERHEAD 0
701 #elif defined (rcheck)
702 #define MALLOC_OVERHEAD 20
703 #else
704 #define MALLOC_OVERHEAD 8
705 #endif
706 #endif /* MALLOC_OVERHEAD */
707
708 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
709 /* If we released our reserve (due to running out of memory),
710    and we have a fair amount free once again,
711    try to set aside another reserve in case we run out once more.
712
713    This is called when a relocatable block is freed in ralloc.c.  */
714 void refill_memory_reserve (void);
715 void
716 refill_memory_reserve ()
717 {
718   if (breathing_space == 0)
719     breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
720 }
721 #endif
722
723 #ifdef ALLOC_NO_POOLS
724 # define TYPE_ALLOC_SIZE(type, structtype) 1
725 #else
726 # define TYPE_ALLOC_SIZE(type, structtype)                      \
727     ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *))  \
728      / sizeof (structtype))
729 #endif /* ALLOC_NO_POOLS */
730
731 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype)      \
732                                                         \
733 struct type##_block                                     \
734 {                                                       \
735   struct type##_block *prev;                            \
736   structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
737 };                                                      \
738                                                         \
739 static struct type##_block *current_##type##_block;     \
740 static int current_##type##_block_index;                \
741                                                         \
742 static structtype *type##_free_list;                    \
743 static structtype *type##_free_list_tail;               \
744                                                         \
745 static void                                             \
746 init_##type##_alloc (void)                              \
747 {                                                       \
748   current_##type##_block = 0;                           \
749   current_##type##_block_index =                        \
750     countof (current_##type##_block->block);            \
751   type##_free_list = 0;                                 \
752   type##_free_list_tail = 0;                            \
753 }                                                       \
754                                                         \
755 static int gc_count_num_##type##_in_use;                \
756 static int gc_count_num_##type##_freelist
757
758 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do {               \
759   if (current_##type##_block_index                                      \
760       == countof (current_##type##_block->block))                       \
761     {                                                                   \
762       struct type##_block *AFTFB_new = (struct type##_block *)          \
763         allocate_lisp_storage (sizeof (struct type##_block));           \
764       AFTFB_new->prev = current_##type##_block;                         \
765       current_##type##_block = AFTFB_new;                               \
766       current_##type##_block_index = 0;                                 \
767     }                                                                   \
768   (result) =                                                            \
769     &(current_##type##_block->block[current_##type##_block_index++]);   \
770 } while (0)
771
772 /* Allocate an instance of a type that is stored in blocks.
773    TYPE is the "name" of the type, STRUCTTYPE is the corresponding
774    structure type. */
775
776 #ifdef ERROR_CHECK_GC
777
778 /* Note: if you get crashes in this function, suspect incorrect calls
779    to free_cons() and friends.  This happened once because the cons
780    cell was not GC-protected and was getting collected before
781    free_cons() was called. */
782
783 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result)                  \
784 do                                                                       \
785 {                                                                        \
786   if (gc_count_num_##type##_freelist >                                   \
787       MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type)                           \
788     {                                                                    \
789       result = type##_free_list;                                         \
790       /* Before actually using the chain pointer, we complement all its  \
791          bits; see FREE_FIXED_TYPE(). */                                 \
792       type##_free_list =                                                 \
793         (structtype *) ~(unsigned long)                                  \
794           (* (structtype **) ((char *) result + sizeof (void *)));       \
795       gc_count_num_##type##_freelist--;                                  \
796     }                                                                    \
797   else                                                                   \
798     ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result);                       \
799   MARK_STRUCT_AS_NOT_FREE (result);                                      \
800 } while (0)
801
802 #else /* !ERROR_CHECK_GC */
803
804 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result)         \
805 do                                                              \
806 {                                                               \
807   if (type##_free_list)                                         \
808     {                                                           \
809       result = type##_free_list;                                \
810       type##_free_list =                                        \
811         * (structtype **) ((char *) result + sizeof (void *));  \
812     }                                                           \
813   else                                                          \
814     ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result);              \
815   MARK_STRUCT_AS_NOT_FREE (result);                             \
816 } while (0)
817
818 #endif /* !ERROR_CHECK_GC */
819
820 #define ALLOCATE_FIXED_TYPE(type, structtype, result)   \
821 do                                                      \
822 {                                                       \
823   ALLOCATE_FIXED_TYPE_1 (type, structtype, result);     \
824   INCREMENT_CONS_COUNTER (sizeof (structtype), #type);  \
825 } while (0)
826
827 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result)   \
828 do                                                              \
829 {                                                               \
830   ALLOCATE_FIXED_TYPE_1 (type, structtype, result);             \
831   NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type);  \
832 } while (0)
833
834 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
835    to a Lisp object and invalid as an actual Lisp_Object value.  We have
836    to make sure that this value cannot be an integer in Lisp_Object form.
837    0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
838    On a 32-bit system, the type bits will be non-zero, making the value
839    be a pointer, and the pointer will be misaligned.
840
841    Even if Emacs is run on some weirdo system that allows and allocates
842    byte-aligned pointers, this pointer is at the very top of the address
843    space and so it's almost inconceivable that it could ever be valid. */
844
845 #if INTBITS == 32
846 # define INVALID_POINTER_VALUE 0xFFFFFFFF
847 #elif INTBITS == 48
848 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
849 #elif INTBITS == 64
850 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
851 #else
852 You have some weird system and need to supply a reasonable value here.
853 #endif
854
855 #define FREE_STRUCT_P(ptr) \
856   (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
857 #define MARK_STRUCT_AS_FREE(ptr) \
858   (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
859 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
860   (* (void **) ptr = 0)
861
862 #ifdef ERROR_CHECK_GC
863
864 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr)              \
865 do { if (type##_free_list_tail)                                         \
866        {                                                                \
867          /* When we store the chain pointer, we complement all          \
868             its bits; this should significantly increase its            \
869             bogosity in case someone tries to use the value, and        \
870             should make us dump faster if someone stores something      \
871             over the pointer because when it gets un-complemented in    \
872             ALLOCATED_FIXED_TYPE(), the resulting pointer will be       \
873             extremely bogus. */                                         \
874          * (structtype **)                                              \
875            ((char *) type##_free_list_tail + sizeof (void *)) =         \
876              (structtype *) ~(unsigned long) ptr;                       \
877        }                                                                \
878      else                                                               \
879        type##_free_list = ptr;                                          \
880      type##_free_list_tail = ptr;                                       \
881    } while (0)
882
883 #else /* !ERROR_CHECK_GC */
884
885 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr)      \
886 do { * (structtype **) ((char *) (ptr) + sizeof (void *)) =     \
887        type##_free_list;                                        \
888      type##_free_list = (ptr);                                  \
889    } while (0)
890
891 #endif /* !ERROR_CHECK_GC */
892
893 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
894
895 #define FREE_FIXED_TYPE(type, structtype, ptr) do {             \
896   structtype *FFT_ptr = (ptr);                                  \
897   ADDITIONAL_FREE_##type (FFT_ptr);                             \
898   deadbeef_memory (FFT_ptr, sizeof (structtype));               \
899   PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr);      \
900   MARK_STRUCT_AS_FREE (FFT_ptr);                                \
901 } while (0)
902
903 /* Like FREE_FIXED_TYPE() but used when we are explicitly
904    freeing a structure through free_cons(), free_marker(), etc.
905    rather than through the normal process of sweeping.
906    We attempt to undo the changes made to the allocation counters
907    as a result of this structure being allocated.  This is not
908    completely necessary but helps keep things saner: e.g. this way,
909    repeatedly allocating and freeing a cons will not result in
910    the consing-since-gc counter advancing, which would cause a GC
911    and somewhat defeat the purpose of explicitly freeing. */
912
913 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr)   \
914 do { FREE_FIXED_TYPE (type, structtype, ptr);                   \
915      DECREMENT_CONS_COUNTER (sizeof (structtype));              \
916      gc_count_num_##type##_freelist++;                          \
917    } while (0)
918
919
920 \f
921 /************************************************************************/
922 /*                         Cons allocation                              */
923 /************************************************************************/
924
925 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons);
926 /* conses are used and freed so often that we set this really high */
927 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
928 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
929
930 static Lisp_Object
931 mark_cons (Lisp_Object obj)
932 {
933   if (NILP (XCDR (obj)))
934     return XCAR (obj);
935
936   mark_object (XCAR (obj));
937   return XCDR (obj);
938 }
939
940 static int
941 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
942 {
943   while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1))
944     {
945       ob1 = XCDR (ob1);
946       ob2 = XCDR (ob2);
947       if (! CONSP (ob1) || ! CONSP (ob2))
948         return internal_equal (ob1, ob2, depth + 1);
949     }
950   return 0;
951 }
952
953 static const struct lrecord_description cons_description[] = {
954   { XD_LISP_OBJECT, offsetof (Lisp_Cons, car) },
955   { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr) },
956   { XD_END }
957 };
958
959 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
960                                      mark_cons, print_cons, 0,
961                                      cons_equal,
962                                      /*
963                                       * No `hash' method needed.
964                                       * internal_hash knows how to
965                                       * handle conses.
966                                       */
967                                      0,
968                                      cons_description,
969                                      Lisp_Cons);
970
971 DEFUN ("cons", Fcons, 2, 2, 0, /*
972 Create a new cons, give it CAR and CDR as components, and return it.
973 */
974        (car, cdr))
975 {
976   /* This cannot GC. */
977   Lisp_Object val;
978   Lisp_Cons *c;
979
980   ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
981   set_lheader_implementation (&(c->lheader), &lrecord_cons);
982   XSETCONS (val, c);
983   c->car = car;
984   c->cdr = cdr;
985   return val;
986 }
987
988 /* This is identical to Fcons() but it used for conses that we're
989    going to free later, and is useful when trying to track down
990    "real" consing. */
991 Lisp_Object
992 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
993 {
994   Lisp_Object val;
995   Lisp_Cons *c;
996
997   NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
998   set_lheader_implementation (&(c->lheader), &lrecord_cons);
999   XSETCONS (val, c);
1000   XCAR (val) = car;
1001   XCDR (val) = cdr;
1002   return val;
1003 }
1004
1005 DEFUN ("list", Flist, 0, MANY, 0, /*
1006 Return a newly created list with specified arguments as elements.
1007 Any number of arguments, even zero arguments, are allowed.
1008 */
1009        (int nargs, Lisp_Object *args))
1010 {
1011   Lisp_Object val = Qnil;
1012   Lisp_Object *argp = args + nargs;
1013
1014   while (argp > args)
1015     val = Fcons (*--argp, val);
1016   return val;
1017 }
1018
1019 Lisp_Object
1020 list1 (Lisp_Object obj0)
1021 {
1022   /* This cannot GC. */
1023   return Fcons (obj0, Qnil);
1024 }
1025
1026 Lisp_Object
1027 list2 (Lisp_Object obj0, Lisp_Object obj1)
1028 {
1029   /* This cannot GC. */
1030   return Fcons (obj0, Fcons (obj1, Qnil));
1031 }
1032
1033 Lisp_Object
1034 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1035 {
1036   /* This cannot GC. */
1037   return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1038 }
1039
1040 Lisp_Object
1041 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1042 {
1043   /* This cannot GC. */
1044   return Fcons (obj0, Fcons (obj1, obj2));
1045 }
1046
1047 Lisp_Object
1048 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1049 {
1050   return Fcons (Fcons (key, value), alist);
1051 }
1052
1053 Lisp_Object
1054 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1055 {
1056   /* This cannot GC. */
1057   return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1058 }
1059
1060 Lisp_Object
1061 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1062        Lisp_Object obj4)
1063 {
1064   /* This cannot GC. */
1065   return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1066 }
1067
1068 Lisp_Object
1069 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1070        Lisp_Object obj4, Lisp_Object obj5)
1071 {
1072   /* This cannot GC. */
1073   return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1074 }
1075
1076 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1077 Return a new list of length LENGTH, with each element being INIT.
1078 */
1079        (length, init))
1080 {
1081   CHECK_NATNUM (length);
1082
1083   {
1084     Lisp_Object val = Qnil;
1085     size_t size = XINT (length);
1086
1087     while (size--)
1088       val = Fcons (init, val);
1089     return val;
1090   }
1091 }
1092
1093 \f
1094 /************************************************************************/
1095 /*                        Float allocation                              */
1096 /************************************************************************/
1097
1098 #ifdef LISP_FLOAT_TYPE
1099
1100 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float);
1101 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1102
1103 Lisp_Object
1104 make_float (double float_value)
1105 {
1106   Lisp_Object val;
1107   Lisp_Float *f;
1108
1109   ALLOCATE_FIXED_TYPE (float, Lisp_Float, f);
1110
1111   /* Avoid dump-time `uninitialized memory read' purify warnings. */
1112   if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
1113     xzero (*f);
1114
1115   set_lheader_implementation (&(f->lheader), &lrecord_float);
1116   float_data (f) = float_value;
1117   XSETFLOAT (val, f);
1118   return val;
1119 }
1120
1121 #endif /* LISP_FLOAT_TYPE */
1122
1123 \f
1124 /************************************************************************/
1125 /*                         Vector allocation                            */
1126 /************************************************************************/
1127
1128 static Lisp_Object
1129 mark_vector (Lisp_Object obj)
1130 {
1131   Lisp_Vector *ptr = XVECTOR (obj);
1132   int len = vector_length (ptr);
1133   int i;
1134
1135   for (i = 0; i < len - 1; i++)
1136     mark_object (ptr->contents[i]);
1137   return (len > 0) ? ptr->contents[len - 1] : Qnil;
1138 }
1139
1140 static size_t
1141 size_vector (CONST void *lheader)
1142 {
1143   return STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents,
1144                                  ((Lisp_Vector *) lheader)->size);
1145 }
1146
1147 static int
1148 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1149 {
1150   int len = XVECTOR_LENGTH (obj1);
1151   if (len != XVECTOR_LENGTH (obj2))
1152     return 0;
1153
1154   {
1155     Lisp_Object *ptr1 = XVECTOR_DATA (obj1);
1156     Lisp_Object *ptr2 = XVECTOR_DATA (obj2);
1157     while (len--)
1158       if (!internal_equal (*ptr1++, *ptr2++, depth + 1))
1159         return 0;
1160   }
1161   return 1;
1162 }
1163
1164 static const struct lrecord_description vector_description[] = {
1165   { XD_LONG,              offsetof (Lisp_Vector, size) },
1166   { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
1167   { XD_END }
1168 };
1169
1170 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1171                                        mark_vector, print_vector, 0,
1172                                        vector_equal,
1173                                        /*
1174                                         * No `hash' method needed for
1175                                         * vectors.  internal_hash
1176                                         * knows how to handle vectors.
1177                                         */
1178                                        0,
1179                                        vector_description,
1180                                        size_vector, Lisp_Vector);
1181
1182 /* #### should allocate `small' vectors from a frob-block */
1183 static Lisp_Vector *
1184 make_vector_internal (size_t sizei)
1185 {
1186   /* no vector_next */
1187   size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
1188   Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
1189
1190   p->size = sizei;
1191   return p;
1192 }
1193
1194 Lisp_Object
1195 make_vector (size_t length, Lisp_Object init)
1196 {
1197   Lisp_Vector *vecp = make_vector_internal (length);
1198   Lisp_Object *p = vector_data (vecp);
1199
1200   while (length--)
1201     *p++ = init;
1202
1203   {
1204     Lisp_Object vector;
1205     XSETVECTOR (vector, vecp);
1206     return vector;
1207   }
1208 }
1209
1210 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1211 Return a new vector of length LENGTH, with each element being INIT.
1212 See also the function `vector'.
1213 */
1214        (length, init))
1215 {
1216   CONCHECK_NATNUM (length);
1217   return make_vector (XINT (length), init);
1218 }
1219
1220 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1221 Return a newly created vector with specified arguments as elements.
1222 Any number of arguments, even zero arguments, are allowed.
1223 */
1224        (int nargs, Lisp_Object *args))
1225 {
1226   Lisp_Vector *vecp = make_vector_internal (nargs);
1227   Lisp_Object *p = vector_data (vecp);
1228
1229   while (nargs--)
1230     *p++ = *args++;
1231
1232   {
1233     Lisp_Object vector;
1234     XSETVECTOR (vector, vecp);
1235     return vector;
1236   }
1237 }
1238
1239 Lisp_Object
1240 vector1 (Lisp_Object obj0)
1241 {
1242   return Fvector (1, &obj0);
1243 }
1244
1245 Lisp_Object
1246 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1247 {
1248   Lisp_Object args[2];
1249   args[0] = obj0;
1250   args[1] = obj1;
1251   return Fvector (2, args);
1252 }
1253
1254 Lisp_Object
1255 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1256 {
1257   Lisp_Object args[3];
1258   args[0] = obj0;
1259   args[1] = obj1;
1260   args[2] = obj2;
1261   return Fvector (3, args);
1262 }
1263
1264 #if 0 /* currently unused */
1265
1266 Lisp_Object
1267 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1268          Lisp_Object obj3)
1269 {
1270   Lisp_Object args[4];
1271   args[0] = obj0;
1272   args[1] = obj1;
1273   args[2] = obj2;
1274   args[3] = obj3;
1275   return Fvector (4, args);
1276 }
1277
1278 Lisp_Object
1279 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1280          Lisp_Object obj3, Lisp_Object obj4)
1281 {
1282   Lisp_Object args[5];
1283   args[0] = obj0;
1284   args[1] = obj1;
1285   args[2] = obj2;
1286   args[3] = obj3;
1287   args[4] = obj4;
1288   return Fvector (5, args);
1289 }
1290
1291 Lisp_Object
1292 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1293          Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1294 {
1295   Lisp_Object args[6];
1296   args[0] = obj0;
1297   args[1] = obj1;
1298   args[2] = obj2;
1299   args[3] = obj3;
1300   args[4] = obj4;
1301   args[5] = obj5;
1302   return Fvector (6, args);
1303 }
1304
1305 Lisp_Object
1306 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1307          Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1308          Lisp_Object obj6)
1309 {
1310   Lisp_Object args[7];
1311   args[0] = obj0;
1312   args[1] = obj1;
1313   args[2] = obj2;
1314   args[3] = obj3;
1315   args[4] = obj4;
1316   args[5] = obj5;
1317   args[6] = obj6;
1318   return Fvector (7, args);
1319 }
1320
1321 Lisp_Object
1322 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1323          Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1324          Lisp_Object obj6, Lisp_Object obj7)
1325 {
1326   Lisp_Object args[8];
1327   args[0] = obj0;
1328   args[1] = obj1;
1329   args[2] = obj2;
1330   args[3] = obj3;
1331   args[4] = obj4;
1332   args[5] = obj5;
1333   args[6] = obj6;
1334   args[7] = obj7;
1335   return Fvector (8, args);
1336 }
1337 #endif /* unused */
1338
1339 /************************************************************************/
1340 /*                       Bit Vector allocation                          */
1341 /************************************************************************/
1342
1343 static Lisp_Object all_bit_vectors;
1344
1345 /* #### should allocate `small' bit vectors from a frob-block */
1346 static Lisp_Bit_Vector *
1347 make_bit_vector_internal (size_t sizei)
1348 {
1349   size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
1350   size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits, num_longs);
1351   Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1352   set_lheader_implementation (&(p->lheader), &lrecord_bit_vector);
1353
1354   INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1355
1356   bit_vector_length (p) = sizei;
1357   bit_vector_next   (p) = all_bit_vectors;
1358   /* make sure the extra bits in the last long are 0; the calling
1359      functions might not set them. */
1360   p->bits[num_longs - 1] = 0;
1361   XSETBIT_VECTOR (all_bit_vectors, p);
1362   return p;
1363 }
1364
1365 Lisp_Object
1366 make_bit_vector (size_t length, Lisp_Object init)
1367 {
1368   Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1369   size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
1370
1371   CHECK_BIT (init);
1372
1373   if (ZEROP (init))
1374     memset (p->bits, 0, num_longs * sizeof (long));
1375   else
1376     {
1377       size_t bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1378       memset (p->bits, ~0, num_longs * sizeof (long));
1379       /* But we have to make sure that the unused bits in the
1380          last long are 0, so that equal/hash is easy. */
1381       if (bits_in_last)
1382         p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1383     }
1384
1385   {
1386     Lisp_Object bit_vector;
1387     XSETBIT_VECTOR (bit_vector, p);
1388     return bit_vector;
1389   }
1390 }
1391
1392 Lisp_Object
1393 make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
1394 {
1395   int i;
1396   Lisp_Bit_Vector *p = make_bit_vector_internal (length);
1397
1398   for (i = 0; i < length; i++)
1399     set_bit_vector_bit (p, i, bytevec[i]);
1400
1401   {
1402     Lisp_Object bit_vector;
1403     XSETBIT_VECTOR (bit_vector, p);
1404     return bit_vector;
1405   }
1406 }
1407
1408 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1409 Return a new bit vector of length LENGTH. with each bit being INIT.
1410 Each element is set to INIT.  See also the function `bit-vector'.
1411 */
1412        (length, init))
1413 {
1414   CONCHECK_NATNUM (length);
1415
1416   return make_bit_vector (XINT (length), init);
1417 }
1418
1419 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1420 Return a newly created bit vector with specified arguments as elements.
1421 Any number of arguments, even zero arguments, are allowed.
1422 */
1423        (int nargs, Lisp_Object *args))
1424 {
1425   int i;
1426   Lisp_Bit_Vector *p = make_bit_vector_internal (nargs);
1427
1428   for (i = 0; i < nargs; i++)
1429     {
1430       CHECK_BIT (args[i]);
1431       set_bit_vector_bit (p, i, !ZEROP (args[i]));
1432     }
1433
1434   {
1435     Lisp_Object bit_vector;
1436     XSETBIT_VECTOR (bit_vector, p);
1437     return bit_vector;
1438   }
1439 }
1440
1441 \f
1442 /************************************************************************/
1443 /*                   Compiled-function allocation                       */
1444 /************************************************************************/
1445
1446 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
1447 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1448
1449 static Lisp_Object
1450 make_compiled_function (void)
1451 {
1452   Lisp_Compiled_Function *f;
1453   Lisp_Object fun;
1454
1455   ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
1456   set_lheader_implementation (&(f->lheader), &lrecord_compiled_function);
1457
1458   f->stack_depth = 0;
1459   f->specpdl_depth = 0;
1460   f->flags.documentationp = 0;
1461   f->flags.interactivep = 0;
1462   f->flags.domainp = 0; /* I18N3 */
1463   f->instructions = Qzero;
1464   f->constants = Qzero;
1465   f->arglist = Qnil;
1466   f->doc_and_interactive = Qnil;
1467 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1468   f->annotated = Qnil;
1469 #endif
1470   XSETCOMPILED_FUNCTION (fun, f);
1471   return fun;
1472 }
1473
1474 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1475 Return a new compiled-function object.
1476 Usage: (arglist instructions constants stack-depth
1477         &optional doc-string interactive)
1478 Note that, unlike all other emacs-lisp functions, calling this with five
1479 arguments is NOT the same as calling it with six arguments, the last of
1480 which is nil.  If the INTERACTIVE arg is specified as nil, then that means
1481 that this function was defined with `(interactive)'.  If the arg is not
1482 specified, then that means the function is not interactive.
1483 This is terrible behavior which is retained for compatibility with old
1484 `.elc' files which expect these semantics.
1485 */
1486        (int nargs, Lisp_Object *args))
1487 {
1488 /* In a non-insane world this function would have this arglist...
1489    (arglist instructions constants stack_depth &optional doc_string interactive)
1490  */
1491   Lisp_Object fun = make_compiled_function ();
1492   Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
1493
1494   Lisp_Object arglist      = args[0];
1495   Lisp_Object instructions = args[1];
1496   Lisp_Object constants    = args[2];
1497   Lisp_Object stack_depth  = args[3];
1498   Lisp_Object doc_string   = (nargs > 4) ? args[4] : Qnil;
1499   Lisp_Object interactive  = (nargs > 5) ? args[5] : Qunbound;
1500
1501   if (nargs < 4 || nargs > 6)
1502     return Fsignal (Qwrong_number_of_arguments,
1503                     list2 (intern ("make-byte-code"), make_int (nargs)));
1504
1505   /* Check for valid formal parameter list now, to allow us to use
1506      SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
1507   {
1508     Lisp_Object symbol, tail;
1509     EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
1510       {
1511         CHECK_SYMBOL (symbol);
1512         if (EQ (symbol, Qt)   ||
1513             EQ (symbol, Qnil) ||
1514             SYMBOL_IS_KEYWORD (symbol))
1515           signal_simple_error_2
1516             ("Invalid constant symbol in formal parameter list",
1517              symbol, arglist);
1518       }
1519   }
1520   f->arglist = arglist;
1521
1522   /* `instructions' is a string or a cons (string . int) for a
1523      lazy-loaded function. */
1524   if (CONSP (instructions))
1525     {
1526       CHECK_STRING (XCAR (instructions));
1527       CHECK_INT (XCDR (instructions));
1528     }
1529   else
1530     {
1531       CHECK_STRING (instructions);
1532     }
1533   f->instructions = instructions;
1534
1535   if (!NILP (constants))
1536     CHECK_VECTOR (constants);
1537   f->constants = constants;
1538
1539   CHECK_NATNUM (stack_depth);
1540   f->stack_depth = XINT (stack_depth);
1541
1542 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1543   if (!NILP (Vcurrent_compiled_function_annotation))
1544     f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
1545   else if (!NILP (Vload_file_name_internal_the_purecopy))
1546     f->annotated = Vload_file_name_internal_the_purecopy;
1547   else if (!NILP (Vload_file_name_internal))
1548     {
1549       struct gcpro gcpro1;
1550       GCPRO1 (fun);             /* don't let fun get reaped */
1551       Vload_file_name_internal_the_purecopy =
1552         Ffile_name_nondirectory (Vload_file_name_internal);
1553       f->annotated = Vload_file_name_internal_the_purecopy;
1554       UNGCPRO;
1555     }
1556 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1557
1558   /* doc_string may be nil, string, int, or a cons (string . int).
1559      interactive may be list or string (or unbound). */
1560   f->doc_and_interactive = Qunbound;
1561 #ifdef I18N3
1562   if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
1563     f->doc_and_interactive = Vfile_domain;
1564 #endif
1565   if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
1566     {
1567       f->doc_and_interactive
1568         = (UNBOUNDP (f->doc_and_interactive) ? interactive :
1569            Fcons (interactive, f->doc_and_interactive));
1570     }
1571   if ((f->flags.documentationp = !NILP (doc_string)) != 0)
1572     {
1573       f->doc_and_interactive
1574         = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
1575            Fcons (doc_string, f->doc_and_interactive));
1576     }
1577   if (UNBOUNDP (f->doc_and_interactive))
1578     f->doc_and_interactive = Qnil;
1579
1580   return fun;
1581 }
1582
1583 \f
1584 /************************************************************************/
1585 /*                          Symbol allocation                           */
1586 /************************************************************************/
1587
1588 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol);
1589 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1590
1591 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1592 Return a newly allocated uninterned symbol whose name is NAME.
1593 Its value and function definition are void, and its property list is nil.
1594 */
1595        (name))
1596 {
1597   Lisp_Object val;
1598   Lisp_Symbol *p;
1599
1600   CHECK_STRING (name);
1601
1602   ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
1603   set_lheader_implementation (&(p->lheader), &lrecord_symbol);
1604   p->name     = XSTRING (name);
1605   p->plist    = Qnil;
1606   p->value    = Qunbound;
1607   p->function = Qunbound;
1608   symbol_next (p) = 0;
1609   XSETSYMBOL (val, p);
1610   return val;
1611 }
1612
1613 \f
1614 /************************************************************************/
1615 /*                         Extent allocation                            */
1616 /************************************************************************/
1617
1618 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1619 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1620
1621 struct extent *
1622 allocate_extent (void)
1623 {
1624   struct extent *e;
1625
1626   ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1627   set_lheader_implementation (&(e->lheader), &lrecord_extent);
1628   extent_object (e) = Qnil;
1629   set_extent_start (e, -1);
1630   set_extent_end (e, -1);
1631   e->plist = Qnil;
1632
1633   xzero (e->flags);
1634
1635   extent_face (e) = Qnil;
1636   e->flags.end_open = 1;  /* default is for endpoints to behave like markers */
1637   e->flags.detachable = 1;
1638
1639   return e;
1640 }
1641
1642 \f
1643 /************************************************************************/
1644 /*                         Event allocation                             */
1645 /************************************************************************/
1646
1647 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event);
1648 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1649
1650 Lisp_Object
1651 allocate_event (void)
1652 {
1653   Lisp_Object val;
1654   Lisp_Event *e;
1655
1656   ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
1657   set_lheader_implementation (&(e->lheader), &lrecord_event);
1658
1659   XSETEVENT (val, e);
1660   return val;
1661 }
1662
1663 \f
1664 /************************************************************************/
1665 /*                       Marker allocation                              */
1666 /************************************************************************/
1667
1668 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker);
1669 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1670
1671 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1672 Return a new marker which does not point at any place.
1673 */
1674        ())
1675 {
1676   Lisp_Object val;
1677   Lisp_Marker *p;
1678
1679   ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1680   set_lheader_implementation (&(p->lheader), &lrecord_marker);
1681   p->buffer = 0;
1682   p->memind = 0;
1683   marker_next (p) = 0;
1684   marker_prev (p) = 0;
1685   p->insertion_type = 0;
1686   XSETMARKER (val, p);
1687   return val;
1688 }
1689
1690 Lisp_Object
1691 noseeum_make_marker (void)
1692 {
1693   Lisp_Object val;
1694   Lisp_Marker *p;
1695
1696   NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
1697   set_lheader_implementation (&(p->lheader), &lrecord_marker);
1698   p->buffer = 0;
1699   p->memind = 0;
1700   marker_next (p) = 0;
1701   marker_prev (p) = 0;
1702   p->insertion_type = 0;
1703   XSETMARKER (val, p);
1704   return val;
1705 }
1706
1707 \f
1708 /************************************************************************/
1709 /*                        String allocation                             */
1710 /************************************************************************/
1711
1712 /* The data for "short" strings generally resides inside of structs of type
1713    string_chars_block. The Lisp_String structure is allocated just like any
1714    other Lisp object (except for vectors), and these are freelisted when
1715    they get garbage collected. The data for short strings get compacted,
1716    but the data for large strings do not.
1717
1718    Previously Lisp_String structures were relocated, but this caused a lot
1719    of bus-errors because the C code didn't include enough GCPRO's for
1720    strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1721    that the reference would get relocated).
1722
1723    This new method makes things somewhat bigger, but it is MUCH safer.  */
1724
1725 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String);
1726 /* strings are used and freed quite often */
1727 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
1728 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
1729
1730 static Lisp_Object
1731 mark_string (Lisp_Object obj)
1732 {
1733   Lisp_String *ptr = XSTRING (obj);
1734
1735   if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
1736     flush_cached_extent_info (XCAR (ptr->plist));
1737   return ptr->plist;
1738 }
1739
1740 static int
1741 string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1742 {
1743   Bytecount len;
1744   return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
1745           !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
1746 }
1747
1748 static const struct lrecord_description string_description[] = {
1749   { XD_BYTECOUNT,       offsetof (Lisp_String, size) },
1750   { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data), XD_INDIRECT(0, 1) },
1751   { XD_LISP_OBJECT,     offsetof (Lisp_String, plist) },
1752   { XD_END }
1753 };
1754
1755 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
1756                                      mark_string, print_string,
1757                                      /*
1758                                       * No `finalize', or `hash' methods.
1759                                       * internal_hash already knows how
1760                                       * to hash strings and finalization
1761                                       * is done with the
1762                                       * ADDITIONAL_FREE_string macro,
1763                                       * which is the standard way to do
1764                                       * finalization when using
1765                                       * SWEEP_FIXED_TYPE_BLOCK().
1766                                       */
1767                                      0, string_equal, 0,
1768                                      string_description,
1769                                      Lisp_String);
1770
1771 /* String blocks contain this many useful bytes. */
1772 #define STRING_CHARS_BLOCK_SIZE                                 \
1773 ((Bytecount) (8192 - MALLOC_OVERHEAD -                          \
1774               ((2 * sizeof (struct string_chars_block *))       \
1775                + sizeof (EMACS_INT))))
1776 /* Block header for small strings. */
1777 struct string_chars_block
1778 {
1779   EMACS_INT pos;
1780   struct string_chars_block *next;
1781   struct string_chars_block *prev;
1782   /* Contents of string_chars_block->string_chars are interleaved
1783      string_chars structures (see below) and the actual string data */
1784   unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
1785 };
1786
1787 static struct string_chars_block *first_string_chars_block;
1788 static struct string_chars_block *current_string_chars_block;
1789
1790 /* If SIZE is the length of a string, this returns how many bytes
1791  *  the string occupies in string_chars_block->string_chars
1792  *  (including alignment padding).
1793  */
1794 #define STRING_FULLSIZE(size) \
1795    ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\
1796                ALIGNOF (Lisp_String *))
1797
1798 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
1799 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
1800
1801 struct string_chars
1802 {
1803   Lisp_String *string;
1804   unsigned char chars[1];
1805 };
1806
1807 struct unused_string_chars
1808 {
1809   Lisp_String *string;
1810   EMACS_INT fullsize;
1811 };
1812
1813 static void
1814 init_string_chars_alloc (void)
1815 {
1816   first_string_chars_block = xnew (struct string_chars_block);
1817   first_string_chars_block->prev = 0;
1818   first_string_chars_block->next = 0;
1819   first_string_chars_block->pos = 0;
1820   current_string_chars_block = first_string_chars_block;
1821 }
1822
1823 static struct string_chars *
1824 allocate_string_chars_struct (Lisp_String *string_it_goes_with,
1825                               EMACS_INT fullsize)
1826 {
1827   struct string_chars *s_chars;
1828
1829   if (fullsize <=
1830       (countof (current_string_chars_block->string_chars)
1831        - current_string_chars_block->pos))
1832     {
1833       /* This string can fit in the current string chars block */
1834       s_chars = (struct string_chars *)
1835         (current_string_chars_block->string_chars
1836          + current_string_chars_block->pos);
1837       current_string_chars_block->pos += fullsize;
1838     }
1839   else
1840     {
1841       /* Make a new current string chars block */
1842       struct string_chars_block *new_scb = xnew (struct string_chars_block);
1843
1844       current_string_chars_block->next = new_scb;
1845       new_scb->prev = current_string_chars_block;
1846       new_scb->next = 0;
1847       current_string_chars_block = new_scb;
1848       new_scb->pos = fullsize;
1849       s_chars = (struct string_chars *)
1850         current_string_chars_block->string_chars;
1851     }
1852
1853   s_chars->string = string_it_goes_with;
1854
1855   INCREMENT_CONS_COUNTER (fullsize, "string chars");
1856
1857   return s_chars;
1858 }
1859
1860 Lisp_Object
1861 make_uninit_string (Bytecount length)
1862 {
1863   Lisp_String *s;
1864   EMACS_INT fullsize = STRING_FULLSIZE (length);
1865   Lisp_Object val;
1866
1867   assert (length >= 0 && fullsize > 0);
1868
1869   /* Allocate the string header */
1870   ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
1871   set_lheader_implementation (&(s->lheader), &lrecord_string);
1872
1873   set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
1874                    ? xnew_array (Bufbyte, length + 1)
1875                    : allocate_string_chars_struct (s, fullsize)->chars);
1876
1877   set_string_length (s, length);
1878   s->plist = Qnil;
1879
1880   set_string_byte (s, length, 0);
1881
1882   XSETSTRING (val, s);
1883   return val;
1884 }
1885
1886 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1887 static void verify_string_chars_integrity (void);
1888 #endif
1889
1890 /* Resize the string S so that DELTA bytes can be inserted starting
1891    at POS.  If DELTA < 0, it means deletion starting at POS.  If
1892    POS < 0, resize the string but don't copy any characters.  Use
1893    this if you're planning on completely overwriting the string.
1894 */
1895
1896 void
1897 resize_string (Lisp_String *s, Bytecount pos, Bytecount delta)
1898 {
1899   Bytecount oldfullsize, newfullsize;
1900 #ifdef VERIFY_STRING_CHARS_INTEGRITY
1901   verify_string_chars_integrity ();
1902 #endif
1903
1904 #ifdef ERROR_CHECK_BUFPOS
1905   if (pos >= 0)
1906     {
1907       assert (pos <= string_length (s));
1908       if (delta < 0)
1909         assert (pos + (-delta) <= string_length (s));
1910     }
1911   else
1912     {
1913       if (delta < 0)
1914         assert ((-delta) <= string_length (s));
1915     }
1916 #endif /* ERROR_CHECK_BUFPOS */
1917
1918   if (delta == 0)
1919     /* simplest case: no size change. */
1920     return;
1921
1922   if (pos >= 0 && delta < 0)
1923     /* If DELTA < 0, the functions below will delete the characters
1924        before POS.  We want to delete characters *after* POS, however,
1925        so convert this to the appropriate form. */
1926     pos += -delta;
1927
1928   oldfullsize = STRING_FULLSIZE (string_length (s));
1929   newfullsize = STRING_FULLSIZE (string_length (s) + delta);
1930
1931   if (BIG_STRING_FULLSIZE_P (oldfullsize))
1932     {
1933       if (BIG_STRING_FULLSIZE_P (newfullsize))
1934         {
1935           /* Both strings are big.  We can just realloc().
1936              But careful!  If the string is shrinking, we have to
1937              memmove() _before_ realloc(), and if growing, we have to
1938              memmove() _after_ realloc() - otherwise the access is
1939              illegal, and we might crash. */
1940           Bytecount len = string_length (s) + 1 - pos;
1941
1942           if (delta < 0 && pos >= 0)
1943             memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1944           set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
1945                                                     string_length (s) + delta + 1));
1946           if (delta > 0 && pos >= 0)
1947             memmove (string_data (s) + pos + delta, string_data (s) + pos, len);
1948         }
1949       else /* String has been demoted from BIG_STRING. */
1950         {
1951           Bufbyte *new_data =
1952             allocate_string_chars_struct (s, newfullsize)->chars;
1953           Bufbyte *old_data = string_data (s);
1954
1955           if (pos >= 0)
1956             {
1957               memcpy (new_data, old_data, pos);
1958               memcpy (new_data + pos + delta, old_data + pos,
1959                       string_length (s) + 1 - pos);
1960             }
1961           set_string_data (s, new_data);
1962           xfree (old_data);
1963         }
1964     }
1965   else /* old string is small */
1966     {
1967       if (oldfullsize == newfullsize)
1968         {
1969           /* special case; size change but the necessary
1970              allocation size won't change (up or down; code
1971              somewhere depends on there not being any unused
1972              allocation space, modulo any alignment
1973              constraints). */
1974           if (pos >= 0)
1975             {
1976               Bufbyte *addroff = pos + string_data (s);
1977
1978               memmove (addroff + delta, addroff,
1979                        /* +1 due to zero-termination. */
1980                        string_length (s) + 1 - pos);
1981             }
1982         }
1983       else
1984         {
1985           Bufbyte *old_data = string_data (s);
1986           Bufbyte *new_data =
1987             BIG_STRING_FULLSIZE_P (newfullsize)
1988             ? xnew_array (Bufbyte, string_length (s) + delta + 1)
1989             : allocate_string_chars_struct (s, newfullsize)->chars;
1990
1991           if (pos >= 0)
1992             {
1993               memcpy (new_data, old_data, pos);
1994               memcpy (new_data + pos + delta, old_data + pos,
1995                       string_length (s) + 1 - pos);
1996             }
1997           set_string_data (s, new_data);
1998
1999           {
2000             /* We need to mark this chunk of the string_chars_block
2001                as unused so that compact_string_chars() doesn't
2002                freak. */
2003             struct string_chars *old_s_chars = (struct string_chars *)
2004               ((char *) old_data - offsetof (struct string_chars, chars));
2005             /* Sanity check to make sure we aren't hosed by strange
2006                alignment/padding. */
2007             assert (old_s_chars->string == s);
2008             MARK_STRUCT_AS_FREE (old_s_chars);
2009             ((struct unused_string_chars *) old_s_chars)->fullsize =
2010               oldfullsize;
2011           }
2012         }
2013     }
2014
2015   set_string_length (s, string_length (s) + delta);
2016   /* If pos < 0, the string won't be zero-terminated.
2017      Terminate now just to make sure. */
2018   string_data (s)[string_length (s)] = '\0';
2019
2020   if (pos >= 0)
2021     {
2022       Lisp_Object string;
2023
2024       XSETSTRING (string, s);
2025       /* We also have to adjust all of the extent indices after the
2026          place we did the change.  We say "pos - 1" because
2027          adjust_extents() is exclusive of the starting position
2028          passed to it. */
2029       adjust_extents (string, pos - 1, string_length (s),
2030                       delta);
2031     }
2032
2033 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2034   verify_string_chars_integrity ();
2035 #endif
2036 }
2037
2038 #ifdef MULE
2039
2040 void
2041 set_string_char (Lisp_String *s, Charcount i, Emchar c)
2042 {
2043   Bufbyte newstr[MAX_EMCHAR_LEN];
2044   Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2045   Bytecount oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2046   Bytecount newlen = set_charptr_emchar (newstr, c);
2047
2048   if (oldlen != newlen)
2049     resize_string (s, bytoff, newlen - oldlen);
2050   /* Remember, string_data (s) might have changed so we can't cache it. */
2051   memcpy (string_data (s) + bytoff, newstr, newlen);
2052 }
2053
2054 #endif /* MULE */
2055
2056 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2057 Return a new string of length LENGTH, with each character being INIT.
2058 LENGTH must be an integer and INIT must be a character.
2059 */
2060        (length, init))
2061 {
2062   CHECK_NATNUM (length);
2063   CHECK_CHAR_COERCE_INT (init);
2064   {
2065     Bufbyte init_str[MAX_EMCHAR_LEN];
2066     int len = set_charptr_emchar (init_str, XCHAR (init));
2067     Lisp_Object val = make_uninit_string (len * XINT (length));
2068
2069     if (len == 1)
2070       /* Optimize the single-byte case */
2071       memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2072     else
2073       {
2074         size_t i;
2075         Bufbyte *ptr = XSTRING_DATA (val);
2076
2077         for (i = XINT (length); i; i--)
2078           {
2079             Bufbyte *init_ptr = init_str;
2080             switch (len)
2081               {
2082               case 4: *ptr++ = *init_ptr++;
2083               case 3: *ptr++ = *init_ptr++;
2084               case 2: *ptr++ = *init_ptr++;
2085               case 1: *ptr++ = *init_ptr++;
2086               }
2087           }
2088       }
2089     return val;
2090   }
2091 }
2092
2093 DEFUN ("string", Fstring, 0, MANY, 0, /*
2094 Concatenate all the argument characters and make the result a string.
2095 */
2096        (int nargs, Lisp_Object *args))
2097 {
2098   Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2099   Bufbyte *p = storage;
2100
2101   for (; nargs; nargs--, args++)
2102     {
2103       Lisp_Object lisp_char = *args;
2104       CHECK_CHAR_COERCE_INT (lisp_char);
2105       p += set_charptr_emchar (p, XCHAR (lisp_char));
2106     }
2107   return make_string (storage, p - storage);
2108 }
2109
2110
2111 /* Take some raw memory, which MUST already be in internal format,
2112    and package it up into a Lisp string. */
2113 Lisp_Object
2114 make_string (CONST Bufbyte *contents, Bytecount length)
2115 {
2116   Lisp_Object val;
2117
2118   /* Make sure we find out about bad make_string's when they happen */
2119 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2120   bytecount_to_charcount (contents, length); /* Just for the assertions */
2121 #endif
2122
2123   val = make_uninit_string (length);
2124   memcpy (XSTRING_DATA (val), contents, length);
2125   return val;
2126 }
2127
2128 /* Take some raw memory, encoded in some external data format,
2129    and convert it into a Lisp string. */
2130 Lisp_Object
2131 make_ext_string (CONST Extbyte *contents, EMACS_INT length,
2132                  Lisp_Object coding_system)
2133 {
2134   Lisp_Object string;
2135   TO_INTERNAL_FORMAT (DATA, (contents, length),
2136                       LISP_STRING, string,
2137                       coding_system);
2138   return string;
2139 }
2140
2141 Lisp_Object
2142 build_string (CONST char *str)
2143 {
2144   /* Some strlen's crash and burn if passed null. */
2145   return make_string ((CONST Bufbyte *) str, (str ? strlen(str) : 0));
2146 }
2147
2148 Lisp_Object
2149 build_ext_string (CONST char *str, Lisp_Object coding_system)
2150 {
2151   /* Some strlen's crash and burn if passed null. */
2152   return make_ext_string ((CONST Extbyte *) str, (str ? strlen(str) : 0),
2153                           coding_system);
2154 }
2155
2156 Lisp_Object
2157 build_translated_string (CONST char *str)
2158 {
2159   return build_string (GETTEXT (str));
2160 }
2161
2162 Lisp_Object
2163 make_string_nocopy (CONST Bufbyte *contents, Bytecount length)
2164 {
2165   Lisp_String *s;
2166   Lisp_Object val;
2167
2168   /* Make sure we find out about bad make_string_nocopy's when they happen */
2169 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2170   bytecount_to_charcount (contents, length); /* Just for the assertions */
2171 #endif
2172
2173   /* Allocate the string header */
2174   ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
2175   set_lheader_implementation (&(s->lheader), &lrecord_string);
2176   SET_C_READONLY_RECORD_HEADER (&s->lheader);
2177   s->plist = Qnil;
2178   set_string_data (s, (Bufbyte *)contents);
2179   set_string_length (s, length);
2180
2181   XSETSTRING (val, s);
2182   return val;
2183 }
2184
2185 \f
2186 /************************************************************************/
2187 /*                           lcrecord lists                             */
2188 /************************************************************************/
2189
2190 /* Lcrecord lists are used to manage the allocation of particular
2191    sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2192    malloc() and garbage-collection junk) as much as possible.
2193    It is similar to the Blocktype class.
2194
2195    It works like this:
2196
2197    1) Create an lcrecord-list object using make_lcrecord_list().
2198       This is often done at initialization.  Remember to staticpro_nodump
2199       this object!  The arguments to make_lcrecord_list() are the
2200       same as would be passed to alloc_lcrecord().
2201    2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2202       and pass the lcrecord-list earlier created.
2203    3) When done with the lcrecord, call free_managed_lcrecord().
2204       The standard freeing caveats apply: ** make sure there are no
2205       pointers to the object anywhere! **
2206    4) Calling free_managed_lcrecord() is just like kissing the
2207       lcrecord goodbye as if it were garbage-collected.  This means:
2208       -- the contents of the freed lcrecord are undefined, and the
2209          contents of something produced by allocate_managed_lcrecord()
2210          are undefined, just like for alloc_lcrecord().
2211       -- the mark method for the lcrecord's type will *NEVER* be called
2212          on freed lcrecords.
2213       -- the finalize method for the lcrecord's type will be called
2214          at the time that free_managed_lcrecord() is called.
2215
2216    */
2217
2218 static Lisp_Object
2219 mark_lcrecord_list (Lisp_Object obj)
2220 {
2221   struct lcrecord_list *list = XLCRECORD_LIST (obj);
2222   Lisp_Object chain = list->free;
2223
2224   while (!NILP (chain))
2225     {
2226       struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2227       struct free_lcrecord_header *free_header =
2228         (struct free_lcrecord_header *) lheader;
2229
2230 #ifdef ERROR_CHECK_GC
2231       CONST struct lrecord_implementation *implementation
2232         = LHEADER_IMPLEMENTATION(lheader);
2233
2234       /* There should be no other pointers to the free list. */
2235       assert (!MARKED_RECORD_HEADER_P (lheader));
2236       /* Only lcrecords should be here. */
2237       assert (!implementation->basic_p);
2238       /* Only free lcrecords should be here. */
2239       assert (free_header->lcheader.free);
2240       /* The type of the lcrecord must be right. */
2241       assert (implementation == list->implementation);
2242       /* So must the size. */
2243       assert (implementation->static_size == 0
2244               || implementation->static_size == list->size);
2245 #endif /* ERROR_CHECK_GC */
2246
2247       MARK_RECORD_HEADER (lheader);
2248       chain = free_header->chain;
2249     }
2250
2251   return Qnil;
2252 }
2253
2254 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2255                                mark_lcrecord_list, internal_object_printer,
2256                                0, 0, 0, 0, struct lcrecord_list);
2257 Lisp_Object
2258 make_lcrecord_list (size_t size,
2259                     CONST struct lrecord_implementation *implementation)
2260 {
2261   struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2262                                                  &lrecord_lcrecord_list);
2263   Lisp_Object val;
2264
2265   p->implementation = implementation;
2266   p->size = size;
2267   p->free = Qnil;
2268   XSETLCRECORD_LIST (val, p);
2269   return val;
2270 }
2271
2272 Lisp_Object
2273 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2274 {
2275   struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2276   if (!NILP (list->free))
2277     {
2278       Lisp_Object val = list->free;
2279       struct free_lcrecord_header *free_header =
2280         (struct free_lcrecord_header *) XPNTR (val);
2281
2282 #ifdef ERROR_CHECK_GC
2283       struct lrecord_header *lheader =
2284         (struct lrecord_header *) free_header;
2285       CONST struct lrecord_implementation *implementation
2286         = LHEADER_IMPLEMENTATION (lheader);
2287
2288       /* There should be no other pointers to the free list. */
2289       assert (!MARKED_RECORD_HEADER_P (lheader));
2290       /* Only lcrecords should be here. */
2291       assert (!implementation->basic_p);
2292       /* Only free lcrecords should be here. */
2293       assert (free_header->lcheader.free);
2294       /* The type of the lcrecord must be right. */
2295       assert (implementation == list->implementation);
2296       /* So must the size. */
2297       assert (implementation->static_size == 0
2298               || implementation->static_size == list->size);
2299 #endif /* ERROR_CHECK_GC */
2300       list->free = free_header->chain;
2301       free_header->lcheader.free = 0;
2302       return val;
2303     }
2304   else
2305     {
2306       Lisp_Object val;
2307
2308       XSETOBJ (val, Lisp_Type_Record,
2309                alloc_lcrecord (list->size, list->implementation));
2310       return val;
2311     }
2312 }
2313
2314 void
2315 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2316 {
2317   struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2318   struct free_lcrecord_header *free_header =
2319     (struct free_lcrecord_header *) XPNTR (lcrecord);
2320   struct lrecord_header *lheader =
2321     (struct lrecord_header *) free_header;
2322   CONST struct lrecord_implementation *implementation
2323     = LHEADER_IMPLEMENTATION (lheader);
2324
2325 #ifdef ERROR_CHECK_GC
2326   /* Make sure the size is correct.  This will catch, for example,
2327      putting a window configuration on the wrong free list. */
2328   if (implementation->size_in_bytes_method)
2329     assert (implementation->size_in_bytes_method (lheader) == list->size);
2330   else
2331     assert (implementation->static_size == list->size);
2332 #endif /* ERROR_CHECK_GC */
2333
2334   if (implementation->finalizer)
2335     implementation->finalizer (lheader, 0);
2336   free_header->chain = list->free;
2337   free_header->lcheader.free = 1;
2338   list->free = lcrecord;
2339 }
2340
2341 \f
2342
2343 \f
2344 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2345 Kept for compatibility, returns its argument.
2346 Old:
2347 Make a copy of OBJECT in pure storage.
2348 Recursively copies contents of vectors and cons cells.
2349 Does not copy symbols.
2350 */
2351        (obj))
2352 {
2353   return obj;
2354 }
2355
2356
2357 \f
2358 /************************************************************************/
2359 /*                         Garbage Collection                           */
2360 /************************************************************************/
2361
2362 /* This will be used more extensively In The Future */
2363 static int last_lrecord_type_index_assigned;
2364
2365 CONST struct lrecord_implementation *lrecord_implementations_table[128];
2366 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
2367
2368 struct gcpro *gcprolist;
2369
2370 /* 415 used Mly 29-Jun-93 */
2371 /* 1327 used slb 28-Feb-98 */
2372 /* 1328 used og  03-Oct-99 (moving slowly, heh?) */
2373 #ifdef HAVE_SHLIB
2374 #define NSTATICS 4000
2375 #else
2376 #define NSTATICS 2000
2377 #endif
2378 /* Not "static" because of linker lossage on some systems */
2379 Lisp_Object *staticvec[NSTATICS]
2380      /* Force it into data space! */
2381      = {0};
2382 static int staticidx;
2383
2384 /* Put an entry in staticvec, pointing at the variable whose address is given
2385  */
2386 void
2387 staticpro (Lisp_Object *varaddress)
2388 {
2389   if (staticidx >= countof (staticvec))
2390     /* #### This is now a dubious abort() since this routine may be called */
2391     /* by Lisp attempting to load a DLL. */
2392     abort ();
2393   staticvec[staticidx++] = varaddress;
2394 }
2395
2396 /* Not "static" because of linker lossage on some systems */
2397 Lisp_Object *staticvec_nodump[200]
2398      /* Force it into data space! */
2399      = {0};
2400 static int staticidx_nodump;
2401
2402 /* Put an entry in staticvec_nodump, pointing at the variable whose address is given
2403  */
2404 void
2405 staticpro_nodump (Lisp_Object *varaddress)
2406 {
2407   if (staticidx_nodump >= countof (staticvec_nodump))
2408     /* #### This is now a dubious abort() since this routine may be called */
2409     /* by Lisp attempting to load a DLL. */
2410     abort ();
2411   staticvec_nodump[staticidx_nodump++] = varaddress;
2412 }
2413
2414 /* Not "static" because of linker lossage on some systems */
2415 struct
2416 {
2417   void *data;
2418   const struct struct_description *desc;
2419 } dumpstructvec[200];
2420
2421 static int dumpstructidx;
2422
2423 /* Put an entry in dumpstructvec, pointing at the variable whose address is given
2424  */
2425 void
2426 dumpstruct (void *varaddress, const struct struct_description *desc)
2427 {
2428   if (dumpstructidx >= countof (dumpstructvec))
2429     abort ();
2430   dumpstructvec[dumpstructidx].data = varaddress;
2431   dumpstructvec[dumpstructidx].desc = desc;
2432   dumpstructidx++;
2433 }
2434
2435 Lisp_Object *pdump_wirevec[50];
2436 static int pdump_wireidx;
2437
2438 /* Put an entry in pdump_wirevec, pointing at the variable whose address is given
2439  */
2440 void
2441 pdump_wire (Lisp_Object *varaddress)
2442 {
2443   if (pdump_wireidx >= countof (pdump_wirevec))
2444     abort ();
2445   pdump_wirevec[pdump_wireidx++] = varaddress;
2446 }
2447
2448
2449 Lisp_Object *pdump_wirevec_list[50];
2450 static int pdump_wireidx_list;
2451
2452 /* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given
2453  */
2454 void
2455 pdump_wire_list (Lisp_Object *varaddress)
2456 {
2457   if (pdump_wireidx_list >= countof (pdump_wirevec_list))
2458     abort ();
2459   pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
2460 }
2461
2462 \f
2463 /* Mark reference to a Lisp_Object.  If the object referred to has not been
2464    seen yet, recursively mark all the references contained in it. */
2465
2466 void
2467 mark_object (Lisp_Object obj)
2468 {
2469  tail_recurse:
2470
2471 #ifdef ERROR_CHECK_GC
2472   assert (! (EQ (obj, Qnull_pointer)));
2473 #endif
2474   /* Checks we used to perform */
2475   /* if (EQ (obj, Qnull_pointer)) return; */
2476   /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
2477   /* if (PURIFIED (XPNTR (obj))) return; */
2478
2479   if (XTYPE (obj) == Lisp_Type_Record)
2480     {
2481       struct lrecord_header *lheader = XRECORD_LHEADER (obj);
2482 #if defined (ERROR_CHECK_GC)
2483       assert (lheader->type <= last_lrecord_type_index_assigned);
2484 #endif
2485       if (C_READONLY_RECORD_HEADER_P (lheader))
2486         return;
2487
2488       if (! MARKED_RECORD_HEADER_P (lheader) &&
2489           ! UNMARKABLE_RECORD_HEADER_P (lheader))
2490         {
2491           CONST struct lrecord_implementation *implementation =
2492             LHEADER_IMPLEMENTATION (lheader);
2493           MARK_RECORD_HEADER (lheader);
2494 #ifdef ERROR_CHECK_GC
2495           if (!implementation->basic_p)
2496             assert (! ((struct lcrecord_header *) lheader)->free);
2497 #endif
2498           if (implementation->marker)
2499             {
2500               obj = implementation->marker (obj);
2501               if (!NILP (obj)) goto tail_recurse;
2502             }
2503         }
2504     }
2505 }
2506
2507 /* mark all of the conses in a list and mark the final cdr; but
2508    DO NOT mark the cars.
2509
2510    Use only for internal lists!  There should never be other pointers
2511    to the cons cells, because if so, the cars will remain unmarked
2512    even when they maybe should be marked. */
2513 void
2514 mark_conses_in_list (Lisp_Object obj)
2515 {
2516   Lisp_Object rest;
2517
2518   for (rest = obj; CONSP (rest); rest = XCDR (rest))
2519     {
2520       if (CONS_MARKED_P (XCONS (rest)))
2521         return;
2522       MARK_CONS (XCONS (rest));
2523     }
2524
2525   mark_object (rest);
2526 }
2527
2528 \f
2529 /* Find all structures not marked, and free them. */
2530
2531 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
2532 static int gc_count_bit_vector_storage;
2533 static int gc_count_num_short_string_in_use;
2534 static int gc_count_string_total_size;
2535 static int gc_count_short_string_total_size;
2536
2537 /* static int gc_count_total_records_used, gc_count_records_total_size; */
2538
2539 \f
2540 int
2541 lrecord_type_index (CONST struct lrecord_implementation *implementation)
2542 {
2543   int type_index = *(implementation->lrecord_type_index);
2544   /* Have to do this circuitous validation test because of problems
2545      dumping out initialized variables (ie can't set xxx_type_index to -1
2546      because that would make xxx_type_index read-only in a dumped emacs. */
2547   if (type_index < 0 || type_index > max_lrecord_type
2548       || lrecord_implementations_table[type_index] != implementation)
2549     {
2550       assert (last_lrecord_type_index_assigned < max_lrecord_type);
2551       type_index = ++last_lrecord_type_index_assigned;
2552       lrecord_implementations_table[type_index] = implementation;
2553       *(implementation->lrecord_type_index) = type_index;
2554     }
2555   return type_index;
2556 }
2557
2558 /* stats on lcrecords in use - kinda kludgy */
2559
2560 static struct
2561 {
2562   int instances_in_use;
2563   int bytes_in_use;
2564   int instances_freed;
2565   int bytes_freed;
2566   int instances_on_free_list;
2567 } lcrecord_stats [countof (lrecord_implementations_table)];
2568
2569 static void
2570 tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p)
2571 {
2572   CONST struct lrecord_implementation *implementation =
2573     LHEADER_IMPLEMENTATION (h);
2574   int type_index = lrecord_type_index (implementation);
2575
2576   if (((struct lcrecord_header *) h)->free)
2577     {
2578       assert (!free_p);
2579       lcrecord_stats[type_index].instances_on_free_list++;
2580     }
2581   else
2582     {
2583       size_t sz = (implementation->size_in_bytes_method
2584                    ? implementation->size_in_bytes_method (h)
2585                    : implementation->static_size);
2586
2587       if (free_p)
2588         {
2589           lcrecord_stats[type_index].instances_freed++;
2590           lcrecord_stats[type_index].bytes_freed += sz;
2591         }
2592       else
2593         {
2594           lcrecord_stats[type_index].instances_in_use++;
2595           lcrecord_stats[type_index].bytes_in_use += sz;
2596         }
2597     }
2598 }
2599
2600 \f
2601 /* Free all unmarked records */
2602 static void
2603 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
2604 {
2605   struct lcrecord_header *header;
2606   int num_used = 0;
2607   /* int total_size = 0; */
2608
2609   xzero (lcrecord_stats); /* Reset all statistics to 0. */
2610
2611   /* First go through and call all the finalize methods.
2612      Then go through and free the objects.  There used to
2613      be only one loop here, with the call to the finalizer
2614      occurring directly before the xfree() below.  That
2615      is marginally faster but much less safe -- if the
2616      finalize method for an object needs to reference any
2617      other objects contained within it (and many do),
2618      we could easily be screwed by having already freed that
2619      other object. */
2620
2621   for (header = *prev; header; header = header->next)
2622     {
2623       struct lrecord_header *h = &(header->lheader);
2624       if (!C_READONLY_RECORD_HEADER_P(h)
2625           && !MARKED_RECORD_HEADER_P (h)
2626           && ! (header->free))
2627         {
2628           if (LHEADER_IMPLEMENTATION (h)->finalizer)
2629             LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
2630         }
2631     }
2632
2633   for (header = *prev; header; )
2634     {
2635       struct lrecord_header *h = &(header->lheader);
2636       if (C_READONLY_RECORD_HEADER_P(h) || MARKED_RECORD_HEADER_P (h))
2637         {
2638           if (MARKED_RECORD_HEADER_P (h))
2639             UNMARK_RECORD_HEADER (h);
2640           num_used++;
2641           /* total_size += n->implementation->size_in_bytes (h);*/
2642           /* #### May modify header->next on a C_READONLY lcrecord */
2643           prev = &(header->next);
2644           header = *prev;
2645           tick_lcrecord_stats (h, 0);
2646         }
2647       else
2648         {
2649           struct lcrecord_header *next = header->next;
2650           *prev = next;
2651           tick_lcrecord_stats (h, 1);
2652           /* used to call finalizer right here. */
2653           xfree (header);
2654           header = next;
2655         }
2656     }
2657   *used = num_used;
2658   /* *total = total_size; */
2659 }
2660
2661
2662 static void
2663 sweep_bit_vectors_1 (Lisp_Object *prev,
2664                      int *used, int *total, int *storage)
2665 {
2666   Lisp_Object bit_vector;
2667   int num_used = 0;
2668   int total_size = 0;
2669   int total_storage = 0;
2670
2671   /* BIT_VECTORP fails because the objects are marked, which changes
2672      their implementation */
2673   for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
2674     {
2675       Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
2676       int len = v->size;
2677       if (C_READONLY_RECORD_HEADER_P(&(v->lheader)) || MARKED_RECORD_P (bit_vector))
2678         {
2679           if (MARKED_RECORD_P (bit_vector))
2680             UNMARK_RECORD_HEADER (&(v->lheader));
2681           total_size += len;
2682           total_storage +=
2683             MALLOC_OVERHEAD +
2684             STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
2685                                     BIT_VECTOR_LONG_STORAGE (len));
2686           num_used++;
2687           /* #### May modify next on a C_READONLY bitvector */
2688           prev = &(bit_vector_next (v));
2689           bit_vector = *prev;
2690         }
2691       else
2692         {
2693           Lisp_Object next = bit_vector_next (v);
2694           *prev = next;
2695           xfree (v);
2696           bit_vector = next;
2697         }
2698     }
2699   *used = num_used;
2700   *total = total_size;
2701   *storage = total_storage;
2702 }
2703
2704 /* And the Lord said: Thou shalt use the `c-backslash-region' command
2705    to make macros prettier. */
2706
2707 #ifdef ERROR_CHECK_GC
2708
2709 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type)                      \
2710 do {                                                                    \
2711   struct typename##_block *SFTB_current;                                \
2712   struct typename##_block **SFTB_prev;                                  \
2713   int SFTB_limit;                                                       \
2714   int num_free = 0, num_used = 0;                                       \
2715                                                                         \
2716   for (SFTB_prev = &current_##typename##_block,                         \
2717        SFTB_current = current_##typename##_block,                       \
2718        SFTB_limit = current_##typename##_block_index;                   \
2719        SFTB_current;                                                    \
2720        )                                                                \
2721     {                                                                   \
2722       int SFTB_iii;                                                     \
2723                                                                         \
2724       for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++)             \
2725         {                                                               \
2726           obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]);     \
2727                                                                         \
2728           if (FREE_STRUCT_P (SFTB_victim))                              \
2729             {                                                           \
2730               num_free++;                                               \
2731             }                                                           \
2732           else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader))  \
2733             {                                                           \
2734               num_used++;                                               \
2735             }                                                           \
2736           else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader))     \
2737             {                                                           \
2738               num_free++;                                               \
2739               FREE_FIXED_TYPE (typename, obj_type, SFTB_victim);        \
2740             }                                                           \
2741           else                                                          \
2742             {                                                           \
2743               num_used++;                                               \
2744               UNMARK_##typename (SFTB_victim);                          \
2745             }                                                           \
2746         }                                                               \
2747       SFTB_prev = &(SFTB_current->prev);                                \
2748       SFTB_current = SFTB_current->prev;                                \
2749       SFTB_limit = countof (current_##typename##_block->block);         \
2750     }                                                                   \
2751                                                                         \
2752   gc_count_num_##typename##_in_use = num_used;                          \
2753   gc_count_num_##typename##_freelist = num_free;                        \
2754 } while (0)
2755
2756 #else /* !ERROR_CHECK_GC */
2757
2758 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type)                              \
2759 do {                                                                            \
2760   struct typename##_block *SFTB_current;                                        \
2761   struct typename##_block **SFTB_prev;                                          \
2762   int SFTB_limit;                                                               \
2763   int num_free = 0, num_used = 0;                                               \
2764                                                                                 \
2765   typename##_free_list = 0;                                                     \
2766                                                                                 \
2767   for (SFTB_prev = &current_##typename##_block,                                 \
2768        SFTB_current = current_##typename##_block,                               \
2769        SFTB_limit = current_##typename##_block_index;                           \
2770        SFTB_current;                                                            \
2771        )                                                                        \
2772     {                                                                           \
2773       int SFTB_iii;                                                             \
2774       int SFTB_empty = 1;                                                       \
2775       obj_type *SFTB_old_free_list = typename##_free_list;                      \
2776                                                                                 \
2777       for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++)                     \
2778         {                                                                       \
2779           obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]);             \
2780                                                                                 \
2781           if (FREE_STRUCT_P (SFTB_victim))                                      \
2782             {                                                                   \
2783               num_free++;                                                       \
2784               PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim);    \
2785             }                                                                   \
2786           else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader))          \
2787             {                                                                   \
2788               SFTB_empty = 0;                                                   \
2789               num_used++;                                                       \
2790             }                                                                   \
2791           else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader))             \
2792             {                                                                   \
2793               num_free++;                                                       \
2794               FREE_FIXED_TYPE (typename, obj_type, SFTB_victim);                \
2795             }                                                                   \
2796           else                                                                  \
2797             {                                                                   \
2798               SFTB_empty = 0;                                                   \
2799               num_used++;                                                       \
2800               UNMARK_##typename (SFTB_victim);                                  \
2801             }                                                                   \
2802         }                                                                       \
2803       if (!SFTB_empty)                                                          \
2804         {                                                                       \
2805           SFTB_prev = &(SFTB_current->prev);                                    \
2806           SFTB_current = SFTB_current->prev;                                    \
2807         }                                                                       \
2808       else if (SFTB_current == current_##typename##_block                       \
2809                && !SFTB_current->prev)                                          \
2810         {                                                                       \
2811           /* No real point in freeing sole allocation block */                  \
2812           break;                                                                \
2813         }                                                                       \
2814       else                                                                      \
2815         {                                                                       \
2816           struct typename##_block *SFTB_victim_block = SFTB_current;            \
2817           if (SFTB_victim_block == current_##typename##_block)                  \
2818             current_##typename##_block_index                                    \
2819               = countof (current_##typename##_block->block);                    \
2820           SFTB_current = SFTB_current->prev;                                    \
2821           {                                                                     \
2822             *SFTB_prev = SFTB_current;                                          \
2823             xfree (SFTB_victim_block);                                          \
2824             /* Restore free list to what it was before victim was swept */      \
2825             typename##_free_list = SFTB_old_free_list;                          \
2826             num_free -= SFTB_limit;                                             \
2827           }                                                                     \
2828         }                                                                       \
2829       SFTB_limit = countof (current_##typename##_block->block);                 \
2830     }                                                                           \
2831                                                                                 \
2832   gc_count_num_##typename##_in_use = num_used;                                  \
2833   gc_count_num_##typename##_freelist = num_free;                                \
2834 } while (0)
2835
2836 #endif /* !ERROR_CHECK_GC */
2837
2838 \f
2839
2840
2841 static void
2842 sweep_conses (void)
2843 {
2844 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2845 #define ADDITIONAL_FREE_cons(ptr)
2846
2847   SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons);
2848 }
2849
2850 /* Explicitly free a cons cell.  */
2851 void
2852 free_cons (Lisp_Cons *ptr)
2853 {
2854 #ifdef ERROR_CHECK_GC
2855   /* If the CAR is not an int, then it will be a pointer, which will
2856      always be four-byte aligned.  If this cons cell has already been
2857      placed on the free list, however, its car will probably contain
2858      a chain pointer to the next cons on the list, which has cleverly
2859      had all its 0's and 1's inverted.  This allows for a quick
2860      check to make sure we're not freeing something already freed. */
2861   if (POINTER_TYPE_P (XTYPE (ptr->car)))
2862     ASSERT_VALID_POINTER (XPNTR (ptr->car));
2863 #endif /* ERROR_CHECK_GC */
2864
2865 #ifndef ALLOC_NO_POOLS
2866   FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr);
2867 #endif /* ALLOC_NO_POOLS */
2868 }
2869
2870 /* explicitly free a list.  You **must make sure** that you have
2871    created all the cons cells that make up this list and that there
2872    are no pointers to any of these cons cells anywhere else.  If there
2873    are, you will lose. */
2874
2875 void
2876 free_list (Lisp_Object list)
2877 {
2878   Lisp_Object rest, next;
2879
2880   for (rest = list; !NILP (rest); rest = next)
2881     {
2882       next = XCDR (rest);
2883       free_cons (XCONS (rest));
2884     }
2885 }
2886
2887 /* explicitly free an alist.  You **must make sure** that you have
2888    created all the cons cells that make up this alist and that there
2889    are no pointers to any of these cons cells anywhere else.  If there
2890    are, you will lose. */
2891
2892 void
2893 free_alist (Lisp_Object alist)
2894 {
2895   Lisp_Object rest, next;
2896
2897   for (rest = alist; !NILP (rest); rest = next)
2898     {
2899       next = XCDR (rest);
2900       free_cons (XCONS (XCAR (rest)));
2901       free_cons (XCONS (rest));
2902     }
2903 }
2904
2905 static void
2906 sweep_compiled_functions (void)
2907 {
2908 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2909 #define ADDITIONAL_FREE_compiled_function(ptr)
2910
2911   SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
2912 }
2913
2914
2915 #ifdef LISP_FLOAT_TYPE
2916 static void
2917 sweep_floats (void)
2918 {
2919 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2920 #define ADDITIONAL_FREE_float(ptr)
2921
2922   SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float);
2923 }
2924 #endif /* LISP_FLOAT_TYPE */
2925
2926 static void
2927 sweep_symbols (void)
2928 {
2929 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2930 #define ADDITIONAL_FREE_symbol(ptr)
2931
2932   SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol);
2933 }
2934
2935 static void
2936 sweep_extents (void)
2937 {
2938 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2939 #define ADDITIONAL_FREE_extent(ptr)
2940
2941   SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
2942 }
2943
2944 static void
2945 sweep_events (void)
2946 {
2947 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2948 #define ADDITIONAL_FREE_event(ptr)
2949
2950   SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event);
2951 }
2952
2953 static void
2954 sweep_markers (void)
2955 {
2956 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
2957 #define ADDITIONAL_FREE_marker(ptr)                                     \
2958   do { Lisp_Object tem;                                                 \
2959        XSETMARKER (tem, ptr);                                           \
2960        unchain_marker (tem);                                            \
2961      } while (0)
2962
2963   SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker);
2964 }
2965
2966 /* Explicitly free a marker.  */
2967 void
2968 free_marker (Lisp_Marker *ptr)
2969 {
2970 #ifdef ERROR_CHECK_GC
2971   /* Perhaps this will catch freeing an already-freed marker. */
2972   Lisp_Object temmy;
2973   XSETMARKER (temmy, ptr);
2974   assert (MARKERP (temmy));
2975 #endif /* ERROR_CHECK_GC */
2976
2977 #ifndef ALLOC_NO_POOLS
2978   FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
2979 #endif /* ALLOC_NO_POOLS */
2980 }
2981 \f
2982
2983 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
2984
2985 static void
2986 verify_string_chars_integrity (void)
2987 {
2988   struct string_chars_block *sb;
2989
2990   /* Scan each existing string block sequentially, string by string.  */
2991   for (sb = first_string_chars_block; sb; sb = sb->next)
2992     {
2993       int pos = 0;
2994       /* POS is the index of the next string in the block.  */
2995       while (pos < sb->pos)
2996         {
2997           struct string_chars *s_chars =
2998             (struct string_chars *) &(sb->string_chars[pos]);
2999           Lisp_String *string;
3000           int size;
3001           int fullsize;
3002
3003           /* If the string_chars struct is marked as free (i.e. the STRING
3004              pointer is 0xFFFFFFFF) then this is an unused chunk of string
3005              storage. (See below.) */
3006
3007           if (FREE_STRUCT_P (s_chars))
3008             {
3009               fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3010               pos += fullsize;
3011               continue;
3012             }
3013
3014           string = s_chars->string;
3015           /* Must be 32-bit aligned. */
3016           assert ((((int) string) & 3) == 0);
3017
3018           size = string_length (string);
3019           fullsize = STRING_FULLSIZE (size);
3020
3021           assert (!BIG_STRING_FULLSIZE_P (fullsize));
3022           assert (string_data (string) == s_chars->chars);
3023           pos += fullsize;
3024         }
3025       assert (pos == sb->pos);
3026     }
3027 }
3028
3029 #endif /* MULE && ERROR_CHECK_GC */
3030
3031 /* Compactify string chars, relocating the reference to each --
3032    free any empty string_chars_block we see. */
3033 static void
3034 compact_string_chars (void)
3035 {
3036   struct string_chars_block *to_sb = first_string_chars_block;
3037   int to_pos = 0;
3038   struct string_chars_block *from_sb;
3039
3040   /* Scan each existing string block sequentially, string by string.  */
3041   for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
3042     {
3043       int from_pos = 0;
3044       /* FROM_POS is the index of the next string in the block.  */
3045       while (from_pos < from_sb->pos)
3046         {
3047           struct string_chars *from_s_chars =
3048             (struct string_chars *) &(from_sb->string_chars[from_pos]);
3049           struct string_chars *to_s_chars;
3050           Lisp_String *string;
3051           int size;
3052           int fullsize;
3053
3054           /* If the string_chars struct is marked as free (i.e. the STRING
3055              pointer is 0xFFFFFFFF) then this is an unused chunk of string
3056              storage.  This happens under Mule when a string's size changes
3057              in such a way that its fullsize changes. (Strings can change
3058              size because a different-length character can be substituted
3059              for another character.) In this case, after the bogus string
3060              pointer is the "fullsize" of this entry, i.e. how many bytes
3061              to skip. */
3062
3063           if (FREE_STRUCT_P (from_s_chars))
3064             {
3065               fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
3066               from_pos += fullsize;
3067               continue;
3068             }
3069
3070           string = from_s_chars->string;
3071           assert (!(FREE_STRUCT_P (string)));
3072
3073           size = string_length (string);
3074           fullsize = STRING_FULLSIZE (size);
3075
3076           if (BIG_STRING_FULLSIZE_P (fullsize))
3077             abort ();
3078
3079           /* Just skip it if it isn't marked.  */
3080           if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
3081             {
3082               from_pos += fullsize;
3083               continue;
3084             }
3085
3086           /* If it won't fit in what's left of TO_SB, close TO_SB out
3087              and go on to the next string_chars_block.  We know that TO_SB
3088              cannot advance past FROM_SB here since FROM_SB is large enough
3089              to currently contain this string. */
3090           if ((to_pos + fullsize) > countof (to_sb->string_chars))
3091             {
3092               to_sb->pos = to_pos;
3093               to_sb = to_sb->next;
3094               to_pos = 0;
3095             }
3096
3097           /* Compute new address of this string
3098              and update TO_POS for the space being used.  */
3099           to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
3100
3101           /* Copy the string_chars to the new place.  */
3102           if (from_s_chars != to_s_chars)
3103             memmove (to_s_chars, from_s_chars, fullsize);
3104
3105           /* Relocate FROM_S_CHARS's reference */
3106           set_string_data (string, &(to_s_chars->chars[0]));
3107
3108           from_pos += fullsize;
3109           to_pos += fullsize;
3110         }
3111     }
3112
3113   /* Set current to the last string chars block still used and
3114      free any that follow. */
3115   {
3116     struct string_chars_block *victim;
3117
3118     for (victim = to_sb->next; victim; )
3119       {
3120         struct string_chars_block *next = victim->next;
3121         xfree (victim);
3122         victim = next;
3123       }
3124
3125     current_string_chars_block = to_sb;
3126     current_string_chars_block->pos = to_pos;
3127     current_string_chars_block->next = 0;
3128   }
3129 }
3130
3131 #if 1 /* Hack to debug missing purecopy's */
3132 static int debug_string_purity;
3133
3134 static void
3135 debug_string_purity_print (Lisp_String *p)
3136 {
3137   Charcount i;
3138   Charcount s = string_char_length (p);
3139   putc ('\"', stderr);
3140   for (i = 0; i < s; i++)
3141   {
3142     Emchar ch = string_char (p, i);
3143     if (ch < 32 || ch >= 126)
3144       stderr_out ("\\%03o", ch);
3145     else if (ch == '\\' || ch == '\"')
3146       stderr_out ("\\%c", ch);
3147     else
3148       stderr_out ("%c", ch);
3149   }
3150   stderr_out ("\"\n");
3151 }
3152 #endif /* 1 */
3153
3154
3155 static void
3156 sweep_strings (void)
3157 {
3158   int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
3159   int debug = debug_string_purity;
3160
3161 #define UNMARK_string(ptr) do {                 \
3162     Lisp_String *p = (ptr);                     \
3163     size_t size = string_length (p);            \
3164     UNMARK_RECORD_HEADER (&(p->lheader));       \
3165     num_bytes += size;                          \
3166     if (!BIG_STRING_SIZE_P (size))              \
3167       { num_small_bytes += size;                \
3168       num_small_used++;                         \
3169       }                                         \
3170     if (debug)                                  \
3171       debug_string_purity_print (p);            \
3172   } while (0)
3173 #define ADDITIONAL_FREE_string(ptr) do {        \
3174     size_t size = string_length (ptr);          \
3175     if (BIG_STRING_SIZE_P (size))               \
3176       xfree (ptr->data);                        \
3177   } while (0)
3178
3179   SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String);
3180
3181   gc_count_num_short_string_in_use = num_small_used;
3182   gc_count_string_total_size = num_bytes;
3183   gc_count_short_string_total_size = num_small_bytes;
3184 }
3185
3186
3187 /* I hate duplicating all this crap! */
3188 int
3189 marked_p (Lisp_Object obj)
3190 {
3191 #ifdef ERROR_CHECK_GC
3192   assert (! (EQ (obj, Qnull_pointer)));
3193 #endif
3194   /* Checks we used to perform. */
3195   /* if (EQ (obj, Qnull_pointer)) return 1; */
3196   /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
3197   /* if (PURIFIED (XPNTR (obj))) return 1; */
3198
3199   if (XTYPE (obj) == Lisp_Type_Record)
3200     {
3201       struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3202 #if defined (ERROR_CHECK_GC)
3203       assert (lheader->type <= last_lrecord_type_index_assigned);
3204 #endif
3205       return C_READONLY_RECORD_HEADER_P (lheader) || MARKED_RECORD_HEADER_P (lheader);
3206     }
3207   return 1;
3208 }
3209
3210 static void
3211 gc_sweep (void)
3212 {
3213   /* Free all unmarked records.  Do this at the very beginning,
3214      before anything else, so that the finalize methods can safely
3215      examine items in the objects.  sweep_lcrecords_1() makes
3216      sure to call all the finalize methods *before* freeing anything,
3217      to complete the safety. */
3218   {
3219     int ignored;
3220     sweep_lcrecords_1 (&all_lcrecords, &ignored);
3221   }
3222
3223   compact_string_chars ();
3224
3225   /* Finalize methods below (called through the ADDITIONAL_FREE_foo
3226      macros) must be *extremely* careful to make sure they're not
3227      referencing freed objects.  The only two existing finalize
3228      methods (for strings and markers) pass muster -- the string
3229      finalizer doesn't look at anything but its own specially-
3230      created block, and the marker finalizer only looks at live
3231      buffers (which will never be freed) and at the markers before
3232      and after it in the chain (which, by induction, will never be
3233      freed because if so, they would have already removed themselves
3234      from the chain). */
3235
3236   /* Put all unmarked strings on free list, free'ing the string chars
3237      of large unmarked strings */
3238   sweep_strings ();
3239
3240   /* Put all unmarked conses on free list */
3241   sweep_conses ();
3242
3243   /* Free all unmarked bit vectors */
3244   sweep_bit_vectors_1 (&all_bit_vectors,
3245                        &gc_count_num_bit_vector_used,
3246                        &gc_count_bit_vector_total_size,
3247                        &gc_count_bit_vector_storage);
3248
3249   /* Free all unmarked compiled-function objects */
3250   sweep_compiled_functions ();
3251
3252 #ifdef LISP_FLOAT_TYPE
3253   /* Put all unmarked floats on free list */
3254   sweep_floats ();
3255 #endif
3256
3257   /* Put all unmarked symbols on free list */
3258   sweep_symbols ();
3259
3260   /* Put all unmarked extents on free list */
3261   sweep_extents ();
3262
3263   /* Put all unmarked markers on free list.
3264      Dechain each one first from the buffer into which it points. */
3265   sweep_markers ();
3266
3267   sweep_events ();
3268
3269 #ifdef PDUMP
3270   /* Unmark all dumped objects */
3271   {
3272     int i;
3273     char *p = pdump_rt_list;
3274     if (p)
3275       for (;;)
3276         {
3277           pdump_reloc_table *rt = (pdump_reloc_table *)p;
3278           p += sizeof (pdump_reloc_table);
3279           if (rt->desc)
3280             {
3281               for (i=0; i<rt->count; i++)
3282                 {
3283                   UNMARK_RECORD_HEADER ((struct lrecord_header *)(*(EMACS_INT *)p));
3284                   p += sizeof (EMACS_INT);
3285                 }
3286             } else
3287               break;
3288         }
3289   }
3290 #endif
3291 }
3292 \f
3293 /* Clearing for disksave. */
3294
3295 void
3296 disksave_object_finalization (void)
3297 {
3298   /* It's important that certain information from the environment not get
3299      dumped with the executable (pathnames, environment variables, etc.).
3300      To make it easier to tell when this has happened with strings(1) we
3301      clear some known-to-be-garbage blocks of memory, so that leftover
3302      results of old evaluation don't look like potential problems.
3303      But first we set some notable variables to nil and do one more GC,
3304      to turn those strings into garbage.
3305   */
3306
3307   /* Yeah, this list is pretty ad-hoc... */
3308   Vprocess_environment = Qnil;
3309   Vexec_directory = Qnil;
3310   Vdata_directory = Qnil;
3311   Vsite_directory = Qnil;
3312   Vdoc_directory = Qnil;
3313   Vconfigure_info_directory = Qnil;
3314   Vexec_path = Qnil;
3315   Vload_path = Qnil;
3316   /* Vdump_load_path = Qnil; */
3317   /* Release hash tables for locate_file */
3318   Flocate_file_clear_hashing (Qt);
3319   uncache_home_directory();
3320
3321 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
3322                            defined(LOADHIST_BUILTIN))
3323   Vload_history = Qnil;
3324 #endif
3325   Vshell_file_name = Qnil;
3326
3327   garbage_collect_1 ();
3328
3329   /* Run the disksave finalization methods of all live objects. */
3330   disksave_object_finalization_1 ();
3331
3332   /* Zero out the uninitialized (really, unused) part of the containers
3333      for the live strings. */
3334   {
3335     struct string_chars_block *scb;
3336     for (scb = first_string_chars_block; scb; scb = scb->next)
3337       {
3338         int count = sizeof (scb->string_chars) - scb->pos;
3339
3340         assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
3341         if (count != 0)
3342           {
3343             /* from the block's fill ptr to the end */
3344             memset ((scb->string_chars + scb->pos), 0, count);
3345           }
3346       }
3347   }
3348
3349   /* There, that ought to be enough... */
3350
3351 }
3352
3353 \f
3354 Lisp_Object
3355 restore_gc_inhibit (Lisp_Object val)
3356 {
3357   gc_currently_forbidden = XINT (val);
3358   return val;
3359 }
3360
3361 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
3362 static int gc_hooks_inhibited;
3363
3364 \f
3365 void
3366 garbage_collect_1 (void)
3367 {
3368 #if MAX_SAVE_STACK > 0
3369   char stack_top_variable;
3370   extern char *stack_bottom;
3371 #endif
3372   struct frame *f;
3373   int speccount;
3374   int cursor_changed;
3375   Lisp_Object pre_gc_cursor;
3376   struct gcpro gcpro1;
3377
3378   if (gc_in_progress
3379       || gc_currently_forbidden
3380       || in_display
3381       || preparing_for_armageddon)
3382     return;
3383
3384   /* We used to call selected_frame() here.
3385
3386      The following functions cannot be called inside GC
3387      so we move to after the above tests. */
3388   {
3389     Lisp_Object frame;
3390     Lisp_Object device = Fselected_device (Qnil);
3391     if (NILP (device)) /* Could happen during startup, eg. if always_gc */
3392       return;
3393     frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
3394     if (NILP (frame))
3395       signal_simple_error ("No frames exist on device", device);
3396     f = XFRAME (frame);
3397   }
3398
3399   pre_gc_cursor = Qnil;
3400   cursor_changed = 0;
3401
3402   GCPRO1 (pre_gc_cursor);
3403
3404   /* Very important to prevent GC during any of the following
3405      stuff that might run Lisp code; otherwise, we'll likely
3406      have infinite GC recursion. */
3407   speccount = specpdl_depth ();
3408   record_unwind_protect (restore_gc_inhibit,
3409                          make_int (gc_currently_forbidden));
3410   gc_currently_forbidden = 1;
3411
3412   if (!gc_hooks_inhibited)
3413     run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3414
3415   /* Now show the GC cursor/message. */
3416   if (!noninteractive)
3417     {
3418       if (FRAME_WIN_P (f))
3419         {
3420           Lisp_Object frame = make_frame (f);
3421           Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
3422                                                      FRAME_SELECTED_WINDOW (f),
3423                                                      ERROR_ME_NOT, 1);
3424           pre_gc_cursor = f->pointer;
3425           if (POINTER_IMAGE_INSTANCEP (cursor)
3426               /* don't change if we don't know how to change back. */
3427               && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
3428             {
3429               cursor_changed = 1;
3430               Fset_frame_pointer (frame, cursor);
3431             }
3432         }
3433
3434       /* Don't print messages to the stream device. */
3435       if (!cursor_changed && !FRAME_STREAM_P (f))
3436         {
3437           char *msg = (STRINGP (Vgc_message)
3438                        ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
3439                        : 0);
3440           Lisp_Object args[2], whole_msg;
3441           args[0] = build_string (msg ? msg :
3442                                   GETTEXT ((CONST char *) gc_default_message));
3443           args[1] = build_string ("...");
3444           whole_msg = Fconcat (2, args);
3445           echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
3446                              Qgarbage_collecting);
3447         }
3448     }
3449
3450   /***** Now we actually start the garbage collection. */
3451
3452   gc_in_progress = 1;
3453
3454   gc_generation_number[0]++;
3455
3456 #if MAX_SAVE_STACK > 0
3457
3458   /* Save a copy of the contents of the stack, for debugging.  */
3459   if (!purify_flag)
3460     {
3461       /* Static buffer in which we save a copy of the C stack at each GC.  */
3462       static char *stack_copy;
3463       static size_t stack_copy_size;
3464
3465       ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
3466       size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
3467       if (stack_size < MAX_SAVE_STACK)
3468         {
3469           if (stack_copy_size < stack_size)
3470             {
3471               stack_copy = (char *) xrealloc (stack_copy, stack_size);
3472               stack_copy_size = stack_size;
3473             }
3474
3475           memcpy (stack_copy,
3476                   stack_diff > 0 ? stack_bottom : &stack_top_variable,
3477                   stack_size);
3478         }
3479     }
3480 #endif /* MAX_SAVE_STACK > 0 */
3481
3482   /* Do some totally ad-hoc resource clearing. */
3483   /* #### generalize this? */
3484   clear_event_resource ();
3485   cleanup_specifiers ();
3486
3487   /* Mark all the special slots that serve as the roots of accessibility. */
3488
3489   { /* staticpro() */
3490     int i;
3491     for (i = 0; i < staticidx; i++)
3492       mark_object (*(staticvec[i]));
3493     for (i = 0; i < staticidx_nodump; i++)
3494       mark_object (*(staticvec_nodump[i]));
3495   }
3496
3497   { /* GCPRO() */
3498     struct gcpro *tail;
3499     int i;
3500     for (tail = gcprolist; tail; tail = tail->next)
3501       for (i = 0; i < tail->nvars; i++)
3502         mark_object (tail->var[i]);
3503   }
3504
3505   { /* specbind() */
3506     struct specbinding *bind;
3507     for (bind = specpdl; bind != specpdl_ptr; bind++)
3508       {
3509         mark_object (bind->symbol);
3510         mark_object (bind->old_value);