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