XEmacs 21.2-b3
[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 */
40
41 #include <config.h>
42 #include "lisp.h"
43
44 #include "backtrace.h"
45 #include "buffer.h"
46 #include "bytecode.h"
47 #include "chartab.h"
48 #include "device.h"
49 #include "elhash.h"
50 #include "events.h"
51 #include "extents.h"
52 #include "frame.h"
53 #include "glyphs.h"
54 #include "redisplay.h"
55 #include "specifier.h"
56 #include "sysfile.h"
57 #include "window.h"
58
59 #include <stddef.h>
60
61 #ifdef DOUG_LEA_MALLOC
62 #include <malloc.h>
63 #endif
64
65 EXFUN (Fgarbage_collect, 0);
66
67 /* #define GDB_SUCKS */
68
69 #if 0 /* this is _way_ too slow to be part of the standard debug options */
70 #if defined(DEBUG_XEMACS) && defined(MULE)
71 #define VERIFY_STRING_CHARS_INTEGRITY
72 #endif
73 #endif
74
75 /* Define this to see where all that space is going... */
76 /* But the length of the printout is obnoxious, so limit it to testers */
77 /* If somebody wants to see this they can ask for it.
78 #ifdef DEBUG_XEMACS
79 #define PURESTAT
80 #endif
81 */
82
83 /* Define this to use malloc/free with no freelist for all datatypes,
84    the hope being that some debugging tools may help detect
85    freed memory references */
86 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */
87 #include <dmalloc.h>
88 #define ALLOC_NO_POOLS
89 #endif
90
91 #include "puresize.h"
92
93 #ifdef DEBUG_XEMACS
94 int debug_allocation;
95
96 int debug_allocation_backtrace_length;
97 #endif
98
99 /* Number of bytes of consing done since the last gc */
100 EMACS_INT consing_since_gc;
101 #ifdef EMACS_BTL
102 extern void cadillac_record_backtrace ();
103 #define INCREMENT_CONS_COUNTER_1(size)          \
104   do {                                          \
105     EMACS_INT __sz__ = ((EMACS_INT) (size));    \
106     consing_since_gc += __sz__;                 \
107     cadillac_record_backtrace (2, __sz__);      \
108   } while (0)
109 #else
110 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
111 #endif /* EMACS_BTL */
112
113 #define debug_allocation_backtrace()                            \
114 do {                                                            \
115   if (debug_allocation_backtrace_length > 0)                    \
116     debug_short_backtrace (debug_allocation_backtrace_length);  \
117 } while (0)
118
119 #ifdef DEBUG_XEMACS
120 #define INCREMENT_CONS_COUNTER(foosize, type)                   \
121   do {                                                          \
122     if (debug_allocation)                                       \
123       {                                                         \
124         stderr_out ("allocating %s (size %ld)\n", type, (long)foosize); \
125         debug_allocation_backtrace ();                          \
126       }                                                         \
127     INCREMENT_CONS_COUNTER_1 (foosize);                         \
128   } while (0)
129 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type)           \
130   do {                                                          \
131     if (debug_allocation > 1)                                   \
132       {                                                         \
133         stderr_out ("allocating noseeum %s (size %ld)\n", type, (long)foosize); \
134         debug_allocation_backtrace ();                          \
135       }                                                         \
136     INCREMENT_CONS_COUNTER_1 (foosize);                         \
137   } while (0)
138 #else
139 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
140 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
141   INCREMENT_CONS_COUNTER_1 (size)
142 #endif
143
144 #define DECREMENT_CONS_COUNTER(size)            \
145   do {                                          \
146     EMACS_INT __sz__ = ((EMACS_INT) (size));    \
147     if (consing_since_gc >= __sz__)             \
148       consing_since_gc -= __sz__;               \
149     else                                        \
150       consing_since_gc = 0;                     \
151   } while (0)
152
153 /* Number of bytes of consing since gc before another gc should be done. */
154 EMACS_INT gc_cons_threshold;
155
156 /* Nonzero during gc */
157 int gc_in_progress;
158
159 /* Number of times GC has happened at this level or below.
160  * Level 0 is most volatile, contrary to usual convention.
161  *  (Of course, there's only one level at present) */
162 EMACS_INT gc_generation_number[1];
163
164 /* This is just for use by the printer, to allow things to print uniquely */
165 static int lrecord_uid_counter;
166
167 /* Nonzero when calling certain hooks or doing other things where
168    a GC would be bad */
169 int gc_currently_forbidden;
170
171 /* Hooks. */
172 Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
173 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
174
175 /* "Garbage collecting" */
176 Lisp_Object Vgc_message;
177 Lisp_Object Vgc_pointer_glyph;
178 static CONST char gc_default_message[] = "Garbage collecting";
179 Lisp_Object Qgarbage_collecting;
180
181 #ifndef VIRT_ADDR_VARIES
182 extern
183 #endif /* VIRT_ADDR_VARIES */
184  EMACS_INT malloc_sbrk_used;
185
186 #ifndef VIRT_ADDR_VARIES
187 extern
188 #endif /* VIRT_ADDR_VARIES */
189  EMACS_INT malloc_sbrk_unused;
190
191 /* Non-zero means defun should do purecopy on the function definition */
192 int purify_flag;
193
194 #ifdef HEAP_IN_DATA
195 extern void sheap_adjust_h();
196 #endif
197
198 #define PUREBEG ((char *) pure)
199
200 #if 0 /* This is breathing_space in XEmacs */
201 /* Points to memory space allocated as "spare",
202    to be freed if we run out of memory.  */
203 static char *spare_memory;
204
205 /* Amount of spare memory to keep in reserve.  */
206 #define SPARE_MEMORY (1 << 14)
207 #endif
208
209 /* Index in pure at which next pure object will be allocated. */
210 static size_t pure_bytes_used;
211
212 #define PURIFIED(ptr)                           \
213 ((char *) (ptr) >= PUREBEG &&                   \
214  (char *) (ptr) <  PUREBEG + get_PURESIZE())
215
216 /* Non-zero if pure_bytes_used > get_PURESIZE(); accounts for excess purespace needs. */
217 static size_t pure_lossage;
218
219 #ifdef ERROR_CHECK_TYPECHECK
220
221 Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
222
223 #endif
224
225 int
226 purified (Lisp_Object obj)
227 {
228   return POINTER_TYPE_P (XGCTYPE (obj)) && PURIFIED (XPNTR (obj));
229 }
230
231 size_t
232 purespace_usage (void)
233 {
234   return pure_bytes_used;
235 }
236
237 static int
238 check_purespace (size_t size)
239 {
240   if (pure_lossage)
241     {
242       pure_lossage += size;
243       return 0;
244     }
245   else if (pure_bytes_used + size > get_PURESIZE())
246     {
247       /* This can cause recursive bad behavior, we'll yell at the end */
248       /* when we're done. */
249       /* message ("\nERROR:  Pure Lisp storage exhausted!\n"); */
250       pure_lossage = size;
251       return 0;
252     }
253   else
254     return 1;
255 }
256
257
258 \f
259 #ifndef PURESTAT
260
261 #define bump_purestat(p,b) DO_NOTHING
262
263 #else /* PURESTAT */
264
265 static int purecopying_for_bytecode;
266
267 static size_t pure_sizeof (Lisp_Object /*, int recurse */);
268
269 /* Keep statistics on how much of what is in purespace */
270 static struct purestat
271 {
272   int nobjects;
273   int nbytes;
274   CONST char *name;
275 }
276   purestat_cons = {0, 0, "cons cells"},
277   purestat_float = {0, 0, "float objects"},
278   purestat_string_pname = {0, 0, "symbol-name strings"},
279   purestat_bytecode = {0, 0, "compiled-function objects"},
280   purestat_string_bytecodes = {0, 0, "byte-code strings"},
281   purestat_vector_bytecode_constants = {0, 0, "byte-constant vectors"},
282   purestat_string_interactive = {0, 0, "interactive strings"},
283 #ifdef I18N3
284   purestat_string_domain = {0, 0, "domain strings"},
285 #endif
286   purestat_string_documentation = {0, 0, "documentation strings"},
287   purestat_string_other_function = {0, 0, "other function strings"},
288   purestat_vector_other = {0, 0, "other vectors"},
289   purestat_string_other = {0, 0, "other strings"},
290   purestat_string_all = {0, 0, "all strings"},
291   purestat_vector_all = {0, 0, "all vectors"};
292
293 static struct purestat *purestats[] =
294 {
295   &purestat_cons,
296   &purestat_float,
297   &purestat_string_pname,
298   &purestat_bytecode,
299   &purestat_string_bytecodes,
300   &purestat_vector_bytecode_constants,
301   &purestat_string_interactive,
302 #ifdef I18N3
303   &purestat_string_domain,
304 #endif
305   &purestat_string_documentation,
306   &purestat_string_other_function,
307   &purestat_vector_other,
308   &purestat_string_other,
309   0,
310   &purestat_string_all,
311   &purestat_vector_all
312 };
313
314 static void
315 bump_purestat (struct purestat *purestat, size_t nbytes)
316 {
317   if (pure_lossage) return;
318   purestat->nobjects += 1;
319   purestat->nbytes += nbytes;
320 }
321 #endif /* PURESTAT */
322
323 \f
324 /* Maximum amount of C stack to save when a GC happens.  */
325
326 #ifndef MAX_SAVE_STACK
327 #define MAX_SAVE_STACK 16000
328 #endif
329
330 /* Non-zero means ignore malloc warnings.  Set during initialization.  */
331 int ignore_malloc_warnings;
332
333 \f
334 static void *breathing_space;
335
336 void
337 release_breathing_space (void)
338 {
339   if (breathing_space)
340     {
341       void *tmp = breathing_space;
342       breathing_space = 0;
343       xfree (tmp);
344     }
345 }
346
347 /* malloc calls this if it finds we are near exhausting storage */
348 void
349 malloc_warning (CONST char *str)
350 {
351   if (ignore_malloc_warnings)
352     return;
353
354   warn_when_safe
355     (Qmemory, Qcritical,
356      "%s\n"
357      "Killing some buffers may delay running out of memory.\n"
358      "However, certainly by the time you receive the 95%% warning,\n"
359      "you should clean up, kill this Emacs, and start a new one.",
360      str);
361 }
362
363 /* Called if malloc returns zero */
364 DOESNT_RETURN
365 memory_full (void)
366 {
367   /* Force a GC next time eval is called.
368      It's better to loop garbage-collecting (we might reclaim enough
369      to win) than to loop beeping and barfing "Memory exhausted"
370    */
371   consing_since_gc = gc_cons_threshold + 1;
372   release_breathing_space ();
373
374   /* Flush some histories which might conceivably contain garbalogical
375      inhibitors.  */
376   if (!NILP (Fboundp (Qvalues)))
377     Fset (Qvalues, Qnil);
378   Vcommand_history = Qnil;
379
380   error ("Memory exhausted");
381 }
382
383 /* like malloc and realloc but check for no memory left, and block input. */
384
385 #ifdef xmalloc
386 #undef xmalloc
387 #endif
388
389 void *
390 xmalloc (size_t size)
391 {
392   void *val = (void *) malloc (size);
393
394   if (!val && (size != 0)) memory_full ();
395   return val;
396 }
397
398 void *
399 xmalloc_and_zero (size_t size)
400 {
401   void *val = xmalloc (size);
402   memset (val, 0, size);
403   return val;
404 }
405
406 #ifdef xrealloc
407 #undef xrealloc
408 #endif
409
410 void *
411 xrealloc (void *block, size_t size)
412 {
413   /* We must call malloc explicitly when BLOCK is 0, since some
414      reallocs don't do this.  */
415   void *val = (void *) (block ? realloc (block, size) : malloc (size));
416
417   if (!val && (size != 0)) memory_full ();
418   return val;
419 }
420
421 void
422 #ifdef ERROR_CHECK_MALLOC
423 xfree_1 (void *block)
424 #else
425 xfree (void *block)
426 #endif
427 {
428 #ifdef ERROR_CHECK_MALLOC
429   /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
430      error until much later on for many system mallocs, such as
431      the one that comes with Solaris 2.3.  FMH!! */
432   assert (block != (void *) 0xDEADBEEF);
433   assert (block);
434 #endif /* ERROR_CHECK_MALLOC */
435   free (block);
436 }
437
438 #ifdef ERROR_CHECK_GC
439
440 #if SIZEOF_INT == 4
441 typedef unsigned int four_byte_t;
442 #elif SIZEOF_LONG == 4
443 typedef unsigned long four_byte_t;
444 #elif SIZEOF_SHORT == 4
445 typedef unsigned short four_byte_t;
446 #else
447 What kind of strange-ass system are we running on?
448 #endif
449
450 static void
451 deadbeef_memory (void *ptr, size_t size)
452 {
453   four_byte_t *ptr4 = (four_byte_t *) ptr;
454   size_t beefs = size >> 2;
455
456   /* In practice, size will always be a multiple of four.  */
457   while (beefs--)
458     (*ptr4++) = 0xDEADBEEF;
459 }
460
461 #else /* !ERROR_CHECK_GC */
462
463
464 #define deadbeef_memory(ptr, size)
465
466 #endif /* !ERROR_CHECK_GC */
467
468 #ifdef xstrdup
469 #undef xstrdup
470 #endif
471
472 char *
473 xstrdup (CONST char *str)
474 {
475   int len = strlen (str) + 1;   /* for stupid terminating 0 */
476
477   void *val = xmalloc (len);
478   if (val == 0) return 0;
479   memcpy (val, str, len);
480   return (char *) val;
481 }
482
483 #ifdef NEED_STRDUP
484 char *
485 strdup (CONST char *s)
486 {
487   return xstrdup (s);
488 }
489 #endif /* NEED_STRDUP */
490
491 \f
492 static void *
493 allocate_lisp_storage (size_t size)
494 {
495   void *p = xmalloc (size);
496 #ifndef USE_MINIMAL_TAGBITS
497   char *lim = ((char *) p) + size;
498   Lisp_Object val;
499
500   XSETOBJ (val, Lisp_Type_Record, lim);
501   if ((char *) XPNTR (val) != lim)
502     {
503       xfree (p);
504       memory_full ();
505     }
506 #endif /* ! USE_MINIMAL_TAGBITS */
507   return p;
508 }
509
510
511 /* lrecords are chained together through their "next.v" field.
512  * After doing the mark phase, the GC will walk this linked
513  *  list and free any record which hasn't been marked.
514  */
515 static struct lcrecord_header *all_lcrecords;
516
517 void *
518 alloc_lcrecord (size_t size, CONST struct lrecord_implementation *implementation)
519 {
520   struct lcrecord_header *lcheader;
521
522   if (size <= 0) abort ();
523   if (implementation->static_size == 0)
524     {
525       if (!implementation->size_in_bytes_method)
526         abort ();
527     }
528   else if (implementation->static_size != size)
529     abort ();
530
531   lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
532   set_lheader_implementation(&(lcheader->lheader), implementation);
533   lcheader->next = all_lcrecords;
534 #if 1                           /* mly prefers to see small ID numbers */
535   lcheader->uid = lrecord_uid_counter++;
536 #else                           /* jwz prefers to see real addrs */
537   lcheader->uid = (int) &lcheader;
538 #endif
539   lcheader->free = 0;
540   all_lcrecords = lcheader;
541   INCREMENT_CONS_COUNTER (size, implementation->name);
542   return lcheader;
543 }
544
545 #if 0 /* Presently unused */
546 /* Very, very poor man's EGC?
547  * This may be slow and thrash pages all over the place.
548  *  Only call it if you really feel you must (and if the
549  *  lrecord was fairly recently allocated).
550  * Otherwise, just let the GC do its job -- that's what it's there for
551  */
552 void
553 free_lcrecord (struct lcrecord_header *lcrecord)
554 {
555   if (all_lcrecords == lcrecord)
556     {
557       all_lcrecords = lcrecord->next;
558     }
559   else
560     {
561       struct lrecord_header *header = all_lcrecords;
562       for (;;)
563         {
564           struct lrecord_header *next = header->next;
565           if (next == lcrecord)
566             {
567               header->next = lrecord->next;
568               break;
569             }
570           else if (next == 0)
571             abort ();
572           else
573             header = next;
574         }
575     }
576   if (lrecord->implementation->finalizer)
577     ((lrecord->implementation->finalizer) (lrecord, 0));
578   xfree (lrecord);
579   return;
580 }
581 #endif /* Unused */
582
583
584 static void
585 disksave_object_finalization_1 (void)
586 {
587   struct lcrecord_header *header;
588
589   for (header = all_lcrecords; header; header = header->next)
590     {
591       if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
592           !header->free)
593         ((LHEADER_IMPLEMENTATION(&header->lheader)->finalizer)
594          (header, 1));
595     }
596 }
597
598
599 /* This must not be called -- it just serves as for EQ test
600  *  If lheader->implementation->finalizer is this_marks_a_marked_record,
601  *  then lrecord has been marked by the GC sweeper
602  * header->implementation is put back to its correct value by
603  *  sweep_records */
604 void
605 this_marks_a_marked_record (void *dummy0, int dummy1)
606 {
607   abort ();
608 }
609
610 /* Semi-kludge -- lrecord_symbol_value_forward objects get stuck
611    in CONST space and you get SEGV's if you attempt to mark them.
612    This sits in lheader->implementation->marker. */
613
614 Lisp_Object
615 this_one_is_unmarkable (Lisp_Object obj, void (*markobj) (Lisp_Object))
616 {
617   abort ();
618   return Qnil;
619 }
620
621 /* XGCTYPE for records */
622 int
623 gc_record_type_p (Lisp_Object frob, CONST struct lrecord_implementation *type)
624 {
625   CONST struct lrecord_implementation *imp;
626
627   if (XGCTYPE (frob) != Lisp_Type_Record)
628     return 0;
629
630   imp = XRECORD_LHEADER_IMPLEMENTATION (frob);
631 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
632   return imp == type;
633 #else
634   return imp == type || imp == type + 1;
635 #endif
636 }
637
638 \f
639 /**********************************************************************/
640 /*                        Debugger support                            */
641 /**********************************************************************/
642 /* Give gdb/dbx enough information to decode Lisp Objects.
643    We make sure certain symbols are defined, so gdb doesn't complain
644    about expressions in src/gdbinit.  Values are randomly chosen.
645    See src/gdbinit or src/dbxrc to see how this is used.  */
646
647 enum dbg_constants
648 {
649 #ifdef USE_MINIMAL_TAGBITS
650   dbg_valmask = (EMACS_INT) (((1UL << VALBITS) - 1) << GCBITS),
651   dbg_typemask = (EMACS_INT) ((1UL << GCTYPEBITS) - 1),
652   dbg_USE_MINIMAL_TAGBITS = 1,
653   dbg_Lisp_Type_Int = 100,
654 #else /* ! USE_MIMIMAL_TAGBITS */
655   dbg_valmask = (EMACS_INT) ((1UL << VALBITS) - 1),
656   dbg_typemask = (EMACS_INT) (((1UL << GCTYPEBITS) - 1) << (VALBITS + GCMARKBITS)),
657   dbg_USE_MINIMAL_TAGBITS = 0,
658   dbg_Lisp_Type_Int = Lisp_Type_Int,
659 #endif /* ! USE_MIMIMAL_TAGBITS */
660 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
661   dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1,
662 #else
663   dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0,
664 #endif
665   dbg_Lisp_Type_Char = Lisp_Type_Char,
666   dbg_Lisp_Type_Record = Lisp_Type_Record,
667 #ifdef LRECORD_CONS
668   dbg_Lisp_Type_Cons = 101,
669 #else
670   dbg_Lisp_Type_Cons = Lisp_Type_Cons,
671   lrecord_cons = 201,
672 #endif
673 #ifdef LRECORD_STRING
674   dbg_Lisp_Type_String = 102,
675 #else
676   dbg_Lisp_Type_String = Lisp_Type_String,
677   lrecord_string = 202,
678 #endif
679 #ifdef LRECORD_VECTOR
680   dbg_Lisp_Type_Vector = 103,
681 #else
682   dbg_Lisp_Type_Vector = Lisp_Type_Vector,
683   lrecord_vector = 203,
684 #endif
685 #ifdef LRECORD_SYMBOL
686   dbg_Lisp_Type_Symbol = 104,
687 #else
688   dbg_Lisp_Type_Symbol = Lisp_Type_Symbol,
689   lrecord_symbol = 204,
690 #endif
691 #ifndef MULE
692   lrecord_char_table_entry = 205,
693   lrecord_charset          = 206,
694   lrecord_coding_system    = 207,
695 #endif
696 #ifndef HAVE_TOOLBARS
697   lrecord_toolbar_button   = 208,
698 #endif
699 #ifndef HAVE_TOOLTALK
700   lrecord_tooltalk_message = 210,
701   lrecord_tooltalk_pattern = 211,
702 #endif
703 #ifndef HAVE_DATABASE
704   lrecord_database = 212,
705 #endif
706   dbg_valbits = VALBITS,
707   dbg_gctypebits = GCTYPEBITS
708   /* If we don't have an actual object of this enum, pgcc (and perhaps
709      other compilers) might optimize away the entire type declaration :-( */
710 } dbg_dummy;
711
712 \f
713 /**********************************************************************/
714 /*                        Fixed-size type macros                      */
715 /**********************************************************************/
716
717 /* For fixed-size types that are commonly used, we malloc() large blocks
718    of memory at a time and subdivide them into chunks of the correct
719    size for an object of that type.  This is more efficient than
720    malloc()ing each object separately because we save on malloc() time
721    and overhead due to the fewer number of malloc()ed blocks, and
722    also because we don't need any extra pointers within each object
723    to keep them threaded together for GC purposes.  For less common
724    (and frequently large-size) types, we use lcrecords, which are
725    malloc()ed individually and chained together through a pointer
726    in the lcrecord header.  lcrecords do not need to be fixed-size
727    (i.e. two objects of the same type need not have the same size;
728    however, the size of a particular object cannot vary dynamically).
729    It is also much easier to create a new lcrecord type because no
730    additional code needs to be added to alloc.c.  Finally, lcrecords
731    may be more efficient when there are only a small number of them.
732
733    The types that are stored in these large blocks (or "frob blocks")
734    are cons, float, compiled-function, symbol, marker, extent, event,
735    and string.
736
737    Note that strings are special in that they are actually stored in
738    two parts: a structure containing information about the string, and
739    the actual data associated with the string.  The former structure
740    (a struct Lisp_String) is a fixed-size structure and is managed the
741    same way as all the other such types.  This structure contains a
742    pointer to the actual string data, which is stored in structures of
743    type struct string_chars_block.  Each string_chars_block consists
744    of a pointer to a struct Lisp_String, followed by the data for that
745    string, followed by another pointer to a struct Lisp_String,
746    followed by the data for that string, etc.  At GC time, the data in
747    these blocks is compacted by searching sequentially through all the
748    blocks and compressing out any holes created by unmarked strings.
749    Strings that are more than a certain size (bigger than the size of
750    a string_chars_block, although something like half as big might
751    make more sense) are malloc()ed separately and not stored in
752    string_chars_blocks.  Furthermore, no one string stretches across
753    two string_chars_blocks.
754
755    Vectors are each malloc()ed separately, similar to lcrecords.
756
757    In the following discussion, we use conses, but it applies equally
758    well to the other fixed-size types.
759
760    We store cons cells inside of cons_blocks, allocating a new
761    cons_block with malloc() whenever necessary.  Cons cells reclaimed
762    by GC are put on a free list to be reallocated before allocating
763    any new cons cells from the latest cons_block.  Each cons_block is
764    just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least
765    the versions in malloc.c and gmalloc.c) really allocates in units
766    of powers of two and uses 4 bytes for its own overhead.
767
768    What GC actually does is to search through all the cons_blocks,
769    from the most recently allocated to the oldest, and put all
770    cons cells that are not marked (whether or not they're already
771    free) on a cons_free_list.  The cons_free_list is a stack, and
772    so the cons cells in the oldest-allocated cons_block end up
773    at the head of the stack and are the first to be reallocated.
774    If any cons_block is entirely free, it is freed with free()
775    and its cons cells removed from the cons_free_list.  Because
776    the cons_free_list ends up basically in memory order, we have
777    a high locality of reference (assuming a reasonable turnover
778    of allocating and freeing) and have a reasonable probability
779    of entirely freeing up cons_blocks that have been more recently
780    allocated.  This stage is called the "sweep stage" of GC, and
781    is executed after the "mark stage", which involves starting
782    from all places that are known to point to in-use Lisp objects
783    (e.g. the obarray, where are all symbols are stored; the
784    current catches and condition-cases; the backtrace list of
785    currently executing functions; the gcpro list; etc.) and
786    recursively marking all objects that are accessible.
787
788    At the beginning of the sweep stage, the conses in the cons
789    blocks are in one of three states: in use and marked, in use
790    but not marked, and not in use (already freed).  Any conses
791    that are marked have been marked in the mark stage just
792    executed, because as part of the sweep stage we unmark any
793    marked objects.  The way we tell whether or not a cons cell
794    is in use is through the FREE_STRUCT_P macro.  This basically
795    looks at the first 4 bytes (or however many bytes a pointer
796    fits in) to see if all the bits in those bytes are 1.  The
797    resulting value (0xFFFFFFFF) is not a valid pointer and is
798    not a valid Lisp_Object.  All current fixed-size types have
799    a pointer or Lisp_Object as their first element with the
800    exception of strings; they have a size value, which can
801    never be less than zero, and so 0xFFFFFFFF is invalid for
802    strings as well.  Now assuming that a cons cell is in use,
803    the way we tell whether or not it is marked is to look at
804    the mark bit of its car (each Lisp_Object has one bit
805    reserved as a mark bit, in case it's needed).  Note that
806    different types of objects use different fields to indicate
807    whether the object is marked, but the principle is the same.
808
809    Conses on the free_cons_list are threaded through a pointer
810    stored in the bytes directly after the bytes that are set
811    to 0xFFFFFFFF (we cannot overwrite these because the cons
812    is still in a cons_block and needs to remain marked as
813    not in use for the next time that GC happens).  This
814    implies that all fixed-size types must be at least big
815    enough to store two pointers, which is indeed the case
816    for all current fixed-size types.
817
818    Some types of objects need additional "finalization" done
819    when an object is converted from in use to not in use;
820    this is the purpose of the ADDITIONAL_FREE_type macro.
821    For example, markers need to be removed from the chain
822    of markers that is kept in each buffer.  This is because
823    markers in a buffer automatically disappear if the marker
824    is no longer referenced anywhere (the same does not
825    apply to extents, however).
826
827    WARNING: Things are in an extremely bizarre state when
828    the ADDITIONAL_FREE_type macros are called, so beware!
829
830    When ERROR_CHECK_GC is defined, we do things differently
831    so as to maximize our chances of catching places where
832    there is insufficient GCPROing.  The thing we want to
833    avoid is having an object that we're using but didn't
834    GCPRO get freed by GC and then reallocated while we're
835    in the process of using it -- this will result in something
836    seemingly unrelated getting trashed, and is extremely
837    difficult to track down.  If the object gets freed but
838    not reallocated, we can usually catch this because we
839    set all bytes of a freed object to 0xDEADBEEF. (The
840    first four bytes, however, are 0xFFFFFFFF, and the next
841    four are a pointer used to chain freed objects together;
842    we play some tricks with this pointer to make it more
843    bogus, so crashes are more likely to occur right away.)
844
845    We want freed objects to stay free as long as possible,
846    so instead of doing what we do above, we maintain the
847    free objects in a first-in first-out queue.  We also
848    don't recompute the free list each GC, unlike above;
849    this ensures that the queue ordering is preserved.
850    [This means that we are likely to have worse locality
851    of reference, and that we can never free a frob block
852    once it's allocated. (Even if we know that all cells
853    in it are free, there's no easy way to remove all those
854    cells from the free list because the objects on the
855    free list are unlikely to be in memory order.)]
856    Furthermore, we never take objects off the free list
857    unless there's a large number (usually 1000, but
858    varies depending on type) of them already on the list.
859    This way, we ensure that an object that gets freed will
860    remain free for the next 1000 (or whatever) times that
861    an object of that type is allocated.
862 */
863
864 #ifndef MALLOC_OVERHEAD
865 #ifdef GNU_MALLOC
866 #define MALLOC_OVERHEAD 0
867 #elif defined (rcheck)
868 #define MALLOC_OVERHEAD 20
869 #else
870 #define MALLOC_OVERHEAD 8
871 #endif
872 #endif /* MALLOC_OVERHEAD */
873
874 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
875 /* If we released our reserve (due to running out of memory),
876    and we have a fair amount free once again,
877    try to set aside another reserve in case we run out once more.
878
879    This is called when a relocatable block is freed in ralloc.c.  */
880 void refill_memory_reserve (void);
881 void
882 refill_memory_reserve ()
883 {
884   if (breathing_space == 0)
885     breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
886 }
887 #endif
888
889 #ifdef ALLOC_NO_POOLS
890 # define TYPE_ALLOC_SIZE(type, structtype) 1
891 #else
892 # define TYPE_ALLOC_SIZE(type, structtype)                      \
893     ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *))  \
894      / sizeof (structtype))
895 #endif /* ALLOC_NO_POOLS */
896
897 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype)                        \
898                                                                           \
899 struct type##_block                                                       \
900 {                                                                         \
901   struct type##_block *prev;                                              \
902   structtype block[TYPE_ALLOC_SIZE (type, structtype)];                   \
903 };                                                                        \
904                                                                           \
905 static struct type##_block *current_##type##_block;                       \
906 static int current_##type##_block_index;                                  \
907                                                                           \
908 static structtype *type##_free_list;                                      \
909 static structtype *type##_free_list_tail;                                 \
910                                                                           \
911 static void                                                               \
912 init_##type##_alloc (void)                                                \
913 {                                                                         \
914   current_##type##_block = 0;                                             \
915   current_##type##_block_index = countof (current_##type##_block->block); \
916   type##_free_list = 0;                                                   \
917   type##_free_list_tail = 0;                                              \
918 }                                                                         \
919                                                                           \
920 static int gc_count_num_##type##_in_use, gc_count_num_##type##_freelist
921
922 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result)                    \
923   do {                                                                  \
924     if (current_##type##_block_index                                    \
925         == countof (current_##type##_block->block))                     \
926     {                                                                   \
927       struct type##_block *__new__ = (struct type##_block *)            \
928          allocate_lisp_storage (sizeof (struct type##_block));          \
929       __new__->prev = current_##type##_block;                           \
930       current_##type##_block = __new__;                                 \
931       current_##type##_block_index = 0;                                 \
932     }                                                                   \
933     (result) =                                                          \
934       &(current_##type##_block->block[current_##type##_block_index++]); \
935   } while (0)
936
937 /* Allocate an instance of a type that is stored in blocks.
938    TYPE is the "name" of the type, STRUCTTYPE is the corresponding
939    structure type. */
940
941 #ifdef ERROR_CHECK_GC
942
943 /* Note: if you get crashes in this function, suspect incorrect calls
944    to free_cons() and friends.  This happened once because the cons
945    cell was not GC-protected and was getting collected before
946    free_cons() was called. */
947
948 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result)                  \
949 do                                                                       \
950 {                                                                        \
951   if (gc_count_num_##type##_freelist >                                   \
952       MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type)                           \
953     {                                                                    \
954       result = type##_free_list;                                         \
955       /* Before actually using the chain pointer, we complement all its  \
956          bits; see FREE_FIXED_TYPE(). */                                 \
957       type##_free_list =                                                 \
958         (structtype *) ~(unsigned long)                                  \
959           (* (structtype **) ((char *) result + sizeof (void *)));       \
960       gc_count_num_##type##_freelist--;                                  \
961     }                                                                    \
962   else                                                                   \
963     ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result);                       \
964   MARK_STRUCT_AS_NOT_FREE (result);                                      \
965 } while (0)
966
967 #else /* !ERROR_CHECK_GC */
968
969 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result)         \
970 do                                                              \
971 {                                                               \
972   if (type##_free_list)                                         \
973     {                                                           \
974       result = type##_free_list;                                \
975       type##_free_list =                                        \
976         * (structtype **) ((char *) result + sizeof (void *));  \
977     }                                                           \
978   else                                                          \
979     ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result);              \
980   MARK_STRUCT_AS_NOT_FREE (result);                             \
981 } while (0)
982
983 #endif /* !ERROR_CHECK_GC */
984
985 #define ALLOCATE_FIXED_TYPE(type, structtype, result)   \
986 do                                                      \
987 {                                                       \
988   ALLOCATE_FIXED_TYPE_1 (type, structtype, result);     \
989   INCREMENT_CONS_COUNTER (sizeof (structtype), #type);  \
990 } while (0)
991
992 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result)   \
993 do                                                              \
994 {                                                               \
995   ALLOCATE_FIXED_TYPE_1 (type, structtype, result);             \
996   NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type);  \
997 } while (0)
998
999 /* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
1000    to a Lisp object and invalid as an actual Lisp_Object value.  We have
1001    to make sure that this value cannot be an integer in Lisp_Object form.
1002    0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
1003    On a 32-bit system, the type bits will be non-zero, making the value
1004    be a pointer, and the pointer will be misaligned.
1005
1006    Even if Emacs is run on some weirdo system that allows and allocates
1007    byte-aligned pointers, this pointer is at the very top of the address
1008    space and so it's almost inconceivable that it could ever be valid. */
1009
1010 #if INTBITS == 32
1011 # define INVALID_POINTER_VALUE 0xFFFFFFFF
1012 #elif INTBITS == 48
1013 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
1014 #elif INTBITS == 64
1015 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
1016 #else
1017 You have some weird system and need to supply a reasonable value here.
1018 #endif
1019
1020 #define FREE_STRUCT_P(ptr) \
1021   (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
1022 #define MARK_STRUCT_AS_FREE(ptr) \
1023   (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
1024 #define MARK_STRUCT_AS_NOT_FREE(ptr) \
1025   (* (void **) ptr = 0)
1026
1027 #ifdef ERROR_CHECK_GC
1028
1029 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr)              \
1030 do { if (type##_free_list_tail)                                         \
1031        {                                                                \
1032          /* When we store the chain pointer, we complement all          \
1033             its bits; this should significantly increase its            \
1034             bogosity in case someone tries to use the value, and        \
1035             should make us dump faster if someone stores something      \
1036             over the pointer because when it gets un-complemented in    \
1037             ALLOCATED_FIXED_TYPE(), the resulting pointer will be       \
1038             extremely bogus. */                                         \
1039          * (structtype **)                                              \
1040            ((char *) type##_free_list_tail + sizeof (void *)) =         \
1041              (structtype *) ~(unsigned long) ptr;                       \
1042        }                                                                \
1043      else                                                               \
1044        type##_free_list = ptr;                                          \
1045      type##_free_list_tail = ptr;                                       \
1046    } while (0)
1047
1048 #else /* !ERROR_CHECK_GC */
1049
1050 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr)      \
1051 do { * (structtype **) ((char *) ptr + sizeof (void *)) =       \
1052        type##_free_list;                                        \
1053      type##_free_list = ptr;                                    \
1054    } while (0)
1055
1056 #endif /* !ERROR_CHECK_GC */
1057
1058 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
1059
1060 #define FREE_FIXED_TYPE(type, structtype, ptr)                  \
1061 do { structtype *_weird_ = (ptr);                               \
1062      ADDITIONAL_FREE_##type (_weird_);                          \
1063      deadbeef_memory (ptr, sizeof (structtype));                \
1064      PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, ptr);       \
1065      MARK_STRUCT_AS_FREE (_weird_);                             \
1066    } while (0)
1067
1068 /* Like FREE_FIXED_TYPE() but used when we are explicitly
1069    freeing a structure through free_cons(), free_marker(), etc.
1070    rather than through the normal process of sweeping.
1071    We attempt to undo the changes made to the allocation counters
1072    as a result of this structure being allocated.  This is not
1073    completely necessary but helps keep things saner: e.g. this way,
1074    repeatedly allocating and freeing a cons will not result in
1075    the consing-since-gc counter advancing, which would cause a GC
1076    and somewhat defeat the purpose of explicitly freeing. */
1077
1078 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr)   \
1079 do { FREE_FIXED_TYPE (type, structtype, ptr);                   \
1080      DECREMENT_CONS_COUNTER (sizeof (structtype));              \
1081      gc_count_num_##type##_freelist++;                          \
1082    } while (0)
1083
1084
1085 \f
1086 /**********************************************************************/
1087 /*                         Cons allocation                            */
1088 /**********************************************************************/
1089
1090 DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons);
1091 /* conses are used and freed so often that we set this really high */
1092 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
1093 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
1094
1095 #ifdef LRECORD_CONS
1096 static Lisp_Object
1097 mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object))
1098 {
1099   if (NILP (XCDR (obj)))
1100     return XCAR (obj);
1101
1102   (markobj) (XCAR (obj));
1103   return XCDR (obj);
1104 }
1105
1106 static int
1107 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth)
1108 {
1109   while (internal_equal (XCAR (ob1), XCAR (ob2), depth + 1))
1110     {
1111       ob1 = XCDR (ob1);
1112       ob2 = XCDR (ob2);
1113       if (! CONSP (ob1) || ! CONSP (ob2))
1114         return internal_equal (ob1, ob2, depth + 1);
1115     }
1116   return 0;
1117 }
1118
1119 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
1120                                      mark_cons, print_cons, 0,
1121                                      cons_equal,
1122                                      /*
1123                                       * No `hash' method needed.
1124                                       * internal_hash knows how to
1125                                       * handle conses.
1126                                       */
1127                                      0,
1128                                      struct Lisp_Cons);
1129 #endif /* LRECORD_CONS */
1130
1131 DEFUN ("cons", Fcons, 2, 2, 0, /*
1132 Create a new cons, give it CAR and CDR as components, and return it.
1133 */
1134        (car, cdr))
1135 {
1136   /* This cannot GC. */
1137   Lisp_Object val;
1138   struct Lisp_Cons *c;
1139
1140   ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1141 #ifdef LRECORD_CONS
1142   set_lheader_implementation (&(c->lheader), lrecord_cons);
1143 #endif
1144   XSETCONS (val, c);
1145   c->car = car;
1146   c->cdr = cdr;
1147   return val;
1148 }
1149
1150 /* This is identical to Fcons() but it used for conses that we're
1151    going to free later, and is useful when trying to track down
1152    "real" consing. */
1153 Lisp_Object
1154 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
1155 {
1156   Lisp_Object val;
1157   struct Lisp_Cons *c;
1158
1159   NOSEEUM_ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
1160 #ifdef LRECORD_CONS
1161   set_lheader_implementation (&(c->lheader), lrecord_cons);
1162 #endif
1163   XSETCONS (val, c);
1164   XCAR (val) = car;
1165   XCDR (val) = cdr;
1166   return val;
1167 }
1168
1169 DEFUN ("list", Flist, 0, MANY, 0, /*
1170 Return a newly created list with specified arguments as elements.
1171 Any number of arguments, even zero arguments, are allowed.
1172 */
1173        (int nargs, Lisp_Object *args))
1174 {
1175   Lisp_Object val = Qnil;
1176   Lisp_Object *argp = args + nargs;
1177
1178   while (nargs-- > 0)
1179     val = Fcons (*--argp, val);
1180   return val;
1181 }
1182
1183 Lisp_Object
1184 list1 (Lisp_Object obj0)
1185 {
1186   /* This cannot GC. */
1187   return Fcons (obj0, Qnil);
1188 }
1189
1190 Lisp_Object
1191 list2 (Lisp_Object obj0, Lisp_Object obj1)
1192 {
1193   /* This cannot GC. */
1194   return Fcons (obj0, Fcons (obj1, Qnil));
1195 }
1196
1197 Lisp_Object
1198 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1199 {
1200   /* This cannot GC. */
1201   return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil)));
1202 }
1203
1204 Lisp_Object
1205 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1206 {
1207   /* This cannot GC. */
1208   return Fcons (obj0, Fcons (obj1, obj2));
1209 }
1210
1211 Lisp_Object
1212 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist)
1213 {
1214   return Fcons (Fcons (key, value), alist);
1215 }
1216
1217 Lisp_Object
1218 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3)
1219 {
1220   /* This cannot GC. */
1221   return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil))));
1222 }
1223
1224 Lisp_Object
1225 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1226        Lisp_Object obj4)
1227 {
1228   /* This cannot GC. */
1229   return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil)))));
1230 }
1231
1232 Lisp_Object
1233 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3,
1234        Lisp_Object obj4, Lisp_Object obj5)
1235 {
1236   /* This cannot GC. */
1237   return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil))))));
1238 }
1239
1240 DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
1241 Return a new list of length LENGTH, with each element being INIT.
1242 */
1243        (length, init))
1244 {
1245   CHECK_NATNUM (length);
1246
1247   {
1248     Lisp_Object val = Qnil;
1249     int size = XINT (length);
1250
1251     while (size-- > 0)
1252       val = Fcons (init, val);
1253     return val;
1254   }
1255 }
1256
1257 \f
1258 /**********************************************************************/
1259 /*                        Float allocation                            */
1260 /**********************************************************************/
1261
1262 #ifdef LISP_FLOAT_TYPE
1263
1264 DECLARE_FIXED_TYPE_ALLOC (float, struct Lisp_Float);
1265 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000
1266
1267 Lisp_Object
1268 make_float (double float_value)
1269 {
1270   Lisp_Object val;
1271   struct Lisp_Float *f;
1272
1273   ALLOCATE_FIXED_TYPE (float, struct Lisp_Float, f);
1274   set_lheader_implementation (&(f->lheader), lrecord_float);
1275   float_data (f) = float_value;
1276   XSETFLOAT (val, f);
1277   return val;
1278 }
1279
1280 #endif /* LISP_FLOAT_TYPE */
1281
1282 \f
1283 /**********************************************************************/
1284 /*                         Vector allocation                          */
1285 /**********************************************************************/
1286
1287 #ifdef LRECORD_VECTOR
1288 static Lisp_Object
1289 mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
1290 {
1291   struct Lisp_Vector *ptr = XVECTOR (obj);
1292   int len = vector_length (ptr);
1293   int i;
1294
1295   for (i = 0; i < len - 1; i++)
1296     (markobj) (ptr->contents[i]);
1297   return (len > 0) ? ptr->contents[len - 1] : Qnil;
1298 }
1299
1300 static size_t
1301 size_vector (CONST void *lheader)
1302 {
1303   /* * -1 because struct Lisp_Vector includes 1 slot */
1304   return sizeof (struct Lisp_Vector) +
1305     ((((struct Lisp_Vector *) lheader)->size - 1) * sizeof (Lisp_Object));
1306 }
1307
1308 static int
1309 vector_equal (Lisp_Object o1, Lisp_Object o2, int depth)
1310 {
1311   int indice;
1312   int len = XVECTOR_LENGTH (o1);
1313   if (len != XVECTOR_LENGTH (o2))
1314     return 0;
1315   for (indice = 0; indice < len; indice++)
1316     {
1317       if (!internal_equal (XVECTOR_DATA (o1) [indice],
1318                            XVECTOR_DATA (o2) [indice],
1319                            depth + 1))
1320         return 0;
1321     }
1322   return 1;
1323 }
1324
1325 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
1326                                        mark_vector, print_vector, 0,
1327                                        vector_equal,
1328                                        /*
1329                                         * No `hash' method needed for
1330                                         * vectors.  internal_hash
1331                                         * knows how to handle vectors.
1332                                         */
1333                                        0,
1334                                        size_vector, struct Lisp_Vector);
1335
1336 /* #### should allocate `small' vectors from a frob-block */
1337 static struct Lisp_Vector *
1338 make_vector_internal (size_t sizei)
1339 {
1340   size_t sizem = (sizeof (struct Lisp_Vector)
1341                   /* -1 because struct Lisp_Vector includes 1 slot */
1342                   + (sizei - 1) * sizeof (Lisp_Object));
1343   struct Lisp_Vector *p =
1344     (struct Lisp_Vector *) alloc_lcrecord (sizem, lrecord_vector);
1345
1346   p->size = sizei;
1347   return p;
1348 }
1349
1350 #else /* ! LRECORD_VECTOR */
1351
1352 static Lisp_Object all_vectors;
1353
1354 /* #### should allocate `small' vectors from a frob-block */
1355 static struct Lisp_Vector *
1356 make_vector_internal (size_t sizei)
1357 {
1358   size_t sizem = (sizeof (struct Lisp_Vector)
1359                   /* -1 because struct Lisp_Vector includes 1 slot,
1360                    * +1 to account for vector_next */
1361                   + (sizei - 1 + 1) * sizeof (Lisp_Object));
1362   struct Lisp_Vector *p = (struct Lisp_Vector *) allocate_lisp_storage (sizem);
1363
1364   INCREMENT_CONS_COUNTER (sizem, "vector");
1365
1366   p->size = sizei;
1367   vector_next (p) = all_vectors;
1368   XSETVECTOR (all_vectors, p);
1369   return p;
1370 }
1371
1372 #endif /* ! LRECORD_VECTOR */
1373
1374 Lisp_Object
1375 make_vector (EMACS_INT length, Lisp_Object init)
1376 {
1377   int elt;
1378   Lisp_Object vector;
1379   struct Lisp_Vector *p;
1380
1381   if (length < 0)
1382     length = XINT (wrong_type_argument (Qnatnump, make_int (length)));
1383
1384   p = make_vector_internal (length);
1385   XSETVECTOR (vector, p);
1386
1387 #if 0
1388   /* Initialize big arrays full of 0's quickly, for what that's worth */
1389   {
1390     char *travesty = (char *) &init;
1391     for (i = 1; i < sizeof (Lisp_Object); i++)
1392     {
1393       if (travesty[i] != travesty[0])
1394         goto fill;
1395     }
1396     memset (vector_data (p), travesty[0], length * sizeof (Lisp_Object));
1397     return vector;
1398   }
1399  fill:
1400 #endif
1401   for (elt = 0; elt < length; elt++)
1402     vector_data(p)[elt] = init;
1403
1404   return vector;
1405 }
1406
1407 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
1408 Return a new vector of length LENGTH, with each element being INIT.
1409 See also the function `vector'.
1410 */
1411        (length, init))
1412 {
1413   CHECK_NATNUM (length);
1414   return make_vector (XINT (length), init);
1415 }
1416
1417 DEFUN ("vector", Fvector, 0, MANY, 0, /*
1418 Return a newly created vector with specified arguments as elements.
1419 Any number of arguments, even zero arguments, are allowed.
1420 */
1421        (int nargs, Lisp_Object *args))
1422 {
1423   Lisp_Object vector;
1424   int elt;
1425   struct Lisp_Vector *p = make_vector_internal (nargs);
1426
1427   for (elt = 0; elt < nargs; elt++)
1428     vector_data(p)[elt] = args[elt];
1429
1430   XSETVECTOR (vector, p);
1431   return vector;
1432 }
1433
1434 Lisp_Object
1435 vector1 (Lisp_Object obj0)
1436 {
1437   return Fvector (1, &obj0);
1438 }
1439
1440 Lisp_Object
1441 vector2 (Lisp_Object obj0, Lisp_Object obj1)
1442 {
1443   Lisp_Object args[2];
1444   args[0] = obj0;
1445   args[1] = obj1;
1446   return Fvector (2, args);
1447 }
1448
1449 Lisp_Object
1450 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2)
1451 {
1452   Lisp_Object args[3];
1453   args[0] = obj0;
1454   args[1] = obj1;
1455   args[2] = obj2;
1456   return Fvector (3, args);
1457 }
1458
1459 #if 0 /* currently unused */
1460
1461 Lisp_Object
1462 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1463          Lisp_Object obj3)
1464 {
1465   Lisp_Object args[4];
1466   args[0] = obj0;
1467   args[1] = obj1;
1468   args[2] = obj2;
1469   args[3] = obj3;
1470   return Fvector (4, args);
1471 }
1472
1473 Lisp_Object
1474 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1475          Lisp_Object obj3, Lisp_Object obj4)
1476 {
1477   Lisp_Object args[5];
1478   args[0] = obj0;
1479   args[1] = obj1;
1480   args[2] = obj2;
1481   args[3] = obj3;
1482   args[4] = obj4;
1483   return Fvector (5, args);
1484 }
1485
1486 Lisp_Object
1487 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1488          Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5)
1489 {
1490   Lisp_Object args[6];
1491   args[0] = obj0;
1492   args[1] = obj1;
1493   args[2] = obj2;
1494   args[3] = obj3;
1495   args[4] = obj4;
1496   args[5] = obj5;
1497   return Fvector (6, args);
1498 }
1499
1500 Lisp_Object
1501 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1502          Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1503          Lisp_Object obj6)
1504 {
1505   Lisp_Object args[7];
1506   args[0] = obj0;
1507   args[1] = obj1;
1508   args[2] = obj2;
1509   args[3] = obj3;
1510   args[4] = obj4;
1511   args[5] = obj5;
1512   args[6] = obj6;
1513   return Fvector (7, args);
1514 }
1515
1516 Lisp_Object
1517 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2,
1518          Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5,
1519          Lisp_Object obj6, Lisp_Object obj7)
1520 {
1521   Lisp_Object args[8];
1522   args[0] = obj0;
1523   args[1] = obj1;
1524   args[2] = obj2;
1525   args[3] = obj3;
1526   args[4] = obj4;
1527   args[5] = obj5;
1528   args[6] = obj6;
1529   args[7] = obj7;
1530   return Fvector (8, args);
1531 }
1532 #endif /* unused */
1533
1534 /**********************************************************************/
1535 /*                       Bit Vector allocation                        */
1536 /**********************************************************************/
1537
1538 static Lisp_Object all_bit_vectors;
1539
1540 /* #### should allocate `small' bit vectors from a frob-block */
1541 static struct Lisp_Bit_Vector *
1542 make_bit_vector_internal (size_t sizei)
1543 {
1544   size_t sizem = sizeof (struct Lisp_Bit_Vector) +
1545     /* -1 because struct Lisp_Bit_Vector includes 1 slot */
1546     sizeof (long) * (BIT_VECTOR_LONG_STORAGE (sizei) - 1);
1547   struct Lisp_Bit_Vector *p =
1548     (struct Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
1549   set_lheader_implementation (&(p->lheader), lrecord_bit_vector);
1550
1551   INCREMENT_CONS_COUNTER (sizem, "bit-vector");
1552
1553   bit_vector_length (p) = sizei;
1554   bit_vector_next (p) = all_bit_vectors;
1555   /* make sure the extra bits in the last long are 0; the calling
1556      functions might not set them. */
1557   p->bits[BIT_VECTOR_LONG_STORAGE (sizei) - 1] = 0;
1558   XSETBIT_VECTOR (all_bit_vectors, p);
1559   return p;
1560 }
1561
1562 Lisp_Object
1563 make_bit_vector (EMACS_INT length, Lisp_Object init)
1564 {
1565   Lisp_Object bit_vector;
1566   struct Lisp_Bit_Vector *p;
1567   EMACS_INT num_longs;
1568
1569   CHECK_BIT (init);
1570
1571   num_longs = BIT_VECTOR_LONG_STORAGE (length);
1572   p = make_bit_vector_internal (length);
1573   XSETBIT_VECTOR (bit_vector, p);
1574
1575   if (ZEROP (init))
1576     memset (p->bits, 0, num_longs * sizeof (long));
1577   else
1578     {
1579       EMACS_INT bits_in_last = length & (LONGBITS_POWER_OF_2 - 1);
1580       memset (p->bits, ~0, num_longs * sizeof (long));
1581       /* But we have to make sure that the unused bits in the
1582          last integer are 0, so that equal/hash is easy. */
1583       if (bits_in_last)
1584         p->bits[num_longs - 1] &= (1 << bits_in_last) - 1;
1585     }
1586
1587   return bit_vector;
1588 }
1589
1590 Lisp_Object
1591 make_bit_vector_from_byte_vector (unsigned char *bytevec, EMACS_INT length)
1592 {
1593   Lisp_Object bit_vector;
1594   struct Lisp_Bit_Vector *p;
1595   int i;
1596
1597   if (length < 0)
1598     length = XINT (wrong_type_argument (Qnatnump, make_int (length)));
1599
1600   p = make_bit_vector_internal (length);
1601   XSETBIT_VECTOR (bit_vector, p);
1602
1603   for (i = 0; i < length; i++)
1604     set_bit_vector_bit (p, i, bytevec[i]);
1605
1606   return bit_vector;
1607 }
1608
1609 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
1610 Return a new bit vector of length LENGTH. with each bit being INIT.
1611 Each element is set to INIT.  See also the function `bit-vector'.
1612 */
1613        (length, init))
1614 {
1615   CONCHECK_NATNUM (length);
1616
1617   return make_bit_vector (XINT (length), init);
1618 }
1619
1620 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
1621 Return a newly created bit vector with specified arguments as elements.
1622 Any number of arguments, even zero arguments, are allowed.
1623 */
1624        (int nargs, Lisp_Object *args))
1625 {
1626   Lisp_Object bit_vector;
1627   int elt;
1628   struct Lisp_Bit_Vector *p;
1629
1630   for (elt = 0; elt < nargs; elt++)
1631     CHECK_BIT (args[elt]);
1632
1633   p = make_bit_vector_internal (nargs);
1634
1635   for (elt = 0; elt < nargs; elt++)
1636     set_bit_vector_bit (p, elt, !ZEROP (args[elt]));
1637
1638   XSETBIT_VECTOR (bit_vector, p);
1639   return bit_vector;
1640 }
1641
1642 \f
1643 /**********************************************************************/
1644 /*                   Compiled-function allocation                     */
1645 /**********************************************************************/
1646
1647 DECLARE_FIXED_TYPE_ALLOC (compiled_function, struct Lisp_Compiled_Function);
1648 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
1649
1650 static Lisp_Object
1651 make_compiled_function (int make_pure)
1652 {
1653   struct Lisp_Compiled_Function *b;
1654   Lisp_Object new;
1655   size_t size = sizeof (struct Lisp_Compiled_Function);
1656
1657   if (make_pure && check_purespace (size))
1658     {
1659       b = (struct Lisp_Compiled_Function *) (PUREBEG + pure_bytes_used);
1660       set_lheader_implementation (&(b->lheader), lrecord_compiled_function);
1661 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
1662       b->lheader.pure = 1;
1663 #endif
1664       pure_bytes_used += size;
1665       bump_purestat (&purestat_bytecode, size);
1666     }
1667   else
1668     {
1669       ALLOCATE_FIXED_TYPE (compiled_function, struct Lisp_Compiled_Function,
1670                            b);
1671       set_lheader_implementation (&(b->lheader), lrecord_compiled_function);
1672     }
1673   b->maxdepth = 0;
1674   b->flags.documentationp = 0;
1675   b->flags.interactivep = 0;
1676   b->flags.domainp = 0; /* I18N3 */
1677   b->bytecodes = Qzero;
1678   b->constants = Qzero;
1679   b->arglist = Qnil;
1680   b->doc_and_interactive = Qnil;
1681 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1682   b->annotated = Qnil;
1683 #endif
1684   XSETCOMPILED_FUNCTION (new, b);
1685   return new;
1686 }
1687
1688 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
1689 Return a new compiled-function object.
1690 Usage: (arglist instructions constants stack-size
1691         &optional doc-string interactive-spec)
1692 Note that, unlike all other emacs-lisp functions, calling this with five
1693 arguments is NOT the same as calling it with six arguments, the last of
1694 which is nil.  If the INTERACTIVE arg is specified as nil, then that means
1695 that this function was defined with `(interactive)'.  If the arg is not
1696 specified, then that means the function is not interactive.
1697 This is terrible behavior which is retained for compatibility with old
1698 `.elc' files which expected these semantics.
1699 */
1700        (int nargs, Lisp_Object *args))
1701 {
1702 /*   In a non-insane world this function would have this arglist...
1703      (arglist, instructions, constants, stack_size, doc_string, interactive)
1704      Lisp_Object arglist, instructions, constants, stack_size, doc_string,
1705         interactive;
1706  */
1707   Lisp_Object arglist      = args[0];
1708   Lisp_Object instructions = args[1];
1709   Lisp_Object constants    = args[2];
1710   Lisp_Object stack_size   = args[3];
1711   Lisp_Object doc_string   = (nargs > 4) ? args[4] : Qnil;
1712   Lisp_Object interactive  = (nargs > 5) ? args[5] : Qunbound;
1713   /* Don't purecopy the doc references in instructions because it's
1714      wasteful; they will get fixed up later.
1715
1716      #### If something goes wrong and they don't get fixed up,
1717      we're screwed, because pure stuff isn't marked and thus the
1718      cons references won't be marked and will get reused.
1719
1720      Note: there will be a window after the byte code is created and
1721      before the doc references are fixed up in which there will be
1722      impure objects inside a pure object, which apparently won't
1723      get marked, leading the trouble.  But during that entire window,
1724      the objects are sitting on Vload_force_doc_string_list, which
1725      is staticpro'd, so we're OK. */
1726   int purecopy_instructions = 1;
1727
1728   if (nargs > 6)
1729     return Fsignal (Qwrong_number_of_arguments,
1730                     list2 (intern ("make-byte-code"), make_int (nargs)));
1731
1732   CHECK_LIST (arglist);
1733   /* instructions is a string or a cons (string . int) for a
1734      lazy-loaded function. */
1735   if (CONSP (instructions))
1736     {
1737       CHECK_STRING (XCAR (instructions));
1738       CHECK_INT (XCDR (instructions));
1739       if (!NILP (constants))
1740         CHECK_VECTOR (constants);
1741       purecopy_instructions = 0;
1742     }
1743   else
1744     {
1745       CHECK_STRING (instructions);
1746       CHECK_VECTOR (constants);
1747     }
1748   CHECK_NATNUM (stack_size);
1749   /* doc_string may be nil, string, int, or a cons (string . int). */
1750
1751   /* interactive may be list or string (or unbound). */
1752
1753   if (purify_flag)
1754     {
1755       if (!purified (arglist))
1756         arglist = Fpurecopy (arglist);
1757       if (purecopy_instructions && !purified (instructions))
1758         instructions = Fpurecopy (instructions);
1759       if (!purified (doc_string))
1760         doc_string = Fpurecopy (doc_string);
1761       if (!purified (interactive) && !UNBOUNDP (interactive))
1762         interactive = Fpurecopy (interactive);
1763
1764       /* Statistics are kept differently for the constants */
1765       if (!purified (constants))
1766 #ifdef PURESTAT
1767         {
1768           int old = purecopying_for_bytecode;
1769           purecopying_for_bytecode = 1;
1770           constants = Fpurecopy (constants);
1771           purecopying_for_bytecode = old;
1772         }
1773 #else
1774         constants = Fpurecopy (constants);
1775 #endif /* PURESTAT */
1776
1777 #ifdef PURESTAT
1778       if (STRINGP (instructions))
1779         bump_purestat (&purestat_string_bytecodes, pure_sizeof (instructions));
1780       if (VECTORP (constants))
1781         bump_purestat (&purestat_vector_bytecode_constants,
1782                        pure_sizeof (constants));
1783       if (STRINGP (doc_string))
1784         /* These should be have been snagged by make-docfile... */
1785         bump_purestat (&purestat_string_documentation,
1786                        pure_sizeof (doc_string));
1787       if (STRINGP (interactive))
1788         bump_purestat (&purestat_string_interactive,
1789                        pure_sizeof (interactive));
1790 #endif /* PURESTAT */
1791     }
1792
1793   {
1794     int docp = !NILP (doc_string);
1795     int intp = !UNBOUNDP (interactive);
1796 #ifdef I18N3
1797     int domp = !NILP (Vfile_domain);
1798 #endif
1799     Lisp_Object val = make_compiled_function (purify_flag);
1800     struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (val);
1801     b->flags.documentationp = docp;
1802     b->flags.interactivep   = intp;
1803 #ifdef I18N3
1804     b->flags.domainp        = domp;
1805 #endif
1806     b->maxdepth  = XINT (stack_size);
1807     b->bytecodes = instructions;
1808     b->constants = constants;
1809     b->arglist   = arglist;
1810 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1811     if (!NILP (Vcurrent_compiled_function_annotation))
1812       b->annotated = Fpurecopy (Vcurrent_compiled_function_annotation);
1813     else if (!NILP (Vload_file_name_internal_the_purecopy))
1814       b->annotated = Vload_file_name_internal_the_purecopy;
1815     else if (!NILP (Vload_file_name_internal))
1816       {
1817         struct gcpro gcpro1;
1818         GCPRO1(val);            /* don't let val or b get reaped */
1819         Vload_file_name_internal_the_purecopy =
1820           Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
1821         b->annotated = Vload_file_name_internal_the_purecopy;
1822         UNGCPRO;
1823       }
1824 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
1825
1826 #ifdef I18N3
1827     if (docp && intp && domp)
1828       b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
1829                                 (doc_string,
1830                                  (((purify_flag) ? pure_cons : Fcons)
1831                                   (interactive, Vfile_domain))));
1832     else if (docp && domp)
1833       b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
1834                                 (doc_string, Vfile_domain));
1835     else if (intp && domp)
1836       b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
1837                                 (interactive, Vfile_domain));
1838     else
1839 #endif
1840     if (docp && intp)
1841       b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
1842                                 (doc_string, interactive));
1843     else if (intp)
1844       b->doc_and_interactive = interactive;
1845 #ifdef I18N3
1846     else if (domp)
1847       b->doc_and_interactive = Vfile_domain;
1848 #endif
1849     else
1850       b->doc_and_interactive = doc_string;
1851
1852     return val;
1853   }
1854 }
1855
1856 \f
1857 /**********************************************************************/
1858 /*                          Symbol allocation                         */
1859 /**********************************************************************/
1860
1861 DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol);
1862 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
1863
1864 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /*
1865 Return a newly allocated uninterned symbol whose name is NAME.
1866 Its value and function definition are void, and its property list is nil.
1867 */
1868        (str))
1869 {
1870   Lisp_Object val;
1871   struct Lisp_Symbol *p;
1872
1873   CHECK_STRING (str);
1874
1875   ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p);
1876 #ifdef LRECORD_SYMBOL
1877   set_lheader_implementation (&(p->lheader), lrecord_symbol);
1878 #endif
1879   p->name = XSTRING (str);
1880   p->plist = Qnil;
1881   p->value = Qunbound;
1882   p->function = Qunbound;
1883   p->obarray = Qnil;
1884   symbol_next (p) = 0;
1885   XSETSYMBOL (val, p);
1886   return val;
1887 }
1888
1889 \f
1890 /**********************************************************************/
1891 /*                         Extent allocation                          */
1892 /**********************************************************************/
1893
1894 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
1895 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
1896
1897 struct extent *
1898 allocate_extent (void)
1899 {
1900   struct extent *e;
1901
1902   ALLOCATE_FIXED_TYPE (extent, struct extent, e);
1903   /* xzero (*e); */
1904   set_lheader_implementation (&(e->lheader), lrecord_extent);
1905   extent_object (e) = Qnil;
1906   set_extent_start (e, -1);
1907   set_extent_end (e, -1);
1908   e->plist = Qnil;
1909
1910   xzero (e->flags);
1911
1912   extent_face (e) = Qnil;
1913   e->flags.end_open = 1;  /* default is for endpoints to behave like markers */
1914   e->flags.detachable = 1;
1915
1916   return e;
1917 }
1918
1919 \f
1920 /**********************************************************************/
1921 /*                         Event allocation                           */
1922 /**********************************************************************/
1923
1924 DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event);
1925 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
1926
1927 Lisp_Object
1928 allocate_event (void)
1929 {
1930   Lisp_Object val;
1931   struct Lisp_Event *e;
1932
1933   ALLOCATE_FIXED_TYPE (event, struct Lisp_Event, e);
1934   set_lheader_implementation (&(e->lheader), lrecord_event);
1935
1936   XSETEVENT (val, e);
1937   return val;
1938 }
1939
1940 \f
1941 /**********************************************************************/
1942 /*                       Marker allocation                            */
1943 /**********************************************************************/
1944
1945 DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker);
1946 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
1947
1948 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /*
1949 Return a new marker which does not point at any place.
1950 */
1951        ())
1952 {
1953   Lisp_Object val;
1954   struct Lisp_Marker *p;
1955
1956   ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1957   set_lheader_implementation (&(p->lheader), lrecord_marker);
1958   p->buffer = 0;
1959   p->memind = 0;
1960   marker_next (p) = 0;
1961   marker_prev (p) = 0;
1962   p->insertion_type = 0;
1963   XSETMARKER (val, p);
1964   return val;
1965 }
1966
1967 Lisp_Object
1968 noseeum_make_marker (void)
1969 {
1970   Lisp_Object val;
1971   struct Lisp_Marker *p;
1972
1973   NOSEEUM_ALLOCATE_FIXED_TYPE (marker, struct Lisp_Marker, p);
1974   set_lheader_implementation (&(p->lheader), lrecord_marker);
1975   p->buffer = 0;
1976   p->memind = 0;
1977   marker_next (p) = 0;
1978   marker_prev (p) = 0;
1979   p->insertion_type = 0;
1980   XSETMARKER (val, p);
1981   return val;
1982 }
1983
1984 \f
1985 /**********************************************************************/
1986 /*                        String allocation                           */
1987 /**********************************************************************/
1988
1989 /* The data for "short" strings generally resides inside of structs of type
1990    string_chars_block. The Lisp_String structure is allocated just like any
1991    other Lisp object (except for vectors), and these are freelisted when
1992    they get garbage collected. The data for short strings get compacted,
1993    but the data for large strings do not.
1994
1995    Previously Lisp_String structures were relocated, but this caused a lot
1996    of bus-errors because the C code didn't include enough GCPRO's for
1997    strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
1998    that the reference would get relocated).
1999
2000    This new method makes things somewhat bigger, but it is MUCH safer.  */
2001
2002 DECLARE_FIXED_TYPE_ALLOC (string, struct Lisp_String);
2003 /* strings are used and freed quite often */
2004 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
2005 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
2006
2007 #ifdef LRECORD_STRING
2008 static Lisp_Object
2009 mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object))
2010 {
2011   struct Lisp_String *ptr = XSTRING (obj);
2012
2013   if (GC_CONSP (ptr->plist) && GC_EXTENT_INFOP (XCAR (ptr->plist)))
2014     flush_cached_extent_info (XCAR (ptr->plist));
2015   return ptr->plist;
2016 }
2017
2018 static int
2019 string_equal (Lisp_Object o1, Lisp_Object o2, int depth)
2020 {
2021   Bytecount len;
2022   return (((len = XSTRING_LENGTH (o1)) == XSTRING_LENGTH (o2)) &&
2023           !memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len));
2024 }
2025
2026 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
2027                                      mark_string, print_string,
2028                                      /*
2029                                       * No `finalize', or `hash' methods.
2030                                       * internal_hash already knows how
2031                                       * to hash strings and finalization
2032                                       * is done with the
2033                                       * ADDITIONAL_FREE_string macro,
2034                                       * which is the standard way to do
2035                                       * finalization when using
2036                                       * SWEEP_FIXED_TYPE_BLOCK().
2037                                       */
2038                                      0, string_equal, 0,
2039                                      struct Lisp_String);
2040 #endif /* LRECORD_STRING */
2041
2042 /* String blocks contain this many useful bytes. */
2043 #define STRING_CHARS_BLOCK_SIZE                                 \
2044 ((Bytecount) (8192 - MALLOC_OVERHEAD -                          \
2045               ((2 * sizeof (struct string_chars_block *))       \
2046                + sizeof (EMACS_INT))))
2047 /* Block header for small strings. */
2048 struct string_chars_block
2049 {
2050   EMACS_INT pos;
2051   struct string_chars_block *next;
2052   struct string_chars_block *prev;
2053   /* Contents of string_chars_block->string_chars are interleaved
2054      string_chars structures (see below) and the actual string data */
2055   unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
2056 };
2057
2058 struct string_chars_block *first_string_chars_block;
2059 struct string_chars_block *current_string_chars_block;
2060
2061 /* If SIZE is the length of a string, this returns how many bytes
2062  *  the string occupies in string_chars_block->string_chars
2063  *  (including alignment padding).
2064  */
2065 #define STRING_FULLSIZE(s) \
2066    ALIGN_SIZE (((s) + 1 + sizeof (struct Lisp_String *)),\
2067                ALIGNOF (struct Lisp_String *))
2068
2069 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
2070 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
2071
2072 #define CHARS_TO_STRING_CHAR(x) \
2073   ((struct string_chars *) \
2074    (((char *) (x)) - (slot_offset (struct string_chars, chars[0]))))
2075
2076
2077 struct string_chars
2078 {
2079   struct Lisp_String *string;
2080   unsigned char chars[1];
2081 };
2082
2083 struct unused_string_chars
2084 {
2085   struct Lisp_String *string;
2086   EMACS_INT fullsize;
2087 };
2088
2089 static void
2090 init_string_chars_alloc (void)
2091 {
2092   first_string_chars_block = xnew (struct string_chars_block);
2093   first_string_chars_block->prev = 0;
2094   first_string_chars_block->next = 0;
2095   first_string_chars_block->pos = 0;
2096   current_string_chars_block = first_string_chars_block;
2097 }
2098
2099 static struct string_chars *
2100 allocate_string_chars_struct (struct Lisp_String *string_it_goes_with,
2101                               EMACS_INT fullsize)
2102 {
2103   struct string_chars *s_chars;
2104
2105   /* Allocate the string's actual data */
2106   if (BIG_STRING_FULLSIZE_P (fullsize))
2107     {
2108       s_chars = (struct string_chars *) xmalloc (fullsize);
2109     }
2110   else if (fullsize <=
2111            (countof (current_string_chars_block->string_chars)
2112             - current_string_chars_block->pos))
2113     {
2114       /* This string can fit in the current string chars block */
2115       s_chars = (struct string_chars *)
2116         (current_string_chars_block->string_chars
2117          + current_string_chars_block->pos);
2118       current_string_chars_block->pos += fullsize;
2119     }
2120   else
2121     {
2122       /* Make a new current string chars block */
2123       struct string_chars_block *new = xnew (struct string_chars_block);
2124
2125       current_string_chars_block->next = new;
2126       new->prev = current_string_chars_block;
2127       new->next = 0;
2128       current_string_chars_block = new;
2129       new->pos = fullsize;
2130       s_chars = (struct string_chars *)
2131         current_string_chars_block->string_chars;
2132     }
2133
2134   s_chars->string = string_it_goes_with;
2135
2136   INCREMENT_CONS_COUNTER (fullsize, "string chars");
2137
2138   return s_chars;
2139 }
2140
2141 Lisp_Object
2142 make_uninit_string (Bytecount length)
2143 {
2144   struct Lisp_String *s;
2145   struct string_chars *s_chars;
2146   EMACS_INT fullsize = STRING_FULLSIZE (length);
2147   Lisp_Object val;
2148
2149   if ((length < 0) || (fullsize <= 0))
2150     abort ();
2151
2152   /* Allocate the string header */
2153   ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
2154 #ifdef LRECORD_STRING
2155   set_lheader_implementation (&(s->lheader), lrecord_string);
2156 #endif
2157
2158   s_chars = allocate_string_chars_struct (s, fullsize);
2159
2160   set_string_data (s, &(s_chars->chars[0]));
2161   set_string_length (s, length);
2162   s->plist = Qnil;
2163
2164   set_string_byte (s, length, 0);
2165
2166   XSETSTRING (val, s);
2167   return val;
2168 }
2169
2170 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2171 static void verify_string_chars_integrity (void);
2172 #endif
2173
2174 /* Resize the string S so that DELTA bytes can be inserted starting
2175    at POS.  If DELTA < 0, it means deletion starting at POS.  If
2176    POS < 0, resize the string but don't copy any characters.  Use
2177    this if you're planning on completely overwriting the string.
2178 */
2179
2180 void
2181 resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta)
2182 {
2183 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2184   verify_string_chars_integrity ();
2185 #endif
2186
2187 #ifdef ERROR_CHECK_BUFPOS
2188   if (pos >= 0)
2189     {
2190       assert (pos <= string_length (s));
2191       if (delta < 0)
2192         assert (pos + (-delta) <= string_length (s));
2193     }
2194   else
2195     {
2196       if (delta < 0)
2197         assert ((-delta) <= string_length (s));
2198     }
2199 #endif /* ERROR_CHECK_BUFPOS */
2200
2201   if (pos >= 0 && delta < 0)
2202   /* If DELTA < 0, the functions below will delete the characters
2203      before POS.  We want to delete characters *after* POS, however,
2204      so convert this to the appropriate form. */
2205     pos += -delta;
2206
2207   if (delta == 0)
2208     /* simplest case: no size change. */
2209     return;
2210   else
2211     {
2212       Bytecount oldfullsize = STRING_FULLSIZE (string_length (s));
2213       Bytecount newfullsize = STRING_FULLSIZE (string_length (s) + delta);
2214
2215       if (oldfullsize == newfullsize)
2216         {
2217           /* next simplest case; size change but the necessary
2218              allocation size won't change (up or down; code somewhere
2219              depends on there not being any unused allocation space,
2220              modulo any alignment constraints). */
2221           if (pos >= 0)
2222             {
2223               Bufbyte *addroff = pos + string_data (s);
2224
2225               memmove (addroff + delta, addroff,
2226                        /* +1 due to zero-termination. */
2227                        string_length (s) + 1 - pos);
2228             }
2229         }
2230       else if (BIG_STRING_FULLSIZE_P (oldfullsize) &&
2231                BIG_STRING_FULLSIZE_P (newfullsize))
2232         {
2233           /* next simplest case; the string is big enough to be malloc()ed
2234              itself, so we just realloc.
2235
2236              It's important not to let the string get below the threshold
2237              for making big strings and still remain malloc()ed; if that
2238              were the case, repeated calls to this function on the same
2239              string could result in memory leakage. */
2240           set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
2241                                                     newfullsize));
2242           if (pos >= 0)
2243             {
2244               Bufbyte *addroff = pos + string_data (s);
2245
2246               memmove (addroff + delta, addroff,
2247                        /* +1 due to zero-termination. */
2248                        string_length (s) + 1 - pos);
2249             }
2250         }
2251       else
2252         {
2253           /* worst case.  We make a new string_chars struct and copy
2254              the string's data into it, inserting/deleting the delta
2255              in the process.  The old string data will either get
2256              freed by us (if it was malloc()ed) or will be reclaimed
2257              in the normal course of garbage collection. */
2258           struct string_chars *s_chars =
2259             allocate_string_chars_struct (s, newfullsize);
2260           Bufbyte *new_addr = &(s_chars->chars[0]);
2261           Bufbyte *old_addr = string_data (s);
2262           if (pos >= 0)
2263             {
2264               memcpy (new_addr, old_addr, pos);
2265               memcpy (new_addr + pos + delta, old_addr + pos,
2266                       string_length (s) + 1 - pos);
2267             }
2268           set_string_data (s, new_addr);
2269           if (BIG_STRING_FULLSIZE_P (oldfullsize))
2270             xfree (old_addr);
2271           else
2272             {
2273               /* We need to mark this chunk of the string_chars_block
2274                  as unused so that compact_string_chars() doesn't
2275                  freak. */
2276               struct string_chars *old_s_chars =
2277                 (struct string_chars *) ((char *) old_addr -
2278                                          sizeof (struct Lisp_String *));
2279               /* Sanity check to make sure we aren't hosed by strange
2280                  alignment/padding. */
2281               assert (old_s_chars->string == s);
2282               MARK_STRUCT_AS_FREE (old_s_chars);
2283               ((struct unused_string_chars *) old_s_chars)->fullsize =
2284                 oldfullsize;
2285             }
2286         }
2287
2288       set_string_length (s, string_length (s) + delta);
2289       /* If pos < 0, the string won't be zero-terminated.
2290          Terminate now just to make sure. */
2291       string_data (s)[string_length (s)] = '\0';
2292
2293       if (pos >= 0)
2294         {
2295           Lisp_Object string;
2296
2297           XSETSTRING (string, s);
2298           /* We also have to adjust all of the extent indices after the
2299              place we did the change.  We say "pos - 1" because
2300              adjust_extents() is exclusive of the starting position
2301              passed to it. */
2302           adjust_extents (string, pos - 1, string_length (s),
2303                           delta);
2304         }
2305     }
2306
2307 #ifdef VERIFY_STRING_CHARS_INTEGRITY
2308   verify_string_chars_integrity ();
2309 #endif
2310 }
2311
2312 #ifdef MULE
2313
2314 void
2315 set_string_char (struct Lisp_String *s, Charcount i, Emchar c)
2316 {
2317   Bytecount oldlen, newlen;
2318   Bufbyte newstr[MAX_EMCHAR_LEN];
2319   Bytecount bytoff = charcount_to_bytecount (string_data (s), i);
2320
2321   oldlen = charcount_to_bytecount (string_data (s) + bytoff, 1);
2322   newlen = set_charptr_emchar (newstr, c);
2323
2324   if (oldlen != newlen)
2325     resize_string (s, bytoff, newlen - oldlen);
2326   /* Remember, string_data (s) might have changed so we can't cache it. */
2327   memcpy (string_data (s) + bytoff, newstr, newlen);
2328 }
2329
2330 #endif /* MULE */
2331
2332 DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
2333 Return a new string of length LENGTH, with each character being INIT.
2334 LENGTH must be an integer and INIT must be a character.
2335 */
2336        (length, init))
2337 {
2338   Lisp_Object val;
2339
2340   CHECK_NATNUM (length);
2341   CHECK_CHAR_COERCE_INT (init);
2342   {
2343     Bufbyte str[MAX_EMCHAR_LEN];
2344     int len = set_charptr_emchar (str, XCHAR (init));
2345
2346     val = make_uninit_string (len * XINT (length));
2347     if (len == 1)
2348       /* Optimize the single-byte case */
2349       memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
2350     else
2351       {
2352         int i, j, k;
2353         Bufbyte *ptr = XSTRING_DATA (val);
2354
2355         k = 0;
2356         for (i = 0; i < XINT (length); i++)
2357           for (j = 0; j < len; j++)
2358             ptr[k++] = str[j];
2359       }
2360   }
2361   return val;
2362 }
2363
2364 DEFUN ("string", Fstring, 0, MANY, 0, /*
2365 Concatenate all the argument characters and make the result a string.
2366 */
2367        (int nargs, Lisp_Object *args))
2368 {
2369   Bufbyte *storage = alloca_array (Bufbyte, nargs * MAX_EMCHAR_LEN);
2370   Bufbyte *p = storage;
2371
2372   for (; nargs; nargs--, args++)
2373     {
2374       Lisp_Object lisp_char = *args;
2375       CHECK_CHAR_COERCE_INT (lisp_char);
2376       p += set_charptr_emchar (p, XCHAR (lisp_char));
2377     }
2378   return make_string (storage, p - storage);
2379 }
2380
2381 /* Take some raw memory, which MUST already be in internal format,
2382    and package it up into a Lisp string. */
2383 Lisp_Object
2384 make_string (CONST Bufbyte *contents, Bytecount length)
2385 {
2386   Lisp_Object val;
2387
2388   /* Make sure we find out about bad make_string's when they happen */
2389 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
2390   bytecount_to_charcount (contents, length); /* Just for the assertions */
2391 #endif
2392
2393   val = make_uninit_string (length);
2394   memcpy (XSTRING_DATA (val), contents, length);
2395   return val;
2396 }
2397
2398 /* Take some raw memory, encoded in some external data format,
2399    and convert it into a Lisp string. */
2400 Lisp_Object
2401 make_ext_string (CONST Extbyte *contents, EMACS_INT length,
2402                  enum external_data_format fmt)
2403 {
2404   Bufbyte *intstr;
2405   Bytecount intlen;
2406
2407   GET_CHARPTR_INT_DATA_ALLOCA (contents, length, fmt, intstr, intlen);
2408   return make_string (intstr, intlen);
2409 }
2410
2411 Lisp_Object
2412 build_string (CONST char *str)
2413 {
2414   /* Some strlen's crash and burn if passed null. */
2415   return make_string ((CONST Bufbyte *) str, (str ? strlen(str) : 0));
2416 }
2417
2418 Lisp_Object
2419 build_ext_string (CONST char *str, enum external_data_format fmt)
2420 {
2421   /* Some strlen's crash and burn if passed null. */
2422   return make_ext_string ((CONST Extbyte *) str, (str ? strlen(str) : 0), fmt);
2423 }
2424
2425 Lisp_Object
2426 build_translated_string (CONST char *str)
2427 {
2428   return build_string (GETTEXT (str));
2429 }
2430
2431 \f
2432 /************************************************************************/
2433 /*                           lcrecord lists                             */
2434 /************************************************************************/
2435
2436 /* Lcrecord lists are used to manage the allocation of particular
2437    sorts of lcrecords, to avoid calling alloc_lcrecord() (and thus
2438    malloc() and garbage-collection junk) as much as possible.
2439    It is similar to the Blocktype class.
2440
2441    It works like this:
2442
2443    1) Create an lcrecord-list object using make_lcrecord_list().
2444       This is often done at initialization.  Remember to staticpro
2445       this object!  The arguments to make_lcrecord_list() are the
2446       same as would be passed to alloc_lcrecord().
2447    2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
2448       and pass the lcrecord-list earlier created.
2449    3) When done with the lcrecord, call free_managed_lcrecord().
2450       The standard freeing caveats apply: ** make sure there are no
2451       pointers to the object anywhere! **
2452    4) Calling free_managed_lcrecord() is just like kissing the
2453       lcrecord goodbye as if it were garbage-collected.  This means:
2454       -- the contents of the freed lcrecord are undefined, and the
2455          contents of something produced by allocate_managed_lcrecord()
2456          are undefined, just like for alloc_lcrecord().
2457       -- the mark method for the lcrecord's type will *NEVER* be called
2458          on freed lcrecords.
2459       -- the finalize method for the lcrecord's type will be called
2460          at the time that free_managed_lcrecord() is called.
2461
2462    */
2463
2464 static Lisp_Object
2465 mark_lcrecord_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
2466 {
2467   struct lcrecord_list *list = XLCRECORD_LIST (obj);
2468   Lisp_Object chain = list->free;
2469
2470   while (!NILP (chain))
2471     {
2472       struct lrecord_header *lheader = XRECORD_LHEADER (chain);
2473       struct free_lcrecord_header *free_header =
2474         (struct free_lcrecord_header *) lheader;
2475
2476 #ifdef ERROR_CHECK_GC
2477       CONST struct lrecord_implementation *implementation
2478         = LHEADER_IMPLEMENTATION(lheader);
2479
2480       /* There should be no other pointers to the free list. */
2481       assert (!MARKED_RECORD_HEADER_P (lheader));
2482       /* Only lcrecords should be here. */
2483       assert (!implementation->basic_p);
2484       /* Only free lcrecords should be here. */
2485       assert (free_header->lcheader.free);
2486       /* The type of the lcrecord must be right. */
2487       assert (implementation == list->implementation);
2488       /* So must the size. */
2489       assert (implementation->static_size == 0
2490               || implementation->static_size == list->size);
2491 #endif /* ERROR_CHECK_GC */
2492
2493       MARK_RECORD_HEADER (lheader);
2494       chain = free_header->chain;
2495     }
2496
2497   return Qnil;
2498 }
2499
2500 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
2501                                mark_lcrecord_list, internal_object_printer,
2502                                0, 0, 0, struct lcrecord_list);
2503 Lisp_Object
2504 make_lcrecord_list (size_t size,
2505                     CONST struct lrecord_implementation *implementation)
2506 {
2507   struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
2508                                                  lrecord_lcrecord_list);
2509   Lisp_Object val;
2510
2511   p->implementation = implementation;
2512   p->size = size;
2513   p->free = Qnil;
2514   XSETLCRECORD_LIST (val, p);
2515   return val;
2516 }
2517
2518 Lisp_Object
2519 allocate_managed_lcrecord (Lisp_Object lcrecord_list)
2520 {
2521   struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2522   if (!NILP (list->free))
2523     {
2524       Lisp_Object val = list->free;
2525       struct free_lcrecord_header *free_header =
2526         (struct free_lcrecord_header *) XPNTR (val);
2527
2528 #ifdef ERROR_CHECK_GC
2529       struct lrecord_header *lheader =
2530         (struct lrecord_header *) free_header;
2531       CONST struct lrecord_implementation *implementation
2532         = LHEADER_IMPLEMENTATION (lheader);
2533
2534       /* There should be no other pointers to the free list. */
2535       assert (!MARKED_RECORD_HEADER_P (lheader));
2536       /* Only lcrecords should be here. */
2537       assert (!implementation->basic_p);
2538       /* Only free lcrecords should be here. */
2539       assert (free_header->lcheader.free);
2540       /* The type of the lcrecord must be right. */
2541       assert (implementation == list->implementation);
2542       /* So must the size. */
2543       assert (implementation->static_size == 0
2544               || implementation->static_size == list->size);
2545 #endif /* ERROR_CHECK_GC */
2546       list->free = free_header->chain;
2547       free_header->lcheader.free = 0;
2548       return val;
2549     }
2550   else
2551     {
2552       Lisp_Object val;
2553
2554       XSETOBJ (val, Lisp_Type_Record,
2555                alloc_lcrecord (list->size, list->implementation));
2556       return val;
2557     }
2558 }
2559
2560 void
2561 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord)
2562 {
2563   struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
2564   struct free_lcrecord_header *free_header =
2565     (struct free_lcrecord_header *) XPNTR (lcrecord);
2566   struct lrecord_header *lheader =
2567     (struct lrecord_header *) free_header;
2568   CONST struct lrecord_implementation *implementation
2569     = LHEADER_IMPLEMENTATION (lheader);
2570
2571 #ifdef ERROR_CHECK_GC
2572   /* Make sure the size is correct.  This will catch, for example,
2573      putting a window configuration on the wrong free list. */
2574   if (implementation->size_in_bytes_method)
2575     assert (((implementation->size_in_bytes_method) (lheader))
2576             == list->size);
2577   else
2578     assert (implementation->static_size == list->size);
2579 #endif /* ERROR_CHECK_GC */
2580
2581   if (implementation->finalizer)
2582     ((implementation->finalizer) (lheader, 0));
2583   free_header->chain = list->free;
2584   free_header->lcheader.free = 1;
2585   list->free = lcrecord;
2586 }
2587
2588 \f
2589 /**********************************************************************/
2590 /*                 Purity of essence, peace on earth                  */
2591 /**********************************************************************/
2592
2593 static int symbols_initialized;
2594
2595 Lisp_Object
2596 make_pure_string (CONST Bufbyte *data, Bytecount length,
2597                   Lisp_Object plist, int no_need_to_copy_data)
2598 {
2599   Lisp_Object new;
2600   struct Lisp_String *s;
2601   size_t size = sizeof (struct Lisp_String) +
2602     (no_need_to_copy_data ? 0 : (length + 1)); /* + 1 for terminating 0 */
2603   size = ALIGN_SIZE (size, ALIGNOF (Lisp_Object));
2604
2605   if (symbols_initialized && !pure_lossage)
2606     {
2607       /* Try to share some names.  Saves a few kbytes. */
2608       Lisp_Object tem = oblookup (Vobarray, data, length);
2609       if (SYMBOLP (tem))
2610         {
2611           s = XSYMBOL (tem)->name;
2612           if (!PURIFIED (s)) abort ();
2613           XSETSTRING (new, s);
2614           return new;
2615         }
2616     }
2617
2618   if (!check_purespace (size))
2619     return make_string (data, length);
2620
2621   s = (struct Lisp_String *) (PUREBEG + pure_bytes_used);
2622 #ifdef LRECORD_STRING
2623   set_lheader_implementation (&(s->lheader), lrecord_string);
2624 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2625   s->lheader.pure = 1;
2626 #endif
2627 #endif
2628   set_string_length (s, length);
2629   if (no_need_to_copy_data)
2630     {
2631       set_string_data (s, (Bufbyte *) data);
2632     }
2633   else
2634     {
2635       set_string_data (s, (Bufbyte *) s + sizeof (struct Lisp_String));
2636       memcpy (string_data (s), data, length);
2637       set_string_byte (s, length, 0);
2638     }
2639   s->plist = Qnil;
2640   pure_bytes_used += size;
2641
2642 #ifdef PURESTAT
2643   bump_purestat (&purestat_string_all, size);
2644   if (purecopying_for_bytecode)
2645     bump_purestat (&purestat_string_other_function, size);
2646 #endif /* PURESTAT */
2647
2648   /* Do this after the official "completion" of the purecopying. */
2649   s->plist = Fpurecopy (plist);
2650
2651   XSETSTRING (new, s);
2652   return new;
2653 }
2654
2655
2656 Lisp_Object
2657 make_pure_pname (CONST Bufbyte *data, Bytecount length,
2658                  int no_need_to_copy_data)
2659 {
2660   Lisp_Object name = make_pure_string (data, length, Qnil,
2661                                        no_need_to_copy_data);
2662   bump_purestat (&purestat_string_pname, pure_sizeof (name));
2663
2664   /* We've made (at least) Qnil now, and Vobarray will soon be set up. */
2665   symbols_initialized = 1;
2666
2667   return name;
2668 }
2669
2670
2671 Lisp_Object
2672 pure_cons (Lisp_Object car, Lisp_Object cdr)
2673 {
2674   Lisp_Object new;
2675   struct Lisp_Cons *c;
2676
2677   if (!check_purespace (sizeof (struct Lisp_Cons)))
2678     return Fcons (Fpurecopy (car), Fpurecopy (cdr));
2679
2680   c = (struct Lisp_Cons *) (PUREBEG + pure_bytes_used);
2681 #ifdef LRECORD_CONS
2682   set_lheader_implementation (&(c->lheader), lrecord_cons);
2683 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2684   c->lheader.pure = 1;
2685 #endif
2686 #endif
2687   pure_bytes_used += sizeof (struct Lisp_Cons);
2688   bump_purestat (&purestat_cons, sizeof (struct Lisp_Cons));
2689
2690   c->car = Fpurecopy (car);
2691   c->cdr = Fpurecopy (cdr);
2692   XSETCONS (new, c);
2693   return new;
2694 }
2695
2696 Lisp_Object
2697 pure_list (int nargs, Lisp_Object *args)
2698 {
2699   Lisp_Object val = Qnil;
2700
2701   for (--nargs; nargs >= 0; nargs--)
2702     val = pure_cons (args[nargs], val);
2703
2704   return val;
2705 }
2706
2707 #ifdef LISP_FLOAT_TYPE
2708
2709 static Lisp_Object
2710 make_pure_float (double num)
2711 {
2712   struct Lisp_Float *f;
2713   Lisp_Object val;
2714
2715   /* Make sure that PUREBEG + pure_bytes_used is aligned on at least a sizeof
2716      (double) boundary.  Some architectures (like the sparc) require
2717      this, and I suspect that floats are rare enough that it's no
2718      tragedy for those that don't. */
2719   {
2720 #if defined (__GNUC__) && (__GNUC__ >= 2)
2721     /* In gcc, we can directly ask what the alignment constraints of a
2722        structure are, but in general, that's not possible...  Arrgh!!
2723      */
2724     int alignment = __alignof (struct Lisp_Float);
2725 #else /* !GNUC */
2726     /* Best guess is to make the `double' slot be aligned to the size
2727        of double (which is probably 8 bytes).  This assumes that it's
2728        ok to align the beginning of the structure to the same boundary
2729        that the `double' slot in it is supposed to be aligned to; this
2730        should be ok because presumably there is padding in the layout
2731        of the struct to account for this.
2732      */
2733     int alignment = sizeof (float_data (f));
2734 #endif /* !GNUC */
2735     char *p = ((char *) PUREBEG + pure_bytes_used);
2736
2737     p = (char *) (((EMACS_UINT) p + alignment - 1) & - alignment);
2738     pure_bytes_used = p - (char *) PUREBEG;
2739   }
2740
2741   if (!check_purespace (sizeof (struct Lisp_Float)))
2742     return make_float (num);
2743
2744   f = (struct Lisp_Float *) (PUREBEG + pure_bytes_used);
2745   set_lheader_implementation (&(f->lheader), lrecord_float);
2746 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2747   f->lheader.pure = 1;
2748 #endif
2749   pure_bytes_used += sizeof (struct Lisp_Float);
2750   bump_purestat (&purestat_float, sizeof (struct Lisp_Float));
2751
2752   float_data (f) = num;
2753   XSETFLOAT (val, f);
2754   return val;
2755 }
2756
2757 #endif /* LISP_FLOAT_TYPE */
2758
2759 Lisp_Object
2760 make_pure_vector (size_t len, Lisp_Object init)
2761 {
2762   Lisp_Object new;
2763   struct Lisp_Vector *v;
2764   size_t size = (sizeof (struct Lisp_Vector)
2765                  + (len - 1) * sizeof (Lisp_Object));
2766
2767   init = Fpurecopy (init);
2768
2769   if (!check_purespace (size))
2770     return make_vector (len, init);
2771
2772   v = (struct Lisp_Vector *) (PUREBEG + pure_bytes_used);
2773 #ifdef LRECORD_VECTOR
2774   set_lheader_implementation (&(v->header.lheader), lrecord_vector);
2775 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
2776   v->header.lheader.pure = 1;
2777 #endif
2778 #endif
2779   pure_bytes_used += size;
2780   bump_purestat (&purestat_vector_all, size);
2781
2782   v->size = len;
2783
2784   for (size = 0; size < len; size++)
2785     v->contents[size] = init;
2786
2787   XSETVECTOR (new, v);
2788   return new;
2789 }
2790
2791 #if 0
2792 /* Presently unused */
2793 void *
2794 alloc_pure_lrecord (int size, struct lrecord_implementation *implementation)
2795 {
2796   struct lrecord_header *header = (void *) (PUREBEG + pure_bytes_used);
2797
2798   if (pure_bytes_used + size > get_PURESIZE())
2799     pure_storage_exhausted ();
2800
2801   set_lheader_implementation (header, implementation);
2802   header->next = 0;
2803   return header;
2804 }
2805 #endif /* unused */
2806
2807
2808 \f
2809 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
2810 Make a copy of OBJECT in pure storage.
2811 Recursively copies contents of vectors and cons cells.
2812 Does not copy symbols.
2813 */
2814        (obj))
2815 {
2816   int i;
2817   if (!purify_flag)
2818     return obj;
2819
2820   if (!POINTER_TYPE_P (XTYPE (obj))
2821       || PURIFIED (XPNTR (obj))
2822       /* happens when bootstrapping Qnil */
2823       || EQ (obj, Qnull_pointer))
2824     return obj;
2825
2826   switch (XTYPE (obj))
2827     {
2828 #ifndef LRECORD_CONS
2829     case Lisp_Type_Cons:
2830       return pure_cons (XCAR (obj), XCDR (obj));
2831 #endif
2832
2833 #ifndef LRECORD_STRING
2834     case Lisp_Type_String:
2835       return make_pure_string (XSTRING_DATA (obj),
2836                                XSTRING_LENGTH (obj),
2837                                XSTRING (obj)->plist,
2838                                0);
2839 #endif /* ! LRECORD_STRING */
2840
2841 #ifndef LRECORD_VECTOR
2842     case Lisp_Type_Vector:
2843       {
2844         struct Lisp_Vector *o = XVECTOR (obj);
2845         Lisp_Object new = make_pure_vector (vector_length (o), Qnil);
2846         for (i = 0; i < vector_length (o); i++)
2847           XVECTOR_DATA (new)[i] = Fpurecopy (o->contents[i]);
2848         return new;
2849       }
2850 #endif /* !LRECORD_VECTOR */
2851
2852     default:
2853       {
2854         if (COMPILED_FUNCTIONP (obj))
2855           {
2856             struct Lisp_Compiled_Function *o = XCOMPILED_FUNCTION (obj);
2857             Lisp_Object new = make_compiled_function (1);
2858             /* How on earth could this code have worked before?  -sb */
2859             struct Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (new);
2860             n->flags = o->flags;
2861             n->bytecodes = Fpurecopy (o->bytecodes);
2862             n->constants = Fpurecopy (o->constants);
2863             n->arglist = Fpurecopy (o->arglist);
2864             n->doc_and_interactive = Fpurecopy (o->doc_and_interactive);
2865             n->maxdepth = o->maxdepth;
2866             return new;
2867           }
2868 #ifdef LRECORD_CONS
2869       else if (CONSP (obj))
2870         return pure_cons (XCAR (obj), XCDR (obj));
2871 #endif /* LRECORD_CONS */
2872 #ifdef LRECORD_VECTOR
2873       else if (VECTORP (obj))
2874         {
2875           struct Lisp_Vector *o = XVECTOR (obj);
2876           Lisp_Object new = make_pure_vector (vector_length (o), Qnil);
2877           for (i = 0; i < vector_length (o); i++)
2878             XVECTOR_DATA (new)[i] = Fpurecopy (o->contents[i]);
2879           return new;
2880         }
2881 #endif /* LRECORD_VECTOR */
2882 #ifdef LRECORD_STRING
2883       else if (STRINGP (obj))
2884         {
2885           return make_pure_string (XSTRING_DATA (obj),
2886                                    XSTRING_LENGTH (obj),
2887                                    XSTRING (obj)->plist,
2888                                    0);
2889         }
2890 #endif /* LRECORD_STRING */
2891 #ifdef LISP_FLOAT_TYPE
2892         else if (FLOATP (obj))
2893           return make_pure_float (float_data (XFLOAT (obj)));
2894 #endif /* LISP_FLOAT_TYPE */
2895         else if (SYMBOLP (obj))
2896           {
2897             /*
2898              * Symbols can't be made pure (and thus read-only),
2899              * because assigning to their function, value or plist
2900              * slots would produced a SEGV in the dumped XEmacs.  So
2901              * we previously would just return the symbol unchanged.
2902              *
2903              * But purified aggregate objects like lists and vectors
2904              * can contain uninterned symbols.  If there are no
2905              * other non-pure references to the symbol, then the
2906              * symbol is not protected from garbage collection
2907              * because the collector does not mark the contents of
2908              * purified objects.  So to protect the symbols, an impure
2909              * reference has to be kept for each uninterned symbol
2910              * that is referenced by a pure object.  All such
2911              * symbols are stored in the hashtable pointed to by
2912              * Vpure_uninterned_symbol_table, which is itself
2913              * staticpro'd.
2914              */
2915             if (!NILP (XSYMBOL (obj)->obarray))
2916               return obj;
2917             Fputhash (obj, Qnil, Vpure_uninterned_symbol_table);
2918             return obj;
2919           }
2920         else
2921           signal_simple_error ("Can't purecopy %S", obj);
2922       }
2923     }
2924   return obj;
2925 }
2926
2927
2928 \f
2929 static void
2930 puresize_adjust_h (size_t puresize)
2931 {
2932   FILE *stream = fopen ("puresize-adjust.h", "w");
2933
2934   if (stream == NULL)
2935     report_file_error ("Opening puresize adjustment file",
2936                        Fcons (build_string ("puresize-adjust.h"), Qnil));
2937
2938   fprintf (stream,
2939            "/*\tDo not edit this file!\n"
2940            "\tAutomatically generated by XEmacs */\n"
2941            "# define PURESIZE_ADJUSTMENT (%ld)\n",
2942            (long) (puresize - RAW_PURESIZE));
2943   fclose (stream);
2944 }
2945
2946 void
2947 report_pure_usage (int report_impurities,
2948                    int die_if_pure_storage_exceeded)
2949 {
2950   int rc = 0;
2951
2952   if (pure_lossage)
2953     {
2954       message ("\n****\tPure Lisp storage exhausted!\n"
2955                "\tPurespace usage: %ld of %ld\n"
2956                "****",
2957                (long) get_PURESIZE() + pure_lossage,
2958                (long) get_PURESIZE());
2959       if (die_if_pure_storage_exceeded)
2960         {
2961           puresize_adjust_h (get_PURESIZE() + pure_lossage);
2962 #ifdef HEAP_IN_DATA
2963           sheap_adjust_h();
2964 #endif
2965           rc = -1;
2966         }
2967     }
2968   else
2969     {
2970       size_t lost = (get_PURESIZE() - pure_bytes_used) / 1024;
2971       char buf[200];
2972       /* extern Lisp_Object Vemacs_beta_version; */
2973       /* This used to be NILP(Vemacs_beta_version) ? 512 : 4; */
2974 #ifndef PURESIZE_SLOP
2975 #define PURESIZE_SLOP 0
2976 #endif
2977       size_t slop = PURESIZE_SLOP;
2978
2979       sprintf (buf, "Purespace usage: %ld of %ld (%d%%",
2980                (long) pure_bytes_used,
2981                (long) get_PURESIZE(),
2982                (int) (pure_bytes_used / (get_PURESIZE() / 100.0) + 0.5));
2983       if (lost > ((slop ? slop : 1) / 1024)) {
2984         sprintf (buf + strlen (buf), " -- %ldk wasted", (long)lost);
2985         if (die_if_pure_storage_exceeded) {
2986           puresize_adjust_h (pure_bytes_used + slop);
2987 #ifdef HEAP_IN_DATA
2988           sheap_adjust_h();
2989 #endif
2990           rc = -1;
2991         }
2992       }
2993
2994       strcat (buf, ").");
2995       message ("%s", buf);
2996     }
2997
2998 #ifdef PURESTAT
2999
3000   purestat_vector_other.nbytes =
3001     purestat_vector_all.nbytes -
3002     purestat_vector_bytecode_constants.nbytes;
3003   purestat_vector_other.nobjects =
3004     purestat_vector_all.nobjects -
3005     purestat_vector_bytecode_constants.nobjects;
3006
3007   purestat_string_other.nbytes =
3008     purestat_string_all.nbytes -
3009     (purestat_string_pname.nbytes +
3010      purestat_string_bytecodes.nbytes +
3011      purestat_string_interactive.nbytes +
3012      purestat_string_documentation.nbytes +
3013 #ifdef I18N3
3014      purestat_string_domain.nbytes +
3015 #endif
3016      purestat_string_other_function.nbytes);
3017
3018   purestat_string_other.nobjects =
3019     purestat_string_all.nobjects -
3020     (purestat_string_pname.nobjects +
3021      purestat_string_bytecodes.nobjects +
3022      purestat_string_interactive.nobjects +
3023      purestat_string_documentation.nobjects +
3024 #ifdef I18N3
3025      purestat_string_domain.nobjects +
3026 #endif
3027      purestat_string_other_function.nobjects);
3028
3029   message ("   %-26s Total    Bytes", "");
3030
3031   {
3032     int j;
3033
3034     for (j = 0; j < countof (purestats); j++)
3035       if (!purestats[j])
3036         clear_message ();
3037       else
3038         {
3039           char buf [100];
3040           sprintf(buf, "%s:", purestats[j]->name);
3041           message ("   %-26s %5d  %7d  %2d%%",
3042                    buf,
3043                    purestats[j]->nobjects,
3044                    purestats[j]->nbytes,
3045                    (int) (purestats[j]->nbytes / (pure_bytes_used / 100.0) + 0.5));
3046         }
3047   }
3048 #endif /* PURESTAT */
3049
3050
3051   if (report_impurities)
3052     {
3053       Lisp_Object tem = Felt (Fgarbage_collect (), make_int (5));
3054       struct gcpro gcpro1;
3055       GCPRO1 (tem);
3056       message ("\nImpurities:");
3057       while (!NILP (tem))
3058         {
3059           if (CONSP (tem) && SYMBOLP (Fcar (tem)) && CONSP (Fcdr (tem)))
3060             {
3061               int total = XINT (Fcar (Fcdr (tem)));
3062               if (total > 0)
3063                 {
3064                   char buf [100];
3065                   char *s = buf;
3066                   memcpy (buf, string_data (XSYMBOL (Fcar (tem))->name),
3067                           string_length (XSYMBOL (Fcar (tem))->name) + 1);
3068                   while (*s++) if (*s == '-') *s = ' ';
3069                   s--; *s++ = ':'; *s = 0;
3070                   message ("   %-33s %6d", buf, total);
3071                 }
3072               tem = Fcdr (Fcdr (tem));
3073             }
3074           else                  /* WTF?! */
3075             {
3076               Fprin1 (tem, Qexternal_debugging_output);
3077               tem = Qnil;
3078             }
3079         }
3080       UNGCPRO;
3081       garbage_collect_1 ();         /* GC garbage_collect's garbage */
3082     }
3083   clear_message ();
3084
3085   if (rc < 0) {
3086     unlink("SATISFIED");
3087     fatal ("Pure size adjusted, Don't Panic!  I will restart the `make'");
3088   } else if (pure_lossage && die_if_pure_storage_exceeded) {
3089     fatal ("Pure storage exhausted");
3090   }
3091 }
3092
3093 \f
3094 /**********************************************************************/
3095 /*                            staticpro                               */
3096 /**********************************************************************/
3097
3098 struct gcpro *gcprolist;
3099
3100 /* 415 used Mly 29-Jun-93 */
3101 /* 1327 used slb 28-Feb-98 */
3102 #ifdef HAVE_SHLIB
3103 #define NSTATICS 4000
3104 #else
3105 #define NSTATICS 2000
3106 #endif
3107 /* Not "static" because of linker lossage on some systems */
3108 Lisp_Object *staticvec[NSTATICS]
3109      /* Force it into data space! */
3110      = {0};
3111 static int staticidx;
3112
3113 /* Put an entry in staticvec, pointing at the variable whose address is given
3114  */
3115 void
3116 staticpro (Lisp_Object *varaddress)
3117 {
3118   if (staticidx >= countof (staticvec))
3119     /* #### This is now a dubious abort() since this routine may be called */
3120     /* by Lisp attempting to load a DLL. */
3121     abort ();
3122   staticvec[staticidx++] = varaddress;
3123 }
3124
3125 \f
3126 /* Mark reference to a Lisp_Object.  If the object referred to has not been
3127    seen yet, recursively mark all the references contained in it. */
3128
3129 static void
3130 mark_object (Lisp_Object obj)
3131 {
3132  tail_recurse:
3133
3134   if (EQ (obj, Qnull_pointer))
3135     return;
3136   if (!POINTER_TYPE_P (XGCTYPE (obj)))
3137     return;
3138   if (PURIFIED (XPNTR (obj)))
3139     return;
3140   switch (XGCTYPE (obj))
3141     {
3142 #ifndef LRECORD_CONS
3143     case Lisp_Type_Cons:
3144       {
3145         struct Lisp_Cons *ptr = XCONS (obj);
3146         if (CONS_MARKED_P (ptr))
3147           break;
3148         MARK_CONS (ptr);
3149         /* If the cdr is nil, tail-recurse on the car.  */
3150         if (NILP (ptr->cdr))
3151           {
3152             obj = ptr->car;
3153           }
3154         else
3155           {
3156             mark_object (ptr->car);
3157             obj = ptr->cdr;
3158           }
3159         goto tail_recurse;
3160       }
3161 #endif
3162
3163     case Lisp_Type_Record:
3164     /* case Lisp_Symbol_Value_Magic: */
3165       {
3166         struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3167         CONST struct lrecord_implementation *implementation
3168           = LHEADER_IMPLEMENTATION (lheader);
3169
3170         if (! MARKED_RECORD_HEADER_P (lheader) &&
3171             ! UNMARKABLE_RECORD_HEADER_P (lheader))
3172           {
3173             MARK_RECORD_HEADER (lheader);
3174 #ifdef ERROR_CHECK_GC
3175             if (!implementation->basic_p)
3176               assert (! ((struct lcrecord_header *) lheader)->free);
3177 #endif
3178             if (implementation->marker != 0)
3179               {
3180                 obj = ((implementation->marker) (obj, mark_object));
3181                 if (!NILP (obj)) goto tail_recurse;
3182               }
3183           }
3184       }
3185       break;
3186
3187 #ifndef LRECORD_STRING
3188     case Lisp_Type_String:
3189       {
3190         struct Lisp_String *ptr = XSTRING (obj);
3191
3192         if (!XMARKBIT (ptr->plist))
3193           {
3194             if (CONSP (ptr->plist) &&
3195                 EXTENT_INFOP (XCAR (ptr->plist)))
3196               flush_cached_extent_info (XCAR (ptr->plist));
3197             XMARK (ptr->plist);
3198             obj = ptr->plist;
3199             goto tail_recurse;
3200           }
3201       }
3202       break;
3203 #endif /* ! LRECORD_STRING */
3204
3205 #ifndef LRECORD_VECTOR
3206     case Lisp_Type_Vector:
3207       {
3208         struct Lisp_Vector *ptr = XVECTOR (obj);
3209         int len = vector_length (ptr);
3210         int i;
3211
3212         if (len < 0)
3213           break;                /* Already marked */
3214         ptr->size = -1 - len;   /* Else mark it */
3215         for (i = 0; i < len - 1; i++) /* and then mark its elements */
3216           mark_object (ptr->contents[i]);
3217         if (len > 0)
3218         {
3219           obj = ptr->contents[len - 1];
3220           goto tail_recurse;
3221         }
3222       }
3223       break;
3224 #endif /* !LRECORD_VECTOR */
3225
3226 #ifndef LRECORD_SYMBOL
3227     case Lisp_Type_Symbol:
3228       {
3229         struct Lisp_Symbol *sym = XSYMBOL (obj);
3230
3231         while (!XMARKBIT (sym->plist))
3232           {
3233             XMARK (sym->plist);
3234             mark_object (sym->value);
3235             mark_object (sym->function);
3236             {
3237               /*
3238                * symbol->name is a struct Lisp_String *, not a
3239                * Lisp_Object.  Fix it up and pass to mark_object.
3240                */
3241               Lisp_Object symname;
3242               XSETSTRING(symname, sym->name);
3243               mark_object(symname);
3244             }
3245             if (!symbol_next (sym))
3246               {
3247                 obj = sym->plist;
3248                 goto tail_recurse;
3249               }
3250             mark_object (sym->plist);
3251             /* Mark the rest of the symbols in the hash-chain */
3252             sym = symbol_next (sym);
3253           }
3254       }
3255       break;
3256 #endif /* !LRECORD_SYMBOL */
3257
3258     default:
3259       abort ();
3260     }
3261 }
3262
3263 /* mark all of the conses in a list and mark the final cdr; but
3264    DO NOT mark the cars.
3265
3266    Use only for internal lists!  There should never be other pointers
3267    to the cons cells, because if so, the cars will remain unmarked
3268    even when they maybe should be marked. */
3269 void
3270 mark_conses_in_list (Lisp_Object obj)
3271 {
3272   Lisp_Object rest;
3273
3274   for (rest = obj; CONSP (rest); rest = XCDR (rest))
3275     {
3276       if (CONS_MARKED_P (XCONS (rest)))
3277         return;
3278       MARK_CONS (XCONS (rest));
3279     }
3280
3281   mark_object (rest);
3282 }
3283
3284 \f
3285 #ifdef PURESTAT
3286 /* Simpler than mark-object, because pure structure can't
3287    have any circularities */
3288
3289 #if 0 /* unused */
3290 static int idiot_c_doesnt_have_closures;
3291 static void
3292 idiot_c (Lisp_Object obj)
3293 {
3294   idiot_c_doesnt_have_closures += pure_sizeof (obj, 1);
3295 }
3296 #endif /* unused */
3297
3298 static size_t
3299 pure_string_sizeof (Lisp_Object obj)
3300 {
3301   struct Lisp_String *ptr = XSTRING (obj);
3302
3303   if (string_data (ptr) != (Bufbyte *) ptr + sizeof (*ptr))
3304     {
3305       /* string-data not allocated contiguously.
3306          Probably (better be!!) a pointer constant "C" data. */
3307       return sizeof (*ptr);
3308     }
3309   else
3310     {
3311       size_t size = sizeof (*ptr) + string_length (ptr) + 1;
3312       size = ALIGN_SIZE (size, sizeof (Lisp_Object));
3313       return size;
3314     }
3315 }
3316
3317 /* recurse arg isn't actually used */
3318 static size_t
3319 pure_sizeof (Lisp_Object obj /*, int recurse */)
3320 {
3321   size_t total = 0;
3322
3323   /*tail_recurse: */
3324   if (!POINTER_TYPE_P (XTYPE (obj))
3325       || !PURIFIED (XPNTR (obj)))
3326     return total;
3327
3328   /* symbol's sizes are accounted for separately */
3329   if (SYMBOLP (obj))
3330     return total;
3331
3332   switch (XTYPE (obj))
3333     {
3334
3335 #ifndef LRECORD_STRING
3336     case Lisp_Type_String:
3337       total += pure_string_sizeof (obj);
3338       break;
3339 #endif /* ! LRECORD_STRING */
3340
3341 #ifndef LRECORD_VECTOR
3342     case Lisp_Type_Vector:
3343       {
3344         struct Lisp_Vector *ptr = XVECTOR (obj);
3345         int len = vector_length (ptr);
3346
3347         total += (sizeof (struct Lisp_Vector)
3348                   + (len - 1) * sizeof (Lisp_Object));
3349 #if 0 /* unused */
3350         if (!recurse)
3351           break;
3352         {
3353           int i;
3354           for (i = 0; i < len - 1; i++)
3355             total += pure_sizeof (ptr->contents[i], 1);
3356         }
3357         if (len > 0)
3358           {
3359             obj = ptr->contents[len - 1];
3360             goto tail_recurse;
3361           }
3362 #endif /* unused */
3363       }
3364       break;
3365 #endif /* !LRECORD_VECTOR */
3366
3367     case Lisp_Type_Record:
3368       {
3369         struct lrecord_header *lheader = XRECORD_LHEADER (obj);
3370         CONST struct lrecord_implementation *implementation
3371           = LHEADER_IMPLEMENTATION (lheader);
3372
3373 #ifdef LRECORD_STRING
3374         if (STRINGP (obj))
3375           total += pure_string_sizeof (obj);
3376         else
3377 #endif
3378         if (implementation->size_in_bytes_method)
3379           total += ((implementation->size_in_bytes_method) (lheader));
3380         else
3381           total += implementation->static_size;
3382
3383 #if 0 /* unused */
3384         if (!recurse)
3385           break;
3386
3387         if (implementation->marker != 0)
3388           {
3389             int old = idiot_c_doesnt_have_closures;
3390
3391             idiot_c_doesnt_have_closures = 0;
3392             obj = ((implementation->marker) (obj, idiot_c));
3393             total += idiot_c_doesnt_have_closures;
3394             idiot_c_doesnt_have_closures = old;
3395
3396             if (!NILP (obj)) goto tail_recurse;
3397           }
3398 #endif /* unused */
3399       }
3400       break;
3401
3402 #ifndef LRECORD_CONS
3403     case Lisp_Type_Cons:
3404       {
3405         struct Lisp_Cons *ptr = XCONS (obj);
3406         total += sizeof (*ptr);
3407 #if 0 /* unused */
3408         if (!recurse)
3409           break;
3410         /* If the cdr is nil, tail-recurse on the car.  */
3411         if (NILP (ptr->cdr))
3412           {
3413             obj = ptr->car;
3414           }
3415         else
3416           {
3417             total += pure_sizeof (ptr->car, 1);
3418             obj = ptr->cdr;
3419           }
3420         goto tail_recurse;
3421 #endif /* unused */
3422       }
3423       break;
3424 #endif
3425
3426       /* Others can't be purified */
3427     default:
3428       abort ();
3429     }
3430   return total;
3431 }
3432 #endif /* PURESTAT */
3433
3434
3435
3436 \f
3437 /* Find all structures not marked, and free them. */
3438
3439 #ifndef LRECORD_VECTOR
3440 static int gc_count_num_vector_used, gc_count_vector_total_size;
3441 static int gc_count_vector_storage;
3442 #endif
3443 static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
3444 static int gc_count_bit_vector_storage;
3445 static int gc_count_num_short_string_in_use;
3446 static int gc_count_string_total_size;
3447 static int gc_count_short_string_total_size;
3448
3449 /* static int gc_count_total_records_used, gc_count_records_total_size; */
3450
3451 \f
3452 /* This will be used more extensively In The Future */
3453 static int last_lrecord_type_index_assigned;
3454
3455 CONST struct lrecord_implementation *lrecord_implementations_table[128];
3456 #define max_lrecord_type (countof (lrecord_implementations_table) - 1)
3457
3458 int
3459 lrecord_type_index (CONST struct lrecord_implementation *implementation)
3460 {
3461   int type_index = *(implementation->lrecord_type_index);
3462   /* Have to do this circuitous validation test because of problems
3463      dumping out initialized variables (ie can't set xxx_type_index to -1
3464      because that would make xxx_type_index read-only in a dumped emacs. */
3465   if (type_index < 0 || type_index > max_lrecord_type
3466       || lrecord_implementations_table[type_index] != implementation)
3467     {
3468       if (last_lrecord_type_index_assigned == max_lrecord_type)
3469         abort ();
3470       type_index = ++last_lrecord_type_index_assigned;
3471       lrecord_implementations_table[type_index] = implementation;
3472       *(implementation->lrecord_type_index) = type_index;
3473     }
3474   return type_index;
3475 }
3476
3477 /* stats on lcrecords in use - kinda kludgy */
3478
3479 static struct
3480 {
3481   int instances_in_use;
3482   int bytes_in_use;
3483   int instances_freed;
3484   int bytes_freed;
3485   int instances_on_free_list;
3486 } lcrecord_stats [countof (lrecord_implementations_table)];
3487
3488
3489 static void
3490 reset_lcrecord_stats (void)
3491 {
3492   int i;
3493   for (i = 0; i < countof (lcrecord_stats); i++)
3494     {
3495       lcrecord_stats[i].instances_in_use = 0;
3496       lcrecord_stats[i].bytes_in_use = 0;
3497       lcrecord_stats[i].instances_freed = 0;
3498       lcrecord_stats[i].bytes_freed = 0;
3499       lcrecord_stats[i].instances_on_free_list = 0;
3500     }
3501 }
3502
3503 static void
3504 tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p)
3505 {
3506   CONST struct lrecord_implementation *implementation =
3507     LHEADER_IMPLEMENTATION (h);
3508   int type_index = lrecord_type_index (implementation);
3509
3510   if (((struct lcrecord_header *) h)->free)
3511     {
3512       assert (!free_p);
3513       lcrecord_stats[type_index].instances_on_free_list++;
3514     }
3515   else
3516     {
3517       size_t sz = (implementation->size_in_bytes_method
3518                    ? ((implementation->size_in_bytes_method) (h))
3519                    : implementation->static_size);
3520
3521       if (free_p)
3522         {
3523           lcrecord_stats[type_index].instances_freed++;
3524           lcrecord_stats[type_index].bytes_freed += sz;
3525         }
3526       else
3527         {
3528           lcrecord_stats[type_index].instances_in_use++;
3529           lcrecord_stats[type_index].bytes_in_use += sz;
3530         }
3531     }
3532 }
3533
3534 \f
3535 /* Free all unmarked records */
3536 static void
3537 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
3538 {
3539   struct lcrecord_header *header;
3540   int num_used = 0;
3541   /* int total_size = 0; */
3542   reset_lcrecord_stats ();
3543
3544   /* First go through and call all the finalize methods.
3545      Then go through and free the objects.  There used to
3546      be only one loop here, with the call to the finalizer
3547      occurring directly before the xfree() below.  That
3548      is marginally faster but much less safe -- if the
3549      finalize method for an object needs to reference any
3550      other objects contained within it (and many do),
3551      we could easily be screwed by having already freed that
3552      other object. */
3553
3554   for (header = *prev; header; header = header->next)
3555     {
3556       struct lrecord_header *h = &(header->lheader);
3557       if (!MARKED_RECORD_HEADER_P (h) && ! (header->free))
3558         {
3559           if (LHEADER_IMPLEMENTATION (h)->finalizer)
3560             ((LHEADER_IMPLEMENTATION (h)->finalizer) (h, 0));
3561         }
3562     }
3563
3564   for (header = *prev; header; )
3565     {
3566       struct lrecord_header *h = &(header->lheader);
3567       if (MARKED_RECORD_HEADER_P (h))
3568         {
3569           UNMARK_RECORD_HEADER (h);
3570           num_used++;
3571           /* total_size += ((n->implementation->size_in_bytes) (h));*/
3572           prev = &(header->next);
3573           header = *prev;
3574           tick_lcrecord_stats (h, 0);
3575         }
3576       else
3577         {
3578           struct lcrecord_header *next = header->next;
3579           *prev = next;
3580           tick_lcrecord_stats (h, 1);
3581           /* used to call finalizer right here. */
3582           xfree (header);
3583           header = next;
3584         }
3585     }
3586   *used = num_used;
3587   /* *total = total_size; */
3588 }
3589
3590 #ifndef LRECORD_VECTOR
3591
3592 static void
3593 sweep_vectors_1 (Lisp_Object *prev,
3594                  int *used, int *total, int *storage)
3595 {
3596   Lisp_Object vector;
3597   int num_used = 0;
3598   int total_size = 0;
3599   int total_storage = 0;
3600
3601   for (vector = *prev; VECTORP (vector); )
3602     {
3603       struct Lisp_Vector *v = XVECTOR (vector);
3604       int len = v->size;
3605       if (len < 0)     /* marked */
3606         {
3607           len = - (len + 1);
3608           v->size = len;
3609           total_size += len;
3610           total_storage += (MALLOC_OVERHEAD
3611                             + sizeof (struct Lisp_Vector)
3612                             + (len - 1 + 1) * sizeof (Lisp_Object));
3613           num_used++;
3614           prev = &(vector_next (v));
3615           vector = *prev;
3616         }
3617       else
3618         {
3619           Lisp_Object next = vector_next (v);
3620           *prev = next;
3621           xfree (v);
3622           vector = next;
3623         }
3624     }
3625   *used = num_used;
3626   *total = total_size;
3627   *storage = total_storage;
3628 }
3629
3630 #endif /* ! LRECORD_VECTOR */
3631
3632 static void
3633 sweep_bit_vectors_1 (Lisp_Object *prev,
3634                      int *used, int *total, int *storage)
3635 {
3636   Lisp_Object bit_vector;
3637   int num_used = 0;
3638   int total_size = 0;
3639   int total_storage = 0;
3640
3641   /* BIT_VECTORP fails because the objects are marked, which changes
3642      their implementation */
3643   for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
3644     {
3645       struct Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
3646       int len = v->size;
3647       if (MARKED_RECORD_P (bit_vector))
3648         {
3649           UNMARK_RECORD_HEADER (&(v->lheader));
3650           total_size += len;
3651           total_storage += (MALLOC_OVERHEAD
3652                             + sizeof (struct Lisp_Bit_Vector)
3653                             + (BIT_VECTOR_LONG_STORAGE (len) - 1)
3654                             * sizeof (long));
3655           num_used++;
3656           prev = &(bit_vector_next (v));
3657           bit_vector = *prev;
3658         }
3659       else
3660         {
3661           Lisp_Object next = bit_vector_next (v);
3662           *prev = next;
3663           xfree (v);
3664           bit_vector = next;
3665         }
3666     }
3667   *used = num_used;
3668   *total = total_size;
3669   *storage = total_storage;
3670 }
3671
3672 /* And the Lord said: Thou shalt use the `c-backslash-region' command
3673    to make macros prettier. */
3674
3675 #ifdef ERROR_CHECK_GC
3676
3677 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type)                      \
3678 do {                                                                    \
3679   struct typename##_block *_frob_current;                               \
3680   struct typename##_block **_frob_prev;                                 \
3681   int _frob_limit;                                                      \
3682   int num_free = 0, num_used = 0;                                       \
3683                                                                         \
3684   for (_frob_prev = &current_##typename##_block,                        \
3685        _frob_current = current_##typename##_block,                      \
3686        _frob_limit = current_##typename##_block_index;                  \
3687        _frob_current;                                                   \
3688        )                                                                \
3689     {                                                                   \
3690       int _frob_iii;                                                    \
3691                                                                         \
3692       for (_frob_iii = 0; _frob_iii < _frob_limit; _frob_iii++)         \
3693         {                                                               \
3694           obj_type *_frob_victim = &(_frob_current->block[_frob_iii]);  \
3695                                                                         \
3696           if (FREE_STRUCT_P (_frob_victim))                             \
3697             {                                                           \
3698               num_free++;                                               \
3699             }                                                           \
3700           else if (!MARKED_##typename##_P (_frob_victim))               \
3701             {                                                           \
3702               num_free++;                                               \
3703               FREE_FIXED_TYPE (typename, obj_type, _frob_victim);       \
3704             }                                                           \
3705           else                                                          \
3706             {                                                           \
3707               num_used++;                                               \
3708               UNMARK_##typename (_frob_victim);                         \
3709             }                                                           \
3710         }                                                               \
3711       _frob_prev = &(_frob_current->prev);                              \
3712       _frob_current = _frob_current->prev;                              \
3713       _frob_limit = countof (current_##typename##_block->block);        \
3714     }                                                                   \
3715                                                                         \
3716   gc_count_num_##typename##_in_use = num_used;                          \
3717   gc_count_num_##typename##_freelist = num_free;                        \
3718 } while (0)
3719
3720 #else /* !ERROR_CHECK_GC */
3721
3722 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type)                            \
3723 do {                                                                          \
3724   struct typename##_block *_frob_current;                                     \
3725   struct typename##_block **_frob_prev;                                       \
3726   int _frob_limit;                                                            \
3727   int num_free = 0, num_used = 0;                                             \
3728                                                                               \
3729   typename##_free_list = 0;                                                   \
3730                                                                               \
3731   for (_frob_prev = &current_##typename##_block,                              \
3732        _frob_current = current_##typename##_block,                            \
3733        _frob_limit = current_##typename##_block_index;                        \
3734        _frob_current;                                                         \
3735        )                                                                      \
3736     {                                                                         \
3737       int _frob_iii;                                                          \
3738       int _frob_empty = 1;                                                    \
3739       obj_type *_frob_old_free_list = typename##_free_list;                   \
3740                                                                               \
3741       for (_frob_iii = 0; _frob_iii < _frob_limit; _frob_iii++)               \
3742         {                                                                     \
3743           obj_type *_frob_victim = &(_frob_current->block[_frob_iii]);        \
3744                                                                               \
3745           if (FREE_STRUCT_P (_frob_victim))                                   \
3746             {                                                                 \
3747               num_free++;                                                     \
3748               PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, _frob_victim); \
3749             }                                                                 \
3750           else if (!MARKED_##typename##_P (_frob_victim))                     \
3751             {                                                                 \
3752               num_free++;                                                     \
3753               FREE_FIXED_TYPE (typename, obj_type, _frob_victim);             \
3754             }                                                                 \
3755           else                                                                \
3756             {                                                                 \
3757               _frob_empty = 0;                                                \
3758               num_used++;                                                     \
3759               UNMARK_##typename (_frob_victim);                               \
3760             }                                                                 \
3761         }                                                                     \
3762       if (!_frob_empty)                                                       \
3763         {                                                                     \
3764           _frob_prev = &(_frob_current->prev);                                \
3765           _frob_current = _frob_current->prev;                                \
3766         }                                                                     \
3767       else if (_frob_current == current_##typename##_block                    \
3768                && !_frob_current->prev)                                       \
3769         {                                                                     \
3770           /* No real point in freeing sole allocation block */                \
3771           break;                                                              \
3772         }                                                                     \
3773       else                                                                    \
3774         {                                                                     \
3775           struct typename##_block *_frob_victim_block = _frob_current;        \
3776           if (_frob_victim_block == current_##typename##_block)               \
3777             current_##typename##_block_index                                  \
3778               = countof (current_##typename##_block->block);                  \
3779           _frob_current = _frob_current->prev;                                \
3780           {                                                                   \
3781             *_frob_prev = _frob_current;                                      \
3782             xfree (_frob_victim_block);                                       \
3783             /* Restore free list to what it was before victim was swept */    \
3784             typename##_free_list = _frob_old_free_list;                       \
3785             num_free -= _frob_limit;                                          \
3786           }                                                                   \
3787         }                                                                     \
3788       _frob_limit = countof (current_##typename##_block->block);              \
3789     }                                                                         \
3790                                                                               \
3791   gc_count_num_##typename##_in_use = num_used;                                \
3792   gc_count_num_##typename##_freelist = num_free;                              \
3793 } while (0)
3794
3795 #endif /* !ERROR_CHECK_GC */
3796
3797 \f
3798
3799
3800 static void
3801 sweep_conses (void)
3802 {
3803 #ifndef LRECORD_CONS
3804 # define MARKED_cons_P(ptr) XMARKBIT ((ptr)->car)
3805 # define UNMARK_cons(ptr) do { XUNMARK ((ptr)->car); } while (0)
3806 #else /* LRECORD_CONS */
3807 # define MARKED_cons_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3808 # define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3809 #endif /* LRECORD_CONS */
3810 #define ADDITIONAL_FREE_cons(ptr)
3811
3812   SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons);
3813 }
3814
3815 /* Explicitly free a cons cell.  */
3816 void
3817 free_cons (struct Lisp_Cons *ptr)
3818 {
3819 #ifdef ERROR_CHECK_GC
3820   /* If the CAR is not an int, then it will be a pointer, which will
3821      always be four-byte aligned.  If this cons cell has already been
3822      placed on the free list, however, its car will probably contain
3823      a chain pointer to the next cons on the list, which has cleverly
3824      had all its 0's and 1's inverted.  This allows for a quick
3825      check to make sure we're not freeing something already freed. */
3826   if (POINTER_TYPE_P (XTYPE (ptr->car)))
3827     ASSERT_VALID_POINTER (XPNTR (ptr->car));
3828 #endif /* ERROR_CHECK_GC */
3829
3830 #ifndef ALLOC_NO_POOLS
3831   FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, struct Lisp_Cons, ptr);
3832 #endif /* ALLOC_NO_POOLS */
3833 }
3834
3835 /* explicitly free a list.  You **must make sure** that you have
3836    created all the cons cells that make up this list and that there
3837    are no pointers to any of these cons cells anywhere else.  If there
3838    are, you will lose. */
3839
3840 void
3841 free_list (Lisp_Object list)
3842 {
3843   Lisp_Object rest, next;
3844
3845   for (rest = list; !NILP (rest); rest = next)
3846     {
3847       next = XCDR (rest);
3848       free_cons (XCONS (rest));
3849     }
3850 }
3851
3852 /* explicitly free an alist.  You **must make sure** that you have
3853    created all the cons cells that make up this alist and that there
3854    are no pointers to any of these cons cells anywhere else.  If there
3855    are, you will lose. */
3856
3857 void
3858 free_alist (Lisp_Object alist)
3859 {
3860   Lisp_Object rest, next;
3861
3862   for (rest = alist; !NILP (rest); rest = next)
3863     {
3864       next = XCDR (rest);
3865       free_cons (XCONS (XCAR (rest)));
3866       free_cons (XCONS (rest));
3867     }
3868 }
3869
3870 static void
3871 sweep_compiled_functions (void)
3872 {
3873 #define MARKED_compiled_function_P(ptr) \
3874   MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3875 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3876 #define ADDITIONAL_FREE_compiled_function(ptr)
3877
3878   SWEEP_FIXED_TYPE_BLOCK (compiled_function, struct Lisp_Compiled_Function);
3879 }
3880
3881
3882 #ifdef LISP_FLOAT_TYPE
3883 static void
3884 sweep_floats (void)
3885 {
3886 #define MARKED_float_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3887 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3888 #define ADDITIONAL_FREE_float(ptr)
3889
3890   SWEEP_FIXED_TYPE_BLOCK (float, struct Lisp_Float);
3891 }
3892 #endif /* LISP_FLOAT_TYPE */
3893
3894 static void
3895 sweep_symbols (void)
3896 {
3897 #ifndef LRECORD_SYMBOL
3898 # define MARKED_symbol_P(ptr) XMARKBIT ((ptr)->plist)
3899 # define UNMARK_symbol(ptr) do { XUNMARK ((ptr)->plist); } while (0)
3900 #else
3901 # define MARKED_symbol_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3902 # define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3903 #endif /* !LRECORD_SYMBOL */
3904 #define ADDITIONAL_FREE_symbol(ptr)
3905
3906   SWEEP_FIXED_TYPE_BLOCK (symbol, struct Lisp_Symbol);
3907 }
3908
3909 static void
3910 sweep_extents (void)
3911 {
3912 #define MARKED_extent_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3913 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3914 #define ADDITIONAL_FREE_extent(ptr)
3915
3916   SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
3917 }
3918
3919 static void
3920 sweep_events (void)
3921 {
3922 #define MARKED_event_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3923 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3924 #define ADDITIONAL_FREE_event(ptr)
3925
3926   SWEEP_FIXED_TYPE_BLOCK (event, struct Lisp_Event);
3927 }
3928
3929 static void
3930 sweep_markers (void)
3931 {
3932 #define MARKED_marker_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
3933 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
3934 #define ADDITIONAL_FREE_marker(ptr)                                     \
3935   do { Lisp_Object tem;                                                 \
3936        XSETMARKER (tem, ptr);                                           \
3937        unchain_marker (tem);                                            \
3938      } while (0)
3939
3940   SWEEP_FIXED_TYPE_BLOCK (marker, struct Lisp_Marker);
3941 }
3942
3943 /* Explicitly free a marker.  */
3944 void
3945 free_marker (struct Lisp_Marker *ptr)
3946 {
3947 #ifdef ERROR_CHECK_GC
3948   /* Perhaps this will catch freeing an already-freed marker. */
3949   Lisp_Object temmy;
3950   XSETMARKER (temmy, ptr);
3951   assert (GC_MARKERP (temmy));
3952 #endif /* ERROR_CHECK_GC */
3953
3954 #ifndef ALLOC_NO_POOLS
3955   FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr);
3956 #endif /* ALLOC_NO_POOLS */
3957 }
3958 \f
3959
3960 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
3961
3962 static void
3963 verify_string_chars_integrity (void)
3964 {
3965   struct string_chars_block *sb;
3966
3967   /* Scan each existing string block sequentially, string by string.  */
3968   for (sb = first_string_chars_block; sb; sb = sb->next)
3969     {
3970       int pos = 0;
3971       /* POS is the index of the next string in the block.  */
3972       while (pos < sb->pos)
3973         {
3974           struct string_chars *s_chars =
3975             (struct string_chars *) &(sb->string_chars[pos]);
3976           struct Lisp_String *string;
3977           int size;
3978           int fullsize;
3979
3980           /* If the string_chars struct is marked as free (i.e. the STRING
3981              pointer is 0xFFFFFFFF) then this is an unused chunk of string
3982              storage. (See below.) */
3983
3984           if (FREE_STRUCT_P (s_chars))
3985             {
3986               fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
3987               pos += fullsize;
3988               continue;
3989             }
3990
3991           string = s_chars->string;
3992           /* Must be 32-bit aligned. */
3993           assert ((((int) string) & 3) == 0);
3994
3995           size = string_length (string);
3996           fullsize = STRING_FULLSIZE (size);
3997
3998           assert (!BIG_STRING_FULLSIZE_P (fullsize));
3999           assert (string_data (string) == s_chars->chars);
4000           pos += fullsize;
4001         }
4002       assert (pos == sb->pos);
4003     }
4004 }
4005
4006 #endif /* MULE && ERROR_CHECK_GC */
4007
4008 /* Compactify string chars, relocating the reference to each --
4009    free any empty string_chars_block we see. */
4010 static void
4011 compact_string_chars (void)
4012 {
4013   struct string_chars_block *to_sb = first_string_chars_block;
4014   int to_pos = 0;
4015   struct string_chars_block *from_sb;
4016
4017   /* Scan each existing string block sequentially, string by string.  */
4018   for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
4019     {
4020       int from_pos = 0;
4021       /* FROM_POS is the index of the next string in the block.  */
4022       while (from_pos < from_sb->pos)
4023         {
4024           struct string_chars *from_s_chars =
4025             (struct string_chars *) &(from_sb->string_chars[from_pos]);
4026           struct string_chars *to_s_chars;
4027           struct Lisp_String *string;
4028           int size;
4029           int fullsize;
4030
4031           /* If the string_chars struct is marked as free (i.e. the STRING
4032              pointer is 0xFFFFFFFF) then this is an unused chunk of string
4033              storage.  This happens under Mule when a string's size changes
4034              in such a way that its fullsize changes. (Strings can change
4035              size because a different-length character can be substituted
4036              for another character.) In this case, after the bogus string
4037              pointer is the "fullsize" of this entry, i.e. how many bytes
4038              to skip. */
4039
4040           if (FREE_STRUCT_P (from_s_chars))
4041             {
4042               fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
4043               from_pos += fullsize;
4044               continue;
4045             }
4046
4047           string = from_s_chars->string;
4048           assert (!(FREE_STRUCT_P (string)));
4049
4050           size = string_length (string);
4051           fullsize = STRING_FULLSIZE (size);
4052
4053           if (BIG_STRING_FULLSIZE_P (fullsize))
4054             abort ();
4055
4056           /* Just skip it if it isn't marked.  */
4057 #ifdef LRECORD_STRING
4058           if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
4059 #else
4060           if (!XMARKBIT (string->plist))
4061 #endif
4062             {
4063               from_pos += fullsize;
4064               continue;
4065             }
4066
4067           /* If it won't fit in what's left of TO_SB, close TO_SB out
4068              and go on to the next string_chars_block.  We know that TO_SB
4069              cannot advance past FROM_SB here since FROM_SB is large enough
4070              to currently contain this string. */
4071           if ((to_pos + fullsize) > countof (to_sb->string_chars))
4072             {
4073               to_sb->pos = to_pos;
4074               to_sb = to_sb->next;
4075               to_pos = 0;
4076             }
4077
4078           /* Compute new address of this string
4079              and update TO_POS for the space being used.  */
4080           to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
4081
4082           /* Copy the string_chars to the new place.  */
4083           if (from_s_chars != to_s_chars)
4084             memmove (to_s_chars, from_s_chars, fullsize);
4085
4086           /* Relocate FROM_S_CHARS's reference */
4087           set_string_data (string, &(to_s_chars->chars[0]));
4088
4089           from_pos += fullsize;
4090           to_pos += fullsize;
4091         }
4092     }
4093
4094   /* Set current to the last string chars block still used and
4095      free any that follow. */
4096   {
4097     struct string_chars_block *victim;
4098
4099     for (victim = to_sb->next; victim; )
4100       {
4101         struct string_chars_block *next = victim->next;
4102         xfree (victim);
4103         victim = next;
4104       }
4105
4106     current_string_chars_block = to_sb;
4107     current_string_chars_block->pos = to_pos;
4108     current_string_chars_block->next = 0;
4109   }
4110 }
4111
4112 #if 1 /* Hack to debug missing purecopy's */
4113 static int debug_string_purity;
4114
4115 static void
4116 debug_string_purity_print (struct Lisp_String *p)
4117 {
4118   Charcount i;
4119   Charcount s = string_char_length (p);
4120   putc ('\"', stderr);
4121   for (i = 0; i < s; i++)
4122   {
4123     Emchar ch = string_char (p, i);
4124     if (ch < 32 || ch >= 126)
4125       stderr_out ("\\%03o", ch);
4126     else if (ch == '\\' || ch == '\"')
4127       stderr_out ("\\%c", ch);
4128     else
4129       stderr_out ("%c", ch);
4130   }
4131   stderr_out ("\"\n");
4132 }
4133 #endif /* 1 */
4134
4135
4136 static void
4137 sweep_strings (void)
4138 {
4139   int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
4140   int debug = debug_string_purity;
4141
4142 #ifdef LRECORD_STRING
4143
4144 # define MARKED_string_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
4145 # define UNMARK_string(ptr)                             \
4146   do { struct Lisp_String *p = (ptr);                   \
4147        int size = string_length (p);                    \
4148        UNMARK_RECORD_HEADER (&(p->lheader));            \
4149        num_bytes += size;                               \
4150        if (!BIG_STRING_SIZE_P (size))                   \
4151          { num_small_bytes += size;                     \
4152            num_small_used++;                            \
4153          }                                              \
4154        if (debug) debug_string_purity_print (p);        \
4155      } while (0)
4156 # define ADDITIONAL_FREE_string(p)                              \
4157   do { int size = string_length (p);                            \
4158        if (BIG_STRING_SIZE_P (size))                            \
4159          xfree_1 (CHARS_TO_STRING_CHAR (string_data (p)));      \
4160      } while (0)
4161
4162 #else
4163
4164 # define MARKED_string_P(ptr) XMARKBIT ((ptr)->plist)
4165 # define UNMARK_string(ptr)                             \
4166   do { struct Lisp_String *p = (ptr);                   \
4167        int size = string_length (p);                    \
4168        XUNMARK (p->plist);                              \
4169        num_bytes += size;                               \
4170        if (!BIG_STRING_SIZE_P (size))                   \
4171          { num_small_bytes += size;                     \
4172            num_small_used++;                            \
4173          }                                              \
4174        if (debug) debug_string_purity_print (p);        \
4175      } while (0)
4176 # define ADDITIONAL_FREE_string(p)                              \
4177   do { int size = string_length (p);                            \
4178        if (BIG_STRING_SIZE_P (size))                            \
4179          xfree_1 (CHARS_TO_STRING_CHAR (string_data (p)));      \
4180      } while (0)
4181
4182 #endif /* ! LRECORD_STRING */
4183
4184   SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String);
4185
4186   gc_count_num_short_string_in_use = num_small_used;
4187   gc_count_string_total_size = num_bytes;
4188   gc_count_short_string_total_size = num_small_bytes;
4189 }
4190
4191
4192 /* I hate duplicating all this crap! */
4193 static int
4194 marked_p (Lisp_Object obj)
4195 {
4196   if (EQ (obj, Qnull_pointer)) return 1;
4197   if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1;
4198   if (PURIFIED (XPNTR (obj))) return 1;
4199   switch (XGCTYPE (obj))
4200     {
4201 #ifndef LRECORD_CONS
4202     case Lisp_Type_Cons:
4203       return XMARKBIT (XCAR (obj));
4204 #endif
4205     case Lisp_Type_Record:
4206       return MARKED_RECORD_HEADER_P (XRECORD_LHEADER (obj));
4207 #ifndef LRECORD_STRING
4208     case Lisp_Type_String:
4209       return XMARKBIT (XSTRING (obj)->plist);
4210 #endif /* ! LRECORD_STRING */
4211 #ifndef LRECORD_VECTOR
4212     case Lisp_Type_Vector:
4213       return XVECTOR_LENGTH (obj) < 0;
4214 #endif /* !LRECORD_VECTOR */
4215 #ifndef LRECORD_SYMBOL
4216     case Lisp_Type_Symbol:
4217       return XMARKBIT (XSYMBOL (obj)->plist);
4218 #endif
4219     default:
4220       abort ();
4221     }
4222   return 0;     /* suppress compiler warning */
4223 }
4224
4225 static void
4226 gc_sweep (void)
4227 {
4228   /* Free all unmarked records.  Do this at the very beginning,
4229      before anything else, so that the finalize methods can safely
4230      examine items in the objects.  sweep_lcrecords_1() makes
4231      sure to call all the finalize methods *before* freeing anything,
4232      to complete the safety. */
4233   {
4234     int ignored;
4235     sweep_lcrecords_1 (&all_lcrecords, &ignored);
4236   }
4237
4238   compact_string_chars ();
4239
4240   /* Finalize methods below (called through the ADDITIONAL_FREE_foo
4241      macros) must be *extremely* careful to make sure they're not
4242      referencing freed objects.  The only two existing finalize
4243      methods (for strings and markers) pass muster -- the string
4244      finalizer doesn't look at anything but its own specially-
4245      created block, and the marker finalizer only looks at live
4246      buffers (which will never be freed) and at the markers before
4247      and after it in the chain (which, by induction, will never be
4248      freed because if so, they would have already removed themselves
4249      from the chain). */
4250
4251   /* Put all unmarked strings on free list, free'ing the string chars
4252      of large unmarked strings */
4253   sweep_strings ();
4254
4255   /* Put all unmarked conses on free list */
4256   sweep_conses ();
4257
4258 #ifndef LRECORD_VECTOR
4259   /* Free all unmarked vectors */
4260   sweep_vectors_1 (&all_vectors,
4261                    &gc_count_num_vector_used, &gc_count_vector_total_size,
4262                    &gc_count_vector_storage);
4263 #endif
4264
4265   /* Free all unmarked bit vectors */
4266   sweep_bit_vectors_1 (&all_bit_vectors,
4267                        &gc_count_num_bit_vector_used,
4268                        &gc_count_bit_vector_total_size,
4269                        &gc_count_bit_vector_storage);
4270
4271   /* Free all unmarked compiled-function objects */
4272   sweep_compiled_functions ();
4273
4274 #ifdef LISP_FLOAT_TYPE
4275   /* Put all unmarked floats on free list */
4276   sweep_floats ();
4277 #endif
4278
4279   /* Put all unmarked symbols on free list */
4280   sweep_symbols ();
4281
4282   /* Put all unmarked extents on free list */
4283   sweep_extents ();
4284
4285   /* Put all unmarked markers on free list.
4286      Dechain each one first from the buffer into which it points. */
4287   sweep_markers ();
4288
4289   sweep_events ();
4290
4291 }
4292 \f
4293 /* Clearing for disksave. */
4294
4295 void
4296 disksave_object_finalization (void)
4297 {
4298   /* It's important that certain information from the environment not get
4299      dumped with the executable (pathnames, environment variables, etc.).
4300      To make it easier to tell when this has happend with strings(1) we
4301      clear some known-to-be-garbage blocks of memory, so that leftover
4302      results of old evaluation don't look like potential problems.
4303      But first we set some notable variables to nil and do one more GC,
4304      to turn those strings into garbage.
4305    */
4306
4307   /* Yeah, this list is pretty ad-hoc... */
4308   Vprocess_environment = Qnil;
4309   Vexec_directory = Qnil;
4310   Vdata_directory = Qnil;
4311   Vsite_directory = Qnil;
4312   Vdoc_directory = Qnil;
4313   Vconfigure_info_directory = Qnil;
4314   Vexec_path = Qnil;
4315   Vload_path = Qnil;
4316   /* Vdump_load_path = Qnil; */
4317   uncache_home_directory();
4318
4319 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
4320                            defined(LOADHIST_BUILTIN))
4321   Vload_history = Qnil;
4322 #endif
4323   Vshell_file_name = Qnil;
4324
4325   garbage_collect_1 ();
4326
4327   /* Run the disksave finalization methods of all live objects. */
4328   disksave_object_finalization_1 ();
4329
4330 #if 0 /* I don't see any point in this.  The purespace starts out all 0's */
4331   /* Zero out the unused portion of purespace */
4332   if (!pure_lossage)
4333     memset (  (char *) (PUREBEG + pure_bytes_used), 0,
4334             (((char *) (PUREBEG + get_PURESIZE())) -
4335              ((char *) (PUREBEG + pure_bytes_used))));
4336 #endif
4337
4338   /* Zero out the uninitialized (really, unused) part of the containers
4339      for the live strings. */
4340   {
4341     struct string_chars_block *scb;
4342     for (scb = first_string_chars_block; scb; scb = scb->next)
4343       {
4344         int count = sizeof (scb->string_chars) - scb->pos;
4345
4346         assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
4347         if (count != 0) {
4348           /* from the block's fill ptr to the end */
4349           memset ((scb->string_chars + scb->pos), 0, count);
4350         }
4351       }
4352   }
4353
4354   /* There, that ought to be enough... */
4355
4356 }
4357
4358 \f
4359 Lisp_Object
4360 restore_gc_inhibit (Lisp_Object val)
4361 {
4362   gc_currently_forbidden = XINT (val);
4363   return val;
4364 }
4365
4366 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */
4367 static int gc_hooks_inhibited;
4368
4369 \f
4370 void
4371 garbage_collect_1 (void)
4372 {
4373   char stack_top_variable;
4374   extern char *stack_bottom;
4375   int i;
4376   struct frame *f;
4377   int speccount;
4378   int cursor_changed;
4379   Lisp_Object pre_gc_cursor;
4380   struct gcpro gcpro1;
4381
4382   if (gc_in_progress
4383       || gc_currently_forbidden
4384       || in_display
4385       || preparing_for_armageddon)
4386     return;
4387
4388   pre_gc_cursor = Qnil;
4389   cursor_changed = 0;
4390
4391   /* This function cannot be called inside GC so we move to after the */
4392   /* above tests */
4393   f = selected_frame ();
4394
4395   GCPRO1 (pre_gc_cursor);
4396
4397   /* Very important to prevent GC during any of the following
4398      stuff that might run Lisp code; otherwise, we'll likely
4399      have infinite GC recursion. */
4400   speccount = specpdl_depth ();
4401   record_unwind_protect (restore_gc_inhibit,
4402                          make_int (gc_currently_forbidden));
4403   gc_currently_forbidden = 1;
4404
4405   if (!gc_hooks_inhibited)
4406     run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
4407
4408   /* Now show the GC cursor/message. */
4409   if (!noninteractive)
4410     {
4411       if (FRAME_WIN_P (f))
4412         {
4413           Lisp_Object frame = make_frame (f);
4414           Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
4415                                                      FRAME_SELECTED_WINDOW (f),
4416                                                      ERROR_ME_NOT, 1);
4417           pre_gc_cursor = f->pointer;
4418           if (POINTER_IMAGE_INSTANCEP (cursor)
4419               /* don't change if we don't know how to change back. */
4420               && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
4421             {
4422               cursor_changed = 1;
4423               Fset_frame_pointer (frame, cursor);
4424             }
4425         }
4426
4427       /* Don't print messages to the stream device. */
4428       if (!cursor_changed && !FRAME_STREAM_P (f))
4429         {
4430           char *msg = (STRINGP (Vgc_message)
4431                        ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
4432                        : 0);
4433           Lisp_Object args[2], whole_msg;
4434           args[0] = build_string (msg ? msg :
4435                                   GETTEXT ((CONST char *) gc_default_message));
4436           args[1] = build_string ("...");
4437           whole_msg = Fconcat (2, args);
4438           echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
4439                              Qgarbage_collecting);
4440         }
4441     }
4442
4443   /***** Now we actually start the garbage collection. */
4444
4445   gc_in_progress = 1;
4446
4447   gc_generation_number[0]++;
4448
4449 #if MAX_SAVE_STACK > 0
4450
4451   /* Save a copy of the contents of the stack, for debugging.  */
4452   if (!purify_flag)
4453     {
4454       /* Static buffer in which we save a copy of the C stack at each GC.  */
4455       static char *stack_copy;
4456       static size_t stack_copy_size;
4457
4458       ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
4459       size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
4460       if (stack_size < MAX_SAVE_STACK)
4461         {
4462           if (stack_copy_size < stack_size)
4463             {
4464               stack_copy = (char *) xrealloc (stack_copy, stack_size);
4465               stack_copy_size = stack_size;
4466             }
4467
4468           memcpy (stack_copy,
4469                   stack_diff > 0 ? stack_bottom : &stack_top_variable,
4470                   stack_size);
4471         }
4472     }
4473 #endif /* MAX_SAVE_STACK > 0 */
4474
4475   /* Do some totally ad-hoc resource clearing. */
4476   /* #### generalize this? */
4477   clear_event_resource ();
4478   cleanup_specifiers ();
4479
4480   /* Mark all the special slots that serve as the roots of accessibility. */
4481   {
4482     struct gcpro *tail;
4483     struct catchtag *catch;
4484     struct backtrace *backlist;
4485     struct specbinding *bind;
4486
4487     for (i = 0; i < staticidx; i++)
4488       {
4489 #ifdef GDB_SUCKS
4490         printf ("%d\n", i);
4491         debug_print (*staticvec[i]);
4492 #endif
4493         mark_object (*(staticvec[i]));
4494       }
4495
4496     for (tail = gcprolist; tail; tail = tail->next)
4497       {
4498         for (i = 0; i < tail->nvars; i++)
4499           mark_object (tail->var[i]);
4500       }
4501
4502     for (bind = specpdl; bind != specpdl_ptr; bind++)
4503       {
4504         mark_object (bind->symbol);
4505         mark_object (bind->old_value);
4506       }
4507
4508     for (catch = catchlist; catch; catch = catch->next)
4509       {
4510         mark_object (catch->tag);
4511         mark_object (catch->val);
4512       }
4513
4514     for (backlist = backtrace_list; backlist; backlist = backlist->next)
4515       {
4516         int nargs = backlist->nargs;
4517
4518         mark_object (*backlist->function);
4519         if (nargs == UNEVALLED || nargs == MANY)
4520           mark_object (backlist->args[0]);
4521         else
4522           for (i = 0; i < nargs; i++)
4523             mark_object (backlist->args[i]);
4524       }
4525
4526     mark_redisplay (mark_object);
4527     mark_profiling_info (mark_object);
4528   }
4529
4530   /* OK, now do the after-mark stuff.  This is for things that
4531      are only marked when something else is marked (e.g. weak hashtables).
4532      There may be complex dependencies between such objects -- e.g.
4533      a weak hashtable might be unmarked, but after processing a later
4534      weak hashtable, the former one might get marked.  So we have to
4535      iterate until nothing more gets marked. */
4536   {
4537     int did_mark;
4538     /* Need to iterate until there's nothing more to mark, in case
4539        of chains of mark dependencies. */
4540     do
4541       {
4542         did_mark = 0;
4543         did_mark += !!finish_marking_weak_hashtables (marked_p, mark_object);
4544         did_mark += !!finish_marking_weak_lists (marked_p, mark_object);
4545       }
4546     while (did_mark);
4547   }
4548
4549   /* And prune (this needs to be called after everything else has been
4550      marked and before we do any sweeping). */
4551   /* #### this is somewhat ad-hoc and should probably be an object
4552      method */
4553   prune_weak_hashtables (marked_p);
4554   prune_weak_lists (marked_p);
4555   prune_specifiers (marked_p);
4556   prune_syntax_tables (marked_p);
4557
4558   gc_sweep ();
4559
4560   consing_since_gc = 0;
4561 #ifndef DEBUG_XEMACS
4562   /* Allow you to set it really fucking low if you really want ... */
4563   if (gc_cons_threshold < 10000)
4564     gc_cons_threshold = 10000;
4565 #endif
4566
4567   gc_in_progress = 0;
4568
4569   /******* End of garbage collection ********/
4570
4571   run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
4572
4573   /* Now remove the GC cursor/message */
4574   if (!noninteractive)
4575     {
4576       if (cursor_changed)
4577         Fset_frame_pointer (make_frame (f), pre_gc_cursor);
4578       else if (!FRAME_STREAM_P (f))
4579         {
4580           char *msg = (STRINGP (Vgc_message)
4581                        ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
4582                        : 0);
4583
4584           /* Show "...done" only if the echo area would otherwise be empty. */
4585           if (NILP (clear_echo_area (selected_frame (),
4586                                      Qgarbage_collecting, 0)))
4587             {
4588               Lisp_Object args[2], whole_msg;
4589               args[0] = build_string (msg ? msg :
4590                                       GETTEXT ((CONST char *)
4591                                                gc_default_message));
4592               args[1] = build_string ("... done");
4593               whole_msg = Fconcat (2, args);
4594               echo_area_message (selected_frame (), (Bufbyte *) 0,
4595                                  whole_msg, 0, -1,
4596                                  Qgarbage_collecting);
4597             }
4598         }
4599     }
4600
4601   /* now stop inhibiting GC */
4602   unbind_to (speccount, Qnil);
4603
4604   if (!breathing_space)
4605     {
4606       breathing_space = malloc (4096 - MALLOC_OVERHEAD);
4607     }
4608
4609   UNGCPRO;
4610   return;
4611 }
4612
4613 #ifdef EMACS_BTL
4614  /* This isn't actually called.  BTL recognizes the stack frame of the top
4615     of the garbage collector by noting that PC is between &garbage_collect_1
4616     and &BTL_after_garbage_collect_1_stub.  So this fn must be right here.
4617     There's not any other way to know the address of the end of a function.
4618   */
4619 void BTL_after_garbage_collect_1_stub () { abort (); }
4620 #endif /* EMACS_BTL */
4621
4622 /* Debugging aids.  */
4623
4624 static Lisp_Object
4625 gc_plist_hack (CONST char *name, int value, Lisp_Object tail)
4626 {
4627   /* C doesn't have local functions (or closures, or GC, or readable syntax,
4628      or portable numeric datatypes, or bit-vectors, or characters, or
4629      arrays, or exceptions, or ...) */
4630   return cons3 (intern (name), make_int (value), tail);
4631 }
4632
4633 #define HACK_O_MATIC(type, name, pl)                                    \
4634   {                                                                     \
4635     int s = 0;                                                          \
4636     struct type##_block *x = current_##type##_block;                    \
4637     while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; }      \
4638     (pl) = gc_plist_hack ((name), s, (pl));                             \
4639   }
4640
4641 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
4642 Reclaim storage for Lisp objects no longer needed.
4643 Return info on amount of space in use:
4644  ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4645   (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4646   PLIST)
4647   where `PLIST' is a list of alternating keyword/value pairs providing
4648   more detailed information.
4649 Garbage collection happens automatically if you cons more than
4650 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4651 */
4652        ())
4653 {
4654   Lisp_Object pl = Qnil;
4655   int i;
4656 #ifdef LRECORD_VECTOR
4657   int gc_count_vector_total_size = 0;
4658 #endif
4659
4660   if (purify_flag && pure_lossage)
4661     return Qnil;
4662
4663   garbage_collect_1 ();
4664
4665   for (i = 0; i < last_lrecord_type_index_assigned; i++)
4666     {
4667       if (lcrecord_stats[i].bytes_in_use != 0
4668           || lcrecord_stats[i].bytes_freed != 0
4669           || lcrecord_stats[i].instances_on_free_list != 0)
4670         {
4671           char buf [255];
4672           CONST char *name = lrecord_implementations_table[i]->name;
4673           int len = strlen (name);
4674 #ifdef LRECORD_VECTOR
4675           /* save this for the FSFmacs-compatible part of the summary */
4676           if (i == *lrecord_vector[0].lrecord_type_index)
4677             gc_count_vector_total_size =
4678               lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
4679 #endif
4680           sprintf (buf, "%s-storage", name);
4681           pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
4682           /* Okay, simple pluralization check for `symbol-value-varalias' */
4683           if (name[len-1] == 's')
4684             sprintf (buf, "%ses-freed", name);
4685           else
4686             sprintf (buf, "%ss-freed", name);
4687           if (lcrecord_stats[i].instances_freed != 0)
4688             pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
4689           if (name[len-1] == 's')
4690             sprintf (buf, "%ses-on-free-list", name);
4691           else
4692             sprintf (buf, "%ss-on-free-list", name);
4693           if (lcrecord_stats[i].instances_on_free_list != 0)
4694             pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
4695                                 pl);
4696           if (name[len-1] == 's')
4697             sprintf (buf, "%ses-used", name);
4698           else
4699             sprintf (buf, "%ss-used", name);
4700           pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
4701         }
4702     }
4703
4704   HACK_O_MATIC (extent, "extent-storage", pl);
4705   pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
4706   pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
4707   HACK_O_MATIC (event, "event-storage", pl);
4708   pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
4709   pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
4710   HACK_O_MATIC (marker, "marker-storage", pl);
4711   pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
4712   pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
4713 #ifdef LISP_FLOAT_TYPE
4714   HACK_O_MATIC (float, "float-storage", pl);
4715   pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
4716   pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
4717 #endif /* LISP_FLOAT_TYPE */
4718   HACK_O_MATIC (string, "string-header-storage", pl);
4719   pl = gc_plist_hack ("long-strings-total-length",
4720                       gc_count_string_total_size
4721                       - gc_count_short_string_total_size, pl);
4722   HACK_O_MATIC (string_chars, "short-string-storage", pl);
4723   pl = gc_plist_hack ("short-strings-total-length",
4724                       gc_count_short_string_total_size, pl);
4725   pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
4726   pl = gc_plist_hack ("long-strings-used",
4727                       gc_count_num_string_in_use
4728                       - gc_count_num_short_string_in_use, pl);
4729   pl = gc_plist_hack ("short-strings-used",
4730                       gc_count_num_short_string_in_use, pl);
4731
4732   HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
4733   pl = gc_plist_hack ("compiled-functions-free",
4734                       gc_count_num_compiled_function_freelist, pl);
4735   pl = gc_plist_hack ("compiled-functions-used",
4736                       gc_count_num_compiled_function_in_use, pl);
4737
4738 #ifndef LRECORD_VECTOR
4739   pl = gc_plist_hack ("vector-storage", gc_count_vector_storage, pl);
4740   pl = gc_plist_hack ("vectors-total-length",
4741                       gc_count_vector_total_size, pl);
4742   pl = gc_plist_hack ("vectors-used", gc_count_num_vector_used, pl);
4743 #endif
4744
4745   pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
4746   pl = gc_plist_hack ("bit-vectors-total-length",
4747                       gc_count_bit_vector_total_size, pl);
4748   pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
4749
4750   HACK_O_MATIC (symbol, "symbol-storage", pl);
4751   pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
4752   pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
4753
4754   HACK_O_MATIC (cons, "cons-storage", pl);
4755   pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
4756   pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
4757
4758   /* The things we do for backwards-compatibility */
4759   return
4760     list6 (Fcons (make_int (gc_count_num_cons_in_use),
4761                   make_int (gc_count_num_cons_freelist)),
4762            Fcons (make_int (gc_count_num_symbol_in_use),
4763                   make_int (gc_count_num_symbol_freelist)),
4764            Fcons (make_int (gc_count_num_marker_in_use),
4765                   make_int (gc_count_num_marker_freelist)),
4766            make_int (gc_count_string_total_size),
4767            make_int (gc_count_vector_total_size),
4768            pl);
4769 }
4770 #undef HACK_O_MATIC
4771
4772 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
4773 Return the number of bytes consed since the last garbage collection.
4774 \"Consed\" is a misnomer in that this actually counts allocation
4775 of all different kinds of objects, not just conses.
4776
4777 If this value exceeds `gc-cons-threshold', a garbage collection happens.
4778 */
4779        ())
4780 {
4781   return make_int (consing_since_gc);
4782 }
4783
4784 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
4785 Return the address of the last byte Emacs has allocated, divided by 1024.
4786 This may be helpful in debugging Emacs's memory usage.
4787 The value is divided by 1024 to make sure it will fit in a lisp integer.
4788 */
4789        ())
4790 {
4791   return make_int ((EMACS_INT) sbrk (0) / 1024);
4792 }
4793
4794
4795 \f
4796 int
4797 object_dead_p (Lisp_Object obj)
4798 {
4799   return ((BUFFERP  (obj) && !BUFFER_LIVE_P  (XBUFFER  (obj))) ||
4800           (FRAMEP   (obj) && !FRAME_LIVE_P   (XFRAME   (obj))) ||
4801           (WINDOWP  (obj) && !WINDOW_LIVE_P  (XWINDOW  (obj))) ||
4802           (DEVICEP  (obj) && !DEVICE_LIVE_P  (XDEVICE  (obj))) ||
4803           (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
4804           (EVENTP   (obj) && !EVENT_LIVE_P   (XEVENT   (obj))) ||
4805           (EXTENTP  (obj) && !EXTENT_LIVE_P  (XEXTENT  (obj))));
4806 }
4807
4808 #ifdef MEMORY_USAGE_STATS
4809
4810 /* Attempt to determine the actual amount of space that is used for
4811    the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
4812
4813    It seems that the following holds:
4814
4815    1. When using the old allocator (malloc.c):
4816
4817       -- blocks are always allocated in chunks of powers of two.  For
4818          each block, there is an overhead of 8 bytes if rcheck is not
4819          defined, 20 bytes if it is defined.  In other words, a
4820          one-byte allocation needs 8 bytes of overhead for a total of
4821          9 bytes, and needs to have 16 bytes of memory chunked out for
4822          it.
4823
4824    2. When using the new allocator (gmalloc.c):
4825
4826       -- blocks are always allocated in chunks of powers of two up
4827          to 4096 bytes.  Larger blocks are allocated in chunks of
4828          an integral multiple of 4096 bytes.  The minimum block
4829          size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
4830          is defined.  There is no per-block overhead, but there
4831          is an overhead of 3*sizeof (size_t) for each 4096 bytes
4832          allocated.
4833
4834     3. When using the system malloc, anything goes, but they are
4835        generally slower and more space-efficient than the GNU
4836        allocators.  One possibly reasonable assumption to make
4837        for want of better data is that sizeof (void *), or maybe
4838        2 * sizeof (void *), is required as overhead and that
4839        blocks are allocated in the minimum required size except
4840        that some minimum block size is imposed (e.g. 16 bytes). */
4841
4842 size_t
4843 malloced_storage_size (void *ptr, size_t claimed_size,
4844                        struct overhead_stats *stats)
4845 {
4846   size_t orig_claimed_size = claimed_size;
4847
4848 #ifdef GNU_MALLOC
4849
4850   if (claimed_size < 2 * sizeof (void *))
4851     claimed_size = 2 * sizeof (void *);
4852 # ifdef SUNOS_LOCALTIME_BUG
4853   if (claimed_size < 16)
4854     claimed_size = 16;
4855 # endif
4856   if (claimed_size < 4096)
4857     {
4858       int log = 1;
4859
4860       /* compute the log base two, more or less, then use it to compute
4861          the block size needed. */
4862       claimed_size--;
4863       /* It's big, it's heavy, it's wood! */
4864       while ((claimed_size /= 2) != 0)
4865         ++log;
4866       claimed_size = 1;
4867       /* It's better than bad, it's good! */
4868       while (log > 0)
4869         {
4870           claimed_size *= 2;
4871           log--;
4872         }
4873       /* We have to come up with some average about the amount of
4874          blocks used. */
4875       if ((size_t) (rand () & 4095) < claimed_size)
4876         claimed_size += 3 * sizeof (void *);
4877     }
4878   else
4879     {
4880       claimed_size += 4095;
4881       claimed_size &= ~4095;
4882       claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
4883     }
4884
4885 #elif defined (SYSTEM_MALLOC)
4886
4887   if (claimed_size < 16)
4888     claimed_size = 16;
4889   claimed_size += 2 * sizeof (void *);
4890
4891 #else /* old GNU allocator */
4892
4893 # ifdef rcheck /* #### may not be defined here */
4894   claimed_size += 20;
4895 # else
4896   claimed_size += 8;
4897 # endif
4898   {
4899     int log = 1;
4900
4901     /* compute the log base two, more or less, then use it to compute
4902        the block size needed. */
4903     claimed_size--;
4904     /* It's big, it's heavy, it's wood! */
4905     while ((claimed_size /= 2) != 0)
4906       ++log;
4907     claimed_size = 1;
4908     /* It's better than bad, it's good! */
4909     while (log > 0)
4910       {
4911         claimed_size *= 2;
4912         log--;
4913       }
4914   }
4915
4916 #endif /* old GNU allocator */
4917
4918   if (stats)
4919     {
4920       stats->was_requested += orig_claimed_size;
4921       stats->malloc_overhead += claimed_size - orig_claimed_size;
4922     }
4923   return claimed_size;
4924 }
4925
4926 size_t
4927 fixed_type_block_overhead (size_t size)
4928 {
4929   size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
4930   size_t overhead = 0;
4931   size_t storage_size = malloced_storage_size (0, per_block, 0);
4932   while (size >= per_block)
4933     {
4934       size -= per_block;
4935       overhead += sizeof (void *) + per_block - storage_size;
4936     }
4937   if (rand () % per_block < size)
4938     overhead += sizeof (void *) + per_block - storage_size;
4939   return overhead;
4940 }
4941
4942 #endif /* MEMORY_USAGE_STATS */
4943
4944 \f
4945 /* Initialization */
4946 void
4947 init_alloc_once_early (void)
4948 {
4949   int iii;
4950
4951 #ifdef PURESTAT
4952   for (iii = 0; iii < countof (purestats); iii++)
4953     {
4954       if (! purestats[iii]) continue;
4955       purestats[iii]->nobjects = 0;
4956       purestats[iii]->nbytes = 0;
4957     }
4958   purecopying_for_bytecode = 0;
4959 #endif /* PURESTAT */
4960
4961   last_lrecord_type_index_assigned = -1;
4962   for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
4963     {
4964       lrecord_implementations_table[iii] = 0;
4965     }
4966
4967 #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
4968   /*
4969    * If USE_INDEXED_LRECORD_IMPLEMENTATION is defined, all the staticly
4970    * defined subr lrecords were initialized with lheader->type == 0.
4971    * See subr_lheader_initializer in lisp.h.  Force type index 0 to be
4972    * assigned to lrecord_subr so that those predefined indexes match
4973    * reality.
4974    */
4975   lrecord_type_index (lrecord_subr);
4976   assert (*(lrecord_subr[0].lrecord_type_index) == 0);
4977   /*
4978    * The same is true for symbol_value_forward objects, except the
4979    * type is 1.
4980    */
4981   lrecord_type_index (lrecord_symbol_value_forward);
4982   assert (*(lrecord_symbol_value_forward[0].lrecord_type_index) == 1);
4983 #endif /* USE_INDEXED_LRECORD_IMPLEMENTATION */
4984
4985   symbols_initialized = 0;
4986
4987   gc_generation_number[0] = 0;
4988   /* purify_flag 1 is correct even if CANNOT_DUMP.
4989    * loadup.el will set to nil at end. */
4990   purify_flag = 1;
4991   pure_bytes_used = 0;
4992   pure_lossage = 0;
4993   breathing_space = 0;
4994 #ifndef LRECORD_VECTOR
4995   XSETINT (all_vectors, 0); /* Qzero may not be set yet. */
4996 #endif
4997   XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
4998   XSETINT (Vgc_message, 0);
4999   all_lcrecords = 0;
5000   ignore_malloc_warnings = 1;
5001 #ifdef DOUG_LEA_MALLOC
5002   mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
5003   mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
5004 #if 0 /* Moved to emacs.c */
5005   mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
5006 #endif
5007 #endif
5008   init_string_alloc ();
5009   init_string_chars_alloc ();
5010   init_cons_alloc ();
5011   init_symbol_alloc ();
5012   init_compiled_function_alloc ();
5013 #ifdef LISP_FLOAT_TYPE
5014   init_float_alloc ();
5015 #endif /* LISP_FLOAT_TYPE */
5016   init_marker_alloc ();
5017   init_extent_alloc ();
5018   init_event_alloc ();
5019
5020   ignore_malloc_warnings = 0;
5021   staticidx = 0;
5022   consing_since_gc = 0;
5023 #if 1
5024   gc_cons_threshold = 500000; /* XEmacs change */
5025 #else
5026   gc_cons_threshold = 15000; /* debugging */
5027 #endif
5028 #ifdef VIRT_ADDR_VARIES
5029   malloc_sbrk_unused = 1<<22;   /* A large number */
5030   malloc_sbrk_used = 100000;    /* as reasonable as any number */
5031 #endif /* VIRT_ADDR_VARIES */
5032   lrecord_uid_counter = 259;
5033   debug_string_purity = 0;
5034   gcprolist = 0;
5035
5036   gc_currently_forbidden = 0;
5037   gc_hooks_inhibited = 0;
5038
5039 #ifdef ERROR_CHECK_TYPECHECK
5040   ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5041     666;
5042   ERROR_ME_NOT.
5043     really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
5044   ERROR_ME_WARN.
5045     really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
5046       3333632;
5047 #endif /* ERROR_CHECK_TYPECHECK */
5048 }
5049
5050 void
5051 reinit_alloc (void)
5052 {
5053   gcprolist = 0;
5054 }
5055
5056 void
5057 syms_of_alloc (void)
5058 {
5059   defsymbol (&Qpre_gc_hook, "pre-gc-hook");
5060   defsymbol (&Qpost_gc_hook, "post-gc-hook");
5061   defsymbol (&Qgarbage_collecting, "garbage-collecting");
5062
5063   DEFSUBR (Fcons);
5064   DEFSUBR (Flist);
5065   DEFSUBR (Fvector);
5066   DEFSUBR (Fbit_vector);
5067   DEFSUBR (Fmake_byte_code);
5068   DEFSUBR (Fmake_list);
5069   DEFSUBR (Fmake_vector);
5070   DEFSUBR (Fmake_bit_vector);
5071   DEFSUBR (Fmake_string);
5072   DEFSUBR (Fstring);
5073   DEFSUBR (Fmake_symbol);
5074   DEFSUBR (Fmake_marker);
5075   DEFSUBR (Fpurecopy);
5076   DEFSUBR (Fgarbage_collect);
5077   DEFSUBR (Fmemory_limit);
5078   DEFSUBR (Fconsing_since_gc);
5079 }
5080
5081 void
5082 vars_of_alloc (void)
5083 {
5084   DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
5085 *Number of bytes of consing between garbage collections.
5086 \"Consing\" is a misnomer in that this actually counts allocation
5087 of all different kinds of objects, not just conses.
5088 Garbage collection can happen automatically once this many bytes have been
5089 allocated since the last garbage collection.  All data types count.
5090
5091 Garbage collection happens automatically when `eval' or `funcall' are
5092 called.  (Note that `funcall' is called implicitly as part of evaluation.)
5093 By binding this temporarily to a large number, you can effectively
5094 prevent garbage collection during a part of the program.
5095
5096 See also `consing-since-gc'.
5097 */ );
5098
5099   DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
5100 Number of bytes of sharable Lisp data allocated so far.
5101 */ );
5102
5103 #if 0
5104   DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
5105 Number of bytes of unshared memory allocated in this session.
5106 */ );
5107
5108   DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
5109 Number of bytes of unshared memory remaining available in this session.
5110 */ );
5111 #endif
5112
5113 #ifdef DEBUG_XEMACS
5114   DEFVAR_INT ("debug-allocation", &debug_allocation /*
5115 If non-zero, print out information to stderr about all objects allocated.
5116 See also `debug-allocation-backtrace-length'.
5117 */ );
5118   debug_allocation = 0;
5119
5120   DEFVAR_INT ("debug-allocation-backtrace-length",
5121               &debug_allocation_backtrace_length /*
5122 Length (in stack frames) of short backtrace printed out by `debug-allocation'.
5123 */ );
5124   debug_allocation_backtrace_length = 2;
5125 #endif
5126
5127   DEFVAR_BOOL ("purify-flag", &purify_flag /*
5128 Non-nil means loading Lisp code in order to dump an executable.
5129 This means that certain objects should be allocated in shared (pure) space.
5130 */ );
5131
5132   DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
5133 Function or functions to be run just before each garbage collection.
5134 Interrupts, garbage collection, and errors are inhibited while this hook
5135 runs, so be extremely careful in what you add here.  In particular, avoid
5136 consing, and do not interact with the user.
5137 */ );
5138   Vpre_gc_hook = Qnil;
5139
5140   DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
5141 Function or functions to be run just after each garbage collection.
5142 Interrupts, garbage collection, and errors are inhibited while this hook
5143 runs, so be extremely careful in what you add here.  In particular, avoid
5144 consing, and do not interact with the user.
5145 */ );
5146   Vpost_gc_hook = Qnil;
5147
5148   DEFVAR_LISP ("gc-message", &Vgc_message /*
5149 String to print to indicate that a garbage collection is in progress.
5150 This is printed in the echo area.  If the selected frame is on a
5151 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
5152 image instance) in the domain of the selected frame, the mouse pointer
5153 will change instead of this message being printed.
5154 */ );
5155   Vgc_message = make_pure_string ((CONST Bufbyte *) gc_default_message,
5156                                   countof (gc_default_message) - 1,
5157                                   Qnil, 1);
5158
5159   DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
5160 Pointer glyph used to indicate that a garbage collection is in progress.
5161 If the selected window is on a window system and this glyph specifies a
5162 value (i.e. a pointer image instance) in the domain of the selected
5163 window, the pointer will be changed as specified during garbage collection.
5164 Otherwise, a message will be printed in the echo area, as controlled
5165 by `gc-message'.
5166 */ );
5167 }
5168
5169 void
5170 complex_vars_of_alloc (void)
5171 {
5172   Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
5173 }