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