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