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