(tool-bar-help): New function.
[bpt/emacs.git] / src / alloc.c
CommitLineData
7146af97 1/* Storage allocation and gc for GNU Emacs Lisp interpreter.
2e471eb5 2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000
4a2f9c6a 3 Free Software Foundation, Inc.
7146af97
JB
4
5This file is part of GNU Emacs.
6
7GNU Emacs is free software; you can redistribute it and/or modify
8it under the terms of the GNU General Public License as published by
7c299e7a 9the Free Software Foundation; either version 2, or (at your option)
7146af97
JB
10any later version.
11
12GNU Emacs is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15GNU General Public License for more details.
16
17You should have received a copy of the GNU General Public License
18along with GNU Emacs; see the file COPYING. If not, write to
3b7ad313
EN
19the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20Boston, MA 02111-1307, USA. */
7146af97 21
18160b98 22#include <config.h>
e9b309ac 23#include <stdio.h>
92939d31 24
68c45bf0 25/* Note that this declares bzero on OSF/1. How dumb. */
2e471eb5 26
68c45bf0 27#include <signal.h>
92939d31 28
7539e11f
KR
29/* This file is part of the core Lisp implementation, and thus must
30 deal with the real data structures. If the Lisp implementation is
31 replaced, this file likely will not be used. */
2e471eb5 32
7539e11f 33#undef HIDE_LISP_IMPLEMENTATION
7146af97 34#include "lisp.h"
d5e35230 35#include "intervals.h"
4c0be5f4 36#include "puresize.h"
7146af97
JB
37#include "buffer.h"
38#include "window.h"
2538fae4 39#include "keyboard.h"
502b9b64 40#include "frame.h"
9ac0d9e0 41#include "blockinput.h"
e54daa22 42#include "charset.h"
e065a56e 43#include "syssignal.h"
34400008 44#include <setjmp.h>
e065a56e 45
bf952fb6
DL
46#ifdef HAVE_UNISTD_H
47#include <unistd.h>
48#else
49extern POINTER_TYPE *sbrk ();
50#endif
ee1eea5c 51
d1658221 52#ifdef DOUG_LEA_MALLOC
2e471eb5 53
d1658221 54#include <malloc.h>
3e60b029
DL
55/* malloc.h #defines this as size_t, at least in glibc2. */
56#ifndef __malloc_size_t
d1658221 57#define __malloc_size_t int
3e60b029 58#endif
81d492d5 59
2e471eb5
GM
60/* Specify maximum number of areas to mmap. It would be nice to use a
61 value that explicitly means "no limit". */
62
81d492d5
RS
63#define MMAP_MAX_AREAS 100000000
64
2e471eb5
GM
65#else /* not DOUG_LEA_MALLOC */
66
276cbe5a
RS
67/* The following come from gmalloc.c. */
68
276cbe5a 69#define __malloc_size_t size_t
276cbe5a 70extern __malloc_size_t _bytes_used;
3e60b029 71extern __malloc_size_t __malloc_extra_blocks;
2e471eb5
GM
72
73#endif /* not DOUG_LEA_MALLOC */
276cbe5a 74
7146af97 75#define max(A,B) ((A) > (B) ? (A) : (B))
b580578b 76#define min(A,B) ((A) < (B) ? (A) : (B))
7146af97
JB
77
78/* Macro to verify that storage intended for Lisp objects is not
79 out of range to fit in the space for a pointer.
80 ADDRESS is the start of the block, and SIZE
81 is the amount of space within which objects can start. */
2e471eb5 82
7146af97
JB
83#define VALIDATE_LISP_STORAGE(address, size) \
84do \
85 { \
86 Lisp_Object val; \
45d12a89 87 XSETCONS (val, (char *) address + size); \
7146af97
JB
88 if ((char *) XCONS (val) != (char *) address + size) \
89 { \
9ac0d9e0 90 xfree (address); \
7146af97
JB
91 memory_full (); \
92 } \
93 } while (0)
94
276cbe5a 95/* Value of _bytes_used, when spare_memory was freed. */
2e471eb5 96
276cbe5a
RS
97static __malloc_size_t bytes_used_when_full;
98
2e471eb5
GM
99/* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
100 to a struct Lisp_String. */
101
cc2d8c6b
KR
102#define MARK_STRING(S) ((S)->size |= MARKBIT)
103#define UNMARK_STRING(S) ((S)->size &= ~MARKBIT)
104#define STRING_MARKED_P(S) ((S)->size & MARKBIT)
2e471eb5
GM
105
106/* Value is the number of bytes/chars of S, a pointer to a struct
107 Lisp_String. This must be used instead of STRING_BYTES (S) or
108 S->size during GC, because S->size contains the mark bit for
109 strings. */
110
111#define GC_STRING_BYTES(S) (STRING_BYTES (S) & ~MARKBIT)
112#define GC_STRING_CHARS(S) ((S)->size & ~MARKBIT)
113
114/* Number of bytes of consing done since the last gc. */
115
7146af97
JB
116int consing_since_gc;
117
310ea200 118/* Count the amount of consing of various sorts of space. */
2e471eb5 119
310ea200
RS
120int cons_cells_consed;
121int floats_consed;
122int vector_cells_consed;
123int symbols_consed;
124int string_chars_consed;
125int misc_objects_consed;
126int intervals_consed;
2e471eb5
GM
127int strings_consed;
128
129/* Number of bytes of consing since GC before another GC should be done. */
310ea200 130
b580578b 131int gc_cons_threshold;
7146af97 132
2e471eb5
GM
133/* Nonzero during GC. */
134
7146af97
JB
135int gc_in_progress;
136
299585ee 137/* Nonzero means display messages at beginning and end of GC. */
2e471eb5 138
299585ee
RS
139int garbage_collection_messages;
140
7146af97
JB
141#ifndef VIRT_ADDR_VARIES
142extern
143#endif /* VIRT_ADDR_VARIES */
2e471eb5 144int malloc_sbrk_used;
7146af97
JB
145
146#ifndef VIRT_ADDR_VARIES
147extern
148#endif /* VIRT_ADDR_VARIES */
2e471eb5 149int malloc_sbrk_unused;
7146af97 150
502b9b64 151/* Two limits controlling how much undo information to keep. */
2e471eb5 152
502b9b64
JB
153int undo_limit;
154int undo_strong_limit;
7146af97 155
34400008
GM
156/* Number of live and free conses etc. */
157
158static int total_conses, total_markers, total_symbols, total_vector_size;
159static int total_free_conses, total_free_markers, total_free_symbols;
160static int total_free_floats, total_floats;
fd27a537 161
2e471eb5
GM
162/* Points to memory space allocated as "spare", to be freed if we run
163 out of memory. */
164
276cbe5a
RS
165static char *spare_memory;
166
167/* Amount of spare memory to keep in reserve. */
2e471eb5 168
276cbe5a
RS
169#define SPARE_MEMORY (1 << 14)
170
171/* Number of extra blocks malloc should get when it needs more core. */
2e471eb5 172
276cbe5a
RS
173static int malloc_hysteresis;
174
2e471eb5
GM
175/* Non-nil means defun should do purecopy on the function definition. */
176
7146af97
JB
177Lisp_Object Vpurify_flag;
178
179#ifndef HAVE_SHM
2e471eb5
GM
180
181/* Force it into data space! */
182
183EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = {0,};
7146af97 184#define PUREBEG (char *) pure
2e471eb5
GM
185
186#else /* not HAVE_SHM */
187
7146af97
JB
188#define pure PURE_SEG_BITS /* Use shared memory segment */
189#define PUREBEG (char *)PURE_SEG_BITS
4c0be5f4
JB
190
191/* This variable is used only by the XPNTR macro when HAVE_SHM is
192 defined. If we used the PURESIZE macro directly there, that would
2e471eb5 193 make most of Emacs dependent on puresize.h, which we don't want -
4c0be5f4
JB
194 you should be able to change that without too much recompilation.
195 So map_in_data initializes pure_size, and the dependencies work
196 out. */
2e471eb5 197
42607681 198EMACS_INT pure_size;
2e471eb5 199
7146af97
JB
200#endif /* not HAVE_SHM */
201
34400008
GM
202/* Value is non-zero if P points into pure space. */
203
204#define PURE_POINTER_P(P) \
205 (((PNTR_COMPARISON_TYPE) (P) \
206 < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)) \
207 && ((PNTR_COMPARISON_TYPE) (P) \
208 >= (PNTR_COMPARISON_TYPE) pure))
209
2e471eb5
GM
210/* Index in pure at which next pure object will be allocated.. */
211
7146af97
JB
212int pureptr;
213
2e471eb5
GM
214/* If nonzero, this is a warning delivered by malloc and not yet
215 displayed. */
216
7146af97
JB
217char *pending_malloc_warning;
218
bcb61d60 219/* Pre-computed signal argument for use when memory is exhausted. */
2e471eb5 220
cf3540e4 221Lisp_Object memory_signal_data;
bcb61d60 222
7146af97
JB
223/* Maximum amount of C stack to save when a GC happens. */
224
225#ifndef MAX_SAVE_STACK
226#define MAX_SAVE_STACK 16000
227#endif
228
229/* Buffer in which we save a copy of the C stack at each GC. */
230
231char *stack_copy;
232int stack_copy_size;
233
2e471eb5
GM
234/* Non-zero means ignore malloc warnings. Set during initialization.
235 Currently not used. */
236
7146af97 237int ignore_warnings;
350273a4 238
a59de17b 239Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
e8197642 240
2e471eb5
GM
241static void mark_buffer P_ ((Lisp_Object));
242static void mark_kboards P_ ((void));
243static void gc_sweep P_ ((void));
41c28a37
GM
244static void mark_glyph_matrix P_ ((struct glyph_matrix *));
245static void mark_face_cache P_ ((struct face_cache *));
246
247#ifdef HAVE_WINDOW_SYSTEM
248static void mark_image P_ ((struct image *));
249static void mark_image_cache P_ ((struct frame *));
250#endif /* HAVE_WINDOW_SYSTEM */
251
2e471eb5
GM
252static struct Lisp_String *allocate_string P_ ((void));
253static void compact_small_strings P_ ((void));
254static void free_large_strings P_ ((void));
255static void sweep_strings P_ ((void));
7da0b0d3
RS
256
257extern int message_enable_multibyte;
34400008 258
34400008
GM
259/* When scanning the C stack for live Lisp objects, Emacs keeps track
260 of what memory allocated via lisp_malloc is intended for what
261 purpose. This enumeration specifies the type of memory. */
262
263enum mem_type
264{
265 MEM_TYPE_NON_LISP,
266 MEM_TYPE_BUFFER,
267 MEM_TYPE_CONS,
268 MEM_TYPE_STRING,
269 MEM_TYPE_MISC,
270 MEM_TYPE_SYMBOL,
271 MEM_TYPE_FLOAT,
272 MEM_TYPE_VECTOR
273};
274
0b378936
GM
275#if GC_MARK_STACK
276
277#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
278#include <stdio.h> /* For fprintf. */
279#endif
280
281/* A unique object in pure space used to make some Lisp objects
282 on free lists recognizable in O(1). */
283
284Lisp_Object Vdead;
285
34400008 286struct mem_node;
b3303f74 287static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
bf952fb6 288static void lisp_free P_ ((POINTER_TYPE *));
34400008
GM
289static void mark_stack P_ ((void));
290static void init_stack P_ ((Lisp_Object *));
291static int live_vector_p P_ ((struct mem_node *, void *));
292static int live_buffer_p P_ ((struct mem_node *, void *));
293static int live_string_p P_ ((struct mem_node *, void *));
294static int live_cons_p P_ ((struct mem_node *, void *));
295static int live_symbol_p P_ ((struct mem_node *, void *));
296static int live_float_p P_ ((struct mem_node *, void *));
297static int live_misc_p P_ ((struct mem_node *, void *));
182ff242 298static void mark_maybe_object P_ ((Lisp_Object));
34400008
GM
299static void mark_memory P_ ((void *, void *));
300static void mem_init P_ ((void));
301static struct mem_node *mem_insert P_ ((void *, void *, enum mem_type));
302static void mem_insert_fixup P_ ((struct mem_node *));
303static void mem_rotate_left P_ ((struct mem_node *));
304static void mem_rotate_right P_ ((struct mem_node *));
305static void mem_delete P_ ((struct mem_node *));
306static void mem_delete_fixup P_ ((struct mem_node *));
307static INLINE struct mem_node *mem_find P_ ((void *));
308
309#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
310static void check_gcpros P_ ((void));
311#endif
312
313#endif /* GC_MARK_STACK != 0 */
314
7146af97 315\f
34400008
GM
316/************************************************************************
317 Malloc
318 ************************************************************************/
319
320/* Write STR to Vstandard_output plus some advice on how to free some
321 memory. Called when memory gets low. */
1a4f1e2c 322
7146af97
JB
323Lisp_Object
324malloc_warning_1 (str)
325 Lisp_Object str;
326{
327 Fprinc (str, Vstandard_output);
328 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
329 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
330 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
331 return Qnil;
332}
333
34400008
GM
334
335/* Function malloc calls this if it finds we are near exhausting
336 storage. */
d457598b
AS
337
338void
7146af97
JB
339malloc_warning (str)
340 char *str;
341{
342 pending_malloc_warning = str;
343}
344
34400008
GM
345
346/* Display a malloc warning in buffer *Danger*. */
347
d457598b 348void
7146af97
JB
349display_malloc_warning ()
350{
351 register Lisp_Object val;
352
353 val = build_string (pending_malloc_warning);
354 pending_malloc_warning = 0;
355 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1, val);
356}
357
34400008 358
d1658221 359#ifdef DOUG_LEA_MALLOC
1177ecf6 360# define BYTES_USED (mallinfo ().arena)
d1658221 361#else
1177ecf6 362# define BYTES_USED _bytes_used
d1658221
RS
363#endif
364
34400008 365
2e471eb5 366/* Called if malloc returns zero. */
276cbe5a 367
d457598b 368void
7146af97
JB
369memory_full ()
370{
276cbe5a 371#ifndef SYSTEM_MALLOC
d1658221 372 bytes_used_when_full = BYTES_USED;
276cbe5a
RS
373#endif
374
375 /* The first time we get here, free the spare memory. */
376 if (spare_memory)
377 {
378 free (spare_memory);
379 spare_memory = 0;
380 }
381
2e471eb5
GM
382 /* This used to call error, but if we've run out of memory, we could
383 get infinite recursion trying to build the string. */
276cbe5a 384 while (1)
74d84334 385 Fsignal (Qnil, memory_signal_data);
276cbe5a
RS
386}
387
34400008 388
276cbe5a
RS
389/* Called if we can't allocate relocatable space for a buffer. */
390
391void
392buffer_memory_full ()
393{
2e471eb5
GM
394 /* If buffers use the relocating allocator, no need to free
395 spare_memory, because we may have plenty of malloc space left
396 that we could get, and if we don't, the malloc that fails will
397 itself cause spare_memory to be freed. If buffers don't use the
398 relocating allocator, treat this like any other failing
399 malloc. */
276cbe5a
RS
400
401#ifndef REL_ALLOC
402 memory_full ();
403#endif
404
2e471eb5
GM
405 /* This used to call error, but if we've run out of memory, we could
406 get infinite recursion trying to build the string. */
bcb61d60
KH
407 while (1)
408 Fsignal (Qerror, memory_signal_data);
7146af97
JB
409}
410
34400008
GM
411
412/* Like malloc but check for no memory and block interrupt input.. */
7146af97 413
c971ff9a 414POINTER_TYPE *
7146af97 415xmalloc (size)
675d5130 416 size_t size;
7146af97 417{
c971ff9a 418 register POINTER_TYPE *val;
7146af97 419
9ac0d9e0 420 BLOCK_INPUT;
c971ff9a 421 val = (POINTER_TYPE *) malloc (size);
9ac0d9e0 422 UNBLOCK_INPUT;
7146af97 423
2e471eb5
GM
424 if (!val && size)
425 memory_full ();
7146af97
JB
426 return val;
427}
428
34400008
GM
429
430/* Like realloc but check for no memory and block interrupt input.. */
431
c971ff9a 432POINTER_TYPE *
7146af97 433xrealloc (block, size)
c971ff9a 434 POINTER_TYPE *block;
675d5130 435 size_t size;
7146af97 436{
c971ff9a 437 register POINTER_TYPE *val;
7146af97 438
9ac0d9e0 439 BLOCK_INPUT;
56d2031b
JB
440 /* We must call malloc explicitly when BLOCK is 0, since some
441 reallocs don't do this. */
442 if (! block)
c971ff9a 443 val = (POINTER_TYPE *) malloc (size);
f048679d 444 else
c971ff9a 445 val = (POINTER_TYPE *) realloc (block, size);
9ac0d9e0 446 UNBLOCK_INPUT;
7146af97
JB
447
448 if (!val && size) memory_full ();
449 return val;
450}
9ac0d9e0 451
34400008
GM
452
453/* Like free but block interrupt input.. */
454
9ac0d9e0
JB
455void
456xfree (block)
c971ff9a 457 POINTER_TYPE *block;
9ac0d9e0
JB
458{
459 BLOCK_INPUT;
460 free (block);
461 UNBLOCK_INPUT;
462}
463
c8099634 464
dca7c6a8
GM
465/* Like strdup, but uses xmalloc. */
466
467char *
468xstrdup (s)
469 char *s;
470{
675d5130 471 size_t len = strlen (s) + 1;
dca7c6a8
GM
472 char *p = (char *) xmalloc (len);
473 bcopy (s, p, len);
474 return p;
475}
476
477
34400008
GM
478/* Like malloc but used for allocating Lisp data. NBYTES is the
479 number of bytes to allocate, TYPE describes the intended use of the
480 allcated memory block (for strings, for conses, ...). */
481
675d5130 482static POINTER_TYPE *
34400008 483lisp_malloc (nbytes, type)
675d5130 484 size_t nbytes;
34400008 485 enum mem_type type;
c8099634 486{
34400008 487 register void *val;
c8099634
RS
488
489 BLOCK_INPUT;
34400008 490 val = (void *) malloc (nbytes);
c8099634 491
34400008 492#if GC_MARK_STACK
dca7c6a8 493 if (val && type != MEM_TYPE_NON_LISP)
34400008
GM
494 mem_insert (val, (char *) val + nbytes, type);
495#endif
496
dca7c6a8
GM
497 UNBLOCK_INPUT;
498 if (!val && nbytes)
499 memory_full ();
c8099634
RS
500 return val;
501}
502
34400008
GM
503
504/* Return a new buffer structure allocated from the heap with
505 a call to lisp_malloc. */
506
507struct buffer *
508allocate_buffer ()
509{
510 return (struct buffer *) lisp_malloc (sizeof (struct buffer),
511 MEM_TYPE_BUFFER);
512}
513
514
515/* Free BLOCK. This must be called to free memory allocated with a
516 call to lisp_malloc. */
517
bf952fb6 518static void
c8099634 519lisp_free (block)
675d5130 520 POINTER_TYPE *block;
c8099634
RS
521{
522 BLOCK_INPUT;
c8099634 523 free (block);
34400008
GM
524#if GC_MARK_STACK
525 mem_delete (mem_find (block));
526#endif
c8099634
RS
527 UNBLOCK_INPUT;
528}
34400008 529
9ac0d9e0
JB
530\f
531/* Arranging to disable input signals while we're in malloc.
532
533 This only works with GNU malloc. To help out systems which can't
534 use GNU malloc, all the calls to malloc, realloc, and free
535 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
536 pairs; unfortunately, we have no idea what C library functions
537 might call malloc, so we can't really protect them unless you're
538 using GNU malloc. Fortunately, most of the major operating can use
539 GNU malloc. */
540
541#ifndef SYSTEM_MALLOC
b3303f74
DL
542#ifndef DOUG_LEA_MALLOC
543extern void * (*__malloc_hook) P_ ((size_t));
544extern void * (*__realloc_hook) P_ ((void *, size_t));
545extern void (*__free_hook) P_ ((void *));
546/* Else declared in malloc.h, perhaps with an extra arg. */
547#endif /* DOUG_LEA_MALLOC */
b0846f52 548static void * (*old_malloc_hook) ();
b0846f52 549static void * (*old_realloc_hook) ();
b0846f52 550static void (*old_free_hook) ();
9ac0d9e0 551
276cbe5a
RS
552/* This function is used as the hook for free to call. */
553
9ac0d9e0
JB
554static void
555emacs_blocked_free (ptr)
556 void *ptr;
557{
558 BLOCK_INPUT;
559 __free_hook = old_free_hook;
560 free (ptr);
276cbe5a
RS
561 /* If we released our reserve (due to running out of memory),
562 and we have a fair amount free once again,
563 try to set aside another reserve in case we run out once more. */
564 if (spare_memory == 0
565 /* Verify there is enough space that even with the malloc
566 hysteresis this call won't run out again.
567 The code here is correct as long as SPARE_MEMORY
568 is substantially larger than the block size malloc uses. */
569 && (bytes_used_when_full
d1658221 570 > BYTES_USED + max (malloc_hysteresis, 4) * SPARE_MEMORY))
675d5130 571 spare_memory = (char *) malloc ((size_t) SPARE_MEMORY);
276cbe5a 572
b0846f52 573 __free_hook = emacs_blocked_free;
9ac0d9e0
JB
574 UNBLOCK_INPUT;
575}
576
34400008 577
276cbe5a
RS
578/* If we released our reserve (due to running out of memory),
579 and we have a fair amount free once again,
580 try to set aside another reserve in case we run out once more.
581
582 This is called when a relocatable block is freed in ralloc.c. */
583
584void
585refill_memory_reserve ()
586{
587 if (spare_memory == 0)
675d5130 588 spare_memory = (char *) malloc ((size_t) SPARE_MEMORY);
276cbe5a
RS
589}
590
34400008 591
276cbe5a
RS
592/* This function is the malloc hook that Emacs uses. */
593
9ac0d9e0
JB
594static void *
595emacs_blocked_malloc (size)
675d5130 596 size_t size;
9ac0d9e0
JB
597{
598 void *value;
599
600 BLOCK_INPUT;
601 __malloc_hook = old_malloc_hook;
1177ecf6 602#ifdef DOUG_LEA_MALLOC
d1658221 603 mallopt (M_TOP_PAD, malloc_hysteresis * 4096);
1177ecf6 604#else
d1658221 605 __malloc_extra_blocks = malloc_hysteresis;
1177ecf6 606#endif
2756d8ee 607 value = (void *) malloc (size);
b0846f52 608 __malloc_hook = emacs_blocked_malloc;
9ac0d9e0
JB
609 UNBLOCK_INPUT;
610
611 return value;
612}
613
34400008
GM
614
615/* This function is the realloc hook that Emacs uses. */
616
9ac0d9e0
JB
617static void *
618emacs_blocked_realloc (ptr, size)
619 void *ptr;
675d5130 620 size_t size;
9ac0d9e0
JB
621{
622 void *value;
623
624 BLOCK_INPUT;
625 __realloc_hook = old_realloc_hook;
2756d8ee 626 value = (void *) realloc (ptr, size);
b0846f52 627 __realloc_hook = emacs_blocked_realloc;
9ac0d9e0
JB
628 UNBLOCK_INPUT;
629
630 return value;
631}
632
34400008
GM
633
634/* Called from main to set up malloc to use our hooks. */
635
9ac0d9e0
JB
636void
637uninterrupt_malloc ()
638{
c8099634
RS
639 if (__free_hook != emacs_blocked_free)
640 old_free_hook = __free_hook;
b0846f52 641 __free_hook = emacs_blocked_free;
9ac0d9e0 642
c8099634
RS
643 if (__malloc_hook != emacs_blocked_malloc)
644 old_malloc_hook = __malloc_hook;
b0846f52 645 __malloc_hook = emacs_blocked_malloc;
9ac0d9e0 646
c8099634
RS
647 if (__realloc_hook != emacs_blocked_realloc)
648 old_realloc_hook = __realloc_hook;
b0846f52 649 __realloc_hook = emacs_blocked_realloc;
9ac0d9e0 650}
2e471eb5
GM
651
652#endif /* not SYSTEM_MALLOC */
653
654
7146af97 655\f
2e471eb5
GM
656/***********************************************************************
657 Interval Allocation
658 ***********************************************************************/
1a4f1e2c 659
34400008
GM
660/* Number of intervals allocated in an interval_block structure.
661 The 1020 is 1024 minus malloc overhead. */
662
d5e35230
JA
663#define INTERVAL_BLOCK_SIZE \
664 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
665
34400008
GM
666/* Intervals are allocated in chunks in form of an interval_block
667 structure. */
668
d5e35230 669struct interval_block
2e471eb5
GM
670{
671 struct interval_block *next;
672 struct interval intervals[INTERVAL_BLOCK_SIZE];
673};
d5e35230 674
34400008
GM
675/* Current interval block. Its `next' pointer points to older
676 blocks. */
677
d5e35230 678struct interval_block *interval_block;
34400008
GM
679
680/* Index in interval_block above of the next unused interval
681 structure. */
682
d5e35230 683static int interval_block_index;
34400008
GM
684
685/* Number of free and live intervals. */
686
2e471eb5 687static int total_free_intervals, total_intervals;
d5e35230 688
34400008
GM
689/* List of free intervals. */
690
d5e35230
JA
691INTERVAL interval_free_list;
692
c8099634 693/* Total number of interval blocks now in use. */
2e471eb5 694
c8099634
RS
695int n_interval_blocks;
696
34400008
GM
697
698/* Initialize interval allocation. */
699
d5e35230
JA
700static void
701init_intervals ()
702{
703 interval_block
34400008
GM
704 = (struct interval_block *) lisp_malloc (sizeof *interval_block,
705 MEM_TYPE_NON_LISP);
d5e35230 706 interval_block->next = 0;
290c8f1e 707 bzero ((char *) interval_block->intervals, sizeof interval_block->intervals);
d5e35230
JA
708 interval_block_index = 0;
709 interval_free_list = 0;
c8099634 710 n_interval_blocks = 1;
d5e35230
JA
711}
712
34400008
GM
713
714/* Return a new interval. */
d5e35230
JA
715
716INTERVAL
717make_interval ()
718{
719 INTERVAL val;
720
721 if (interval_free_list)
722 {
723 val = interval_free_list;
439d5cb4 724 interval_free_list = INTERVAL_PARENT (interval_free_list);
d5e35230
JA
725 }
726 else
727 {
728 if (interval_block_index == INTERVAL_BLOCK_SIZE)
729 {
3c06d205
KH
730 register struct interval_block *newi;
731
34400008
GM
732 newi = (struct interval_block *) lisp_malloc (sizeof *newi,
733 MEM_TYPE_NON_LISP);
d5e35230
JA
734
735 VALIDATE_LISP_STORAGE (newi, sizeof *newi);
736 newi->next = interval_block;
737 interval_block = newi;
738 interval_block_index = 0;
c8099634 739 n_interval_blocks++;
d5e35230
JA
740 }
741 val = &interval_block->intervals[interval_block_index++];
742 }
743 consing_since_gc += sizeof (struct interval);
310ea200 744 intervals_consed++;
d5e35230
JA
745 RESET_INTERVAL (val);
746 return val;
747}
748
34400008
GM
749
750/* Mark Lisp objects in interval I. */
d5e35230
JA
751
752static void
d393c068 753mark_interval (i, dummy)
d5e35230 754 register INTERVAL i;
d393c068 755 Lisp_Object dummy;
d5e35230
JA
756{
757 if (XMARKBIT (i->plist))
758 abort ();
759 mark_object (&i->plist);
760 XMARK (i->plist);
761}
762
34400008
GM
763
764/* Mark the interval tree rooted in TREE. Don't call this directly;
765 use the macro MARK_INTERVAL_TREE instead. */
766
d5e35230
JA
767static void
768mark_interval_tree (tree)
769 register INTERVAL tree;
770{
e8720644
JB
771 /* No need to test if this tree has been marked already; this
772 function is always called through the MARK_INTERVAL_TREE macro,
773 which takes care of that. */
774
775 /* XMARK expands to an assignment; the LHS of an assignment can't be
776 a cast. */
e0b8c689 777 XMARK (tree->up.obj);
d5e35230 778
d393c068 779 traverse_intervals (tree, 1, 0, mark_interval, Qnil);
d5e35230
JA
780}
781
34400008
GM
782
783/* Mark the interval tree rooted in I. */
784
e8720644
JB
785#define MARK_INTERVAL_TREE(i) \
786 do { \
787 if (!NULL_INTERVAL_P (i) \
e0b8c689 788 && ! XMARKBIT (i->up.obj)) \
e8720644
JB
789 mark_interval_tree (i); \
790 } while (0)
d5e35230 791
34400008 792
1a4f1e2c 793/* The oddity in the call to XUNMARK is necessary because XUNMARK
2e471eb5
GM
794 expands to an assignment to its argument, and most C compilers
795 don't support casts on the left operand of `='. */
796
797#define UNMARK_BALANCE_INTERVALS(i) \
798 do { \
799 if (! NULL_INTERVAL_P (i)) \
800 { \
e0b8c689 801 XUNMARK ((i)->up.obj); \
2e471eb5
GM
802 (i) = balance_intervals (i); \
803 } \
804 } while (0)
d5e35230 805
cc2d8c6b
KR
806\f
807/* Number support. If NO_UNION_TYPE isn't in effect, we
808 can't create number objects in macros. */
809#ifndef make_number
810Lisp_Object
811make_number (n)
812 int n;
813{
814 Lisp_Object obj;
815 obj.s.val = n;
816 obj.s.type = Lisp_Int;
817 return obj;
818}
819#endif
d5e35230 820\f
2e471eb5
GM
821/***********************************************************************
822 String Allocation
823 ***********************************************************************/
1a4f1e2c 824
2e471eb5
GM
825/* Lisp_Strings are allocated in string_block structures. When a new
826 string_block is allocated, all the Lisp_Strings it contains are
827 added to a free-list stiing_free_list. When a new Lisp_String is
828 needed, it is taken from that list. During the sweep phase of GC,
829 string_blocks that are entirely free are freed, except two which
830 we keep.
7146af97 831
2e471eb5
GM
832 String data is allocated from sblock structures. Strings larger
833 than LARGE_STRING_BYTES, get their own sblock, data for smaller
834 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
7146af97 835
2e471eb5
GM
836 Sblocks consist internally of sdata structures, one for each
837 Lisp_String. The sdata structure points to the Lisp_String it
838 belongs to. The Lisp_String points back to the `u.data' member of
839 its sdata structure.
7146af97 840
2e471eb5
GM
841 When a Lisp_String is freed during GC, it is put back on
842 string_free_list, and its `data' member and its sdata's `string'
843 pointer is set to null. The size of the string is recorded in the
844 `u.nbytes' member of the sdata. So, sdata structures that are no
845 longer used, can be easily recognized, and it's easy to compact the
846 sblocks of small strings which we do in compact_small_strings. */
7146af97 847
2e471eb5
GM
848/* Size in bytes of an sblock structure used for small strings. This
849 is 8192 minus malloc overhead. */
7146af97 850
2e471eb5 851#define SBLOCK_SIZE 8188
c8099634 852
2e471eb5
GM
853/* Strings larger than this are considered large strings. String data
854 for large strings is allocated from individual sblocks. */
7146af97 855
2e471eb5
GM
856#define LARGE_STRING_BYTES 1024
857
858/* Structure describing string memory sub-allocated from an sblock.
859 This is where the contents of Lisp strings are stored. */
860
861struct sdata
7146af97 862{
2e471eb5
GM
863 /* Back-pointer to the string this sdata belongs to. If null, this
864 structure is free, and the NBYTES member of the union below
34400008 865 contains the string's byte size (the same value that STRING_BYTES
2e471eb5
GM
866 would return if STRING were non-null). If non-null, STRING_BYTES
867 (STRING) is the size of the data, and DATA contains the string's
868 contents. */
869 struct Lisp_String *string;
7146af97 870
2e471eb5
GM
871 union
872 {
873 /* When STRING in non-null. */
874 unsigned char data[1];
875
876 /* When STRING is null. */
877 EMACS_INT nbytes;
878 } u;
879};
880
881/* Structure describing a block of memory which is sub-allocated to
882 obtain string data memory for strings. Blocks for small strings
883 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
884 as large as needed. */
885
886struct sblock
7146af97 887{
2e471eb5
GM
888 /* Next in list. */
889 struct sblock *next;
7146af97 890
2e471eb5
GM
891 /* Pointer to the next free sdata block. This points past the end
892 of the sblock if there isn't any space left in this block. */
893 struct sdata *next_free;
894
895 /* Start of data. */
896 struct sdata first_data;
897};
898
899/* Number of Lisp strings in a string_block structure. The 1020 is
900 1024 minus malloc overhead. */
901
902#define STRINGS_IN_STRING_BLOCK \
903 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
904
905/* Structure describing a block from which Lisp_String structures
906 are allocated. */
907
908struct string_block
7146af97 909{
2e471eb5
GM
910 struct string_block *next;
911 struct Lisp_String strings[STRINGS_IN_STRING_BLOCK];
912};
7146af97 913
2e471eb5
GM
914/* Head and tail of the list of sblock structures holding Lisp string
915 data. We always allocate from current_sblock. The NEXT pointers
916 in the sblock structures go from oldest_sblock to current_sblock. */
3c06d205 917
2e471eb5 918static struct sblock *oldest_sblock, *current_sblock;
7146af97 919
2e471eb5 920/* List of sblocks for large strings. */
7146af97 921
2e471eb5 922static struct sblock *large_sblocks;
7146af97 923
2e471eb5 924/* List of string_block structures, and how many there are. */
7146af97 925
2e471eb5
GM
926static struct string_block *string_blocks;
927static int n_string_blocks;
7146af97 928
2e471eb5 929/* Free-list of Lisp_Strings. */
7146af97 930
2e471eb5 931static struct Lisp_String *string_free_list;
7146af97 932
2e471eb5 933/* Number of live and free Lisp_Strings. */
c8099634 934
2e471eb5 935static int total_strings, total_free_strings;
7146af97 936
2e471eb5
GM
937/* Number of bytes used by live strings. */
938
939static int total_string_size;
940
941/* Given a pointer to a Lisp_String S which is on the free-list
942 string_free_list, return a pointer to its successor in the
943 free-list. */
944
945#define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
946
947/* Return a pointer to the sdata structure belonging to Lisp string S.
948 S must be live, i.e. S->data must not be null. S->data is actually
949 a pointer to the `u.data' member of its sdata structure; the
950 structure starts at a constant offset in front of that. */
951
952#define SDATA_OF_STRING(S) \
953 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
954
955/* Value is the size of an sdata structure large enough to hold NBYTES
956 bytes of string data. The value returned includes a terminating
957 NUL byte, the size of the sdata structure, and padding. */
958
959#define SDATA_SIZE(NBYTES) \
960 ((sizeof (struct Lisp_String *) \
961 + (NBYTES) + 1 \
962 + sizeof (EMACS_INT) - 1) \
963 & ~(sizeof (EMACS_INT) - 1))
964
965
966/* Initialize string allocation. Called from init_alloc_once. */
d457598b
AS
967
968void
2e471eb5 969init_strings ()
7146af97 970{
2e471eb5
GM
971 total_strings = total_free_strings = total_string_size = 0;
972 oldest_sblock = current_sblock = large_sblocks = NULL;
973 string_blocks = NULL;
974 n_string_blocks = 0;
975 string_free_list = NULL;
7146af97
JB
976}
977
2e471eb5
GM
978
979/* Return a new Lisp_String. */
980
981static struct Lisp_String *
982allocate_string ()
7146af97 983{
2e471eb5 984 struct Lisp_String *s;
7146af97 985
2e471eb5
GM
986 /* If the free-list is empty, allocate a new string_block, and
987 add all the Lisp_Strings in it to the free-list. */
988 if (string_free_list == NULL)
7146af97 989 {
2e471eb5
GM
990 struct string_block *b;
991 int i;
992
34400008 993 b = (struct string_block *) lisp_malloc (sizeof *b, MEM_TYPE_STRING);
2e471eb5
GM
994 VALIDATE_LISP_STORAGE (b, sizeof *b);
995 bzero (b, sizeof *b);
996 b->next = string_blocks;
997 string_blocks = b;
998 ++n_string_blocks;
999
1000 for (i = STRINGS_IN_STRING_BLOCK - 1; i >= 0; --i)
7146af97 1001 {
2e471eb5
GM
1002 s = b->strings + i;
1003 NEXT_FREE_LISP_STRING (s) = string_free_list;
1004 string_free_list = s;
7146af97 1005 }
2e471eb5
GM
1006
1007 total_free_strings += STRINGS_IN_STRING_BLOCK;
7146af97 1008 }
c0f51373 1009
2e471eb5
GM
1010 /* Pop a Lisp_String off the free-list. */
1011 s = string_free_list;
1012 string_free_list = NEXT_FREE_LISP_STRING (s);
c0f51373 1013
2e471eb5
GM
1014 /* Probably not strictly necessary, but play it safe. */
1015 bzero (s, sizeof *s);
c0f51373 1016
2e471eb5
GM
1017 --total_free_strings;
1018 ++total_strings;
1019 ++strings_consed;
1020 consing_since_gc += sizeof *s;
c0f51373 1021
2e471eb5 1022 return s;
c0f51373 1023}
7146af97 1024
7146af97 1025
2e471eb5
GM
1026/* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1027 plus a NUL byte at the end. Allocate an sdata structure for S, and
1028 set S->data to its `u.data' member. Store a NUL byte at the end of
1029 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1030 S->data if it was initially non-null. */
7146af97 1031
2e471eb5
GM
1032void
1033allocate_string_data (s, nchars, nbytes)
1034 struct Lisp_String *s;
1035 int nchars, nbytes;
7146af97 1036{
5c5fecb3 1037 struct sdata *data, *old_data;
2e471eb5 1038 struct sblock *b;
5c5fecb3 1039 int needed, old_nbytes;
7146af97 1040
2e471eb5
GM
1041 /* Determine the number of bytes needed to store NBYTES bytes
1042 of string data. */
1043 needed = SDATA_SIZE (nbytes);
7146af97 1044
2e471eb5
GM
1045 if (nbytes > LARGE_STRING_BYTES)
1046 {
675d5130 1047 size_t size = sizeof *b - sizeof (struct sdata) + needed;
2e471eb5
GM
1048
1049#ifdef DOUG_LEA_MALLOC
f8608968
GM
1050 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1051 because mapped region contents are not preserved in
1052 a dumped Emacs. */
2e471eb5
GM
1053 mallopt (M_MMAP_MAX, 0);
1054#endif
1055
34400008 1056 b = (struct sblock *) lisp_malloc (size, MEM_TYPE_NON_LISP);
2e471eb5
GM
1057
1058#ifdef DOUG_LEA_MALLOC
1059 /* Back to a reasonable maximum of mmap'ed areas. */
1060 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
1061#endif
1062
1063 b->next_free = &b->first_data;
1064 b->first_data.string = NULL;
1065 b->next = large_sblocks;
1066 large_sblocks = b;
1067 }
1068 else if (current_sblock == NULL
1069 || (((char *) current_sblock + SBLOCK_SIZE
1070 - (char *) current_sblock->next_free)
1071 < needed))
1072 {
1073 /* Not enough room in the current sblock. */
34400008 1074 b = (struct sblock *) lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
2e471eb5
GM
1075 b->next_free = &b->first_data;
1076 b->first_data.string = NULL;
1077 b->next = NULL;
1078
1079 if (current_sblock)
1080 current_sblock->next = b;
1081 else
1082 oldest_sblock = b;
1083 current_sblock = b;
1084 }
1085 else
1086 b = current_sblock;
5c5fecb3
GM
1087
1088 old_data = s->data ? SDATA_OF_STRING (s) : NULL;
1089 old_nbytes = GC_STRING_BYTES (s);
2e471eb5
GM
1090
1091 data = b->next_free;
1092 data->string = s;
1093 s->data = data->u.data;
1094 s->size = nchars;
1095 s->size_byte = nbytes;
1096 s->data[nbytes] = '\0';
1097 b->next_free = (struct sdata *) ((char *) data + needed);
1098
5c5fecb3
GM
1099 /* If S had already data assigned, mark that as free by setting its
1100 string back-pointer to null, and recording the size of the data
00c9c33c 1101 in it. */
5c5fecb3
GM
1102 if (old_data)
1103 {
5c5fecb3
GM
1104 old_data->u.nbytes = old_nbytes;
1105 old_data->string = NULL;
1106 }
1107
2e471eb5
GM
1108 consing_since_gc += needed;
1109}
1110
1111
1112/* Sweep and compact strings. */
1113
1114static void
1115sweep_strings ()
1116{
1117 struct string_block *b, *next;
1118 struct string_block *live_blocks = NULL;
1119
1120 string_free_list = NULL;
1121 total_strings = total_free_strings = 0;
1122 total_string_size = 0;
1123
1124 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1125 for (b = string_blocks; b; b = next)
1126 {
1127 int i, nfree = 0;
1128 struct Lisp_String *free_list_before = string_free_list;
1129
1130 next = b->next;
1131
1132 for (i = 0; i < STRINGS_IN_STRING_BLOCK; ++i)
1133 {
1134 struct Lisp_String *s = b->strings + i;
1135
1136 if (s->data)
1137 {
1138 /* String was not on free-list before. */
1139 if (STRING_MARKED_P (s))
1140 {
1141 /* String is live; unmark it and its intervals. */
1142 UNMARK_STRING (s);
1143
1144 if (!NULL_INTERVAL_P (s->intervals))
1145 UNMARK_BALANCE_INTERVALS (s->intervals);
1146
1147 ++total_strings;
1148 total_string_size += STRING_BYTES (s);
1149 }
1150 else
1151 {
1152 /* String is dead. Put it on the free-list. */
1153 struct sdata *data = SDATA_OF_STRING (s);
1154
1155 /* Save the size of S in its sdata so that we know
1156 how large that is. Reset the sdata's string
1157 back-pointer so that we know it's free. */
1158 data->u.nbytes = GC_STRING_BYTES (s);
1159 data->string = NULL;
1160
1161 /* Reset the strings's `data' member so that we
1162 know it's free. */
1163 s->data = NULL;
1164
1165 /* Put the string on the free-list. */
1166 NEXT_FREE_LISP_STRING (s) = string_free_list;
1167 string_free_list = s;
1168 ++nfree;
1169 }
1170 }
1171 else
1172 {
1173 /* S was on the free-list before. Put it there again. */
1174 NEXT_FREE_LISP_STRING (s) = string_free_list;
1175 string_free_list = s;
1176 ++nfree;
1177 }
1178 }
1179
34400008 1180 /* Free blocks that contain free Lisp_Strings only, except
2e471eb5
GM
1181 the first two of them. */
1182 if (nfree == STRINGS_IN_STRING_BLOCK
1183 && total_free_strings > STRINGS_IN_STRING_BLOCK)
1184 {
1185 lisp_free (b);
1186 --n_string_blocks;
1187 string_free_list = free_list_before;
1188 }
1189 else
1190 {
1191 total_free_strings += nfree;
1192 b->next = live_blocks;
1193 live_blocks = b;
1194 }
1195 }
1196
1197 string_blocks = live_blocks;
1198 free_large_strings ();
1199 compact_small_strings ();
1200}
1201
1202
1203/* Free dead large strings. */
1204
1205static void
1206free_large_strings ()
1207{
1208 struct sblock *b, *next;
1209 struct sblock *live_blocks = NULL;
1210
1211 for (b = large_sblocks; b; b = next)
1212 {
1213 next = b->next;
1214
1215 if (b->first_data.string == NULL)
1216 lisp_free (b);
1217 else
1218 {
1219 b->next = live_blocks;
1220 live_blocks = b;
1221 }
1222 }
1223
1224 large_sblocks = live_blocks;
1225}
1226
1227
1228/* Compact data of small strings. Free sblocks that don't contain
1229 data of live strings after compaction. */
1230
1231static void
1232compact_small_strings ()
1233{
1234 struct sblock *b, *tb, *next;
1235 struct sdata *from, *to, *end, *tb_end;
1236 struct sdata *to_end, *from_end;
1237
1238 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1239 to, and TB_END is the end of TB. */
1240 tb = oldest_sblock;
1241 tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
1242 to = &tb->first_data;
1243
1244 /* Step through the blocks from the oldest to the youngest. We
1245 expect that old blocks will stabilize over time, so that less
1246 copying will happen this way. */
1247 for (b = oldest_sblock; b; b = b->next)
1248 {
1249 end = b->next_free;
1250 xassert ((char *) end <= (char *) b + SBLOCK_SIZE);
1251
1252 for (from = &b->first_data; from < end; from = from_end)
1253 {
1254 /* Compute the next FROM here because copying below may
1255 overwrite data we need to compute it. */
1256 int nbytes;
1257
1258 if (from->string)
1259 nbytes = GC_STRING_BYTES (from->string);
1260 else
1261 nbytes = from->u.nbytes;
1262
1263 nbytes = SDATA_SIZE (nbytes);
1264 from_end = (struct sdata *) ((char *) from + nbytes);
1265
1266 /* FROM->string non-null means it's alive. Copy its data. */
1267 if (from->string)
1268 {
1269 /* If TB is full, proceed with the next sblock. */
1270 to_end = (struct sdata *) ((char *) to + nbytes);
1271 if (to_end > tb_end)
1272 {
1273 tb->next_free = to;
1274 tb = tb->next;
1275 tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
1276 to = &tb->first_data;
1277 to_end = (struct sdata *) ((char *) to + nbytes);
1278 }
1279
1280 /* Copy, and update the string's `data' pointer. */
1281 if (from != to)
1282 {
a2407477
GM
1283 xassert (tb != b || to <= from);
1284 safe_bcopy ((char *) from, (char *) to, nbytes);
2e471eb5
GM
1285 to->string->data = to->u.data;
1286 }
1287
1288 /* Advance past the sdata we copied to. */
1289 to = to_end;
1290 }
1291 }
1292 }
1293
1294 /* The rest of the sblocks following TB don't contain live data, so
1295 we can free them. */
1296 for (b = tb->next; b; b = next)
1297 {
1298 next = b->next;
1299 lisp_free (b);
1300 }
1301
1302 tb->next_free = to;
1303 tb->next = NULL;
1304 current_sblock = tb;
1305}
1306
1307
1308DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
1309 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1310Both LENGTH and INIT must be numbers.")
1311 (length, init)
1312 Lisp_Object length, init;
1313{
1314 register Lisp_Object val;
1315 register unsigned char *p, *end;
1316 int c, nbytes;
1317
1318 CHECK_NATNUM (length, 0);
1319 CHECK_NUMBER (init, 1);
1320
1321 c = XINT (init);
1322 if (SINGLE_BYTE_CHAR_P (c))
1323 {
1324 nbytes = XINT (length);
1325 val = make_uninit_string (nbytes);
1326 p = XSTRING (val)->data;
1327 end = p + XSTRING (val)->size;
1328 while (p != end)
1329 *p++ = c;
1330 }
1331 else
1332 {
1333 unsigned char str[4];
1334 int len = CHAR_STRING (c, str);
1335
1336 nbytes = len * XINT (length);
1337 val = make_uninit_multibyte_string (XINT (length), nbytes);
1338 p = XSTRING (val)->data;
1339 end = p + nbytes;
1340 while (p != end)
1341 {
1342 bcopy (str, p, len);
1343 p += len;
1344 }
1345 }
1346
1347 *p = 0;
1348 return val;
1349}
1350
1351
1352DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
1353 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1354LENGTH must be a number. INIT matters only in whether it is t or nil.")
1355 (length, init)
1356 Lisp_Object length, init;
1357{
1358 register Lisp_Object val;
1359 struct Lisp_Bool_Vector *p;
1360 int real_init, i;
1361 int length_in_chars, length_in_elts, bits_per_value;
1362
1363 CHECK_NATNUM (length, 0);
1364
1365 bits_per_value = sizeof (EMACS_INT) * BITS_PER_CHAR;
1366
1367 length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
1368 length_in_chars = ((XFASTINT (length) + BITS_PER_CHAR - 1) / BITS_PER_CHAR);
1369
1370 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1371 slot `size' of the struct Lisp_Bool_Vector. */
1372 val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
1373 p = XBOOL_VECTOR (val);
34400008 1374
2e471eb5
GM
1375 /* Get rid of any bits that would cause confusion. */
1376 p->vector_size = 0;
1377 XSETBOOL_VECTOR (val, p);
1378 p->size = XFASTINT (length);
1379
1380 real_init = (NILP (init) ? 0 : -1);
1381 for (i = 0; i < length_in_chars ; i++)
1382 p->data[i] = real_init;
34400008 1383
2e471eb5
GM
1384 /* Clear the extraneous bits in the last byte. */
1385 if (XINT (length) != length_in_chars * BITS_PER_CHAR)
1386 XBOOL_VECTOR (val)->data[length_in_chars - 1]
1387 &= (1 << (XINT (length) % BITS_PER_CHAR)) - 1;
1388
1389 return val;
1390}
1391
1392
1393/* Make a string from NBYTES bytes at CONTENTS, and compute the number
1394 of characters from the contents. This string may be unibyte or
1395 multibyte, depending on the contents. */
1396
1397Lisp_Object
1398make_string (contents, nbytes)
1399 char *contents;
1400 int nbytes;
1401{
1402 register Lisp_Object val;
9eac9d59
KH
1403 int nchars, multibyte_nbytes;
1404
1405 parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes);
2e471eb5
GM
1406 val = make_uninit_multibyte_string (nchars, nbytes);
1407 bcopy (contents, XSTRING (val)->data, nbytes);
9eac9d59
KH
1408 if (nbytes == nchars || nbytes != multibyte_nbytes)
1409 /* CONTENTS contains no multibyte sequences or contains an invalid
1410 multibyte sequence. We must make unibyte string. */
2e471eb5
GM
1411 SET_STRING_BYTES (XSTRING (val), -1);
1412 return val;
1413}
1414
1415
1416/* Make an unibyte string from LENGTH bytes at CONTENTS. */
1417
1418Lisp_Object
1419make_unibyte_string (contents, length)
1420 char *contents;
1421 int length;
1422{
1423 register Lisp_Object val;
1424 val = make_uninit_string (length);
1425 bcopy (contents, XSTRING (val)->data, length);
1426 SET_STRING_BYTES (XSTRING (val), -1);
1427 return val;
1428}
1429
1430
1431/* Make a multibyte string from NCHARS characters occupying NBYTES
1432 bytes at CONTENTS. */
1433
1434Lisp_Object
1435make_multibyte_string (contents, nchars, nbytes)
1436 char *contents;
1437 int nchars, nbytes;
1438{
1439 register Lisp_Object val;
1440 val = make_uninit_multibyte_string (nchars, nbytes);
1441 bcopy (contents, XSTRING (val)->data, nbytes);
1442 return val;
1443}
1444
1445
1446/* Make a string from NCHARS characters occupying NBYTES bytes at
1447 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
1448
1449Lisp_Object
1450make_string_from_bytes (contents, nchars, nbytes)
1451 char *contents;
1452 int nchars, nbytes;
1453{
1454 register Lisp_Object val;
1455 val = make_uninit_multibyte_string (nchars, nbytes);
1456 bcopy (contents, XSTRING (val)->data, nbytes);
1457 if (STRING_BYTES (XSTRING (val)) == XSTRING (val)->size)
1458 SET_STRING_BYTES (XSTRING (val), -1);
1459 return val;
1460}
1461
1462
1463/* Make a string from NCHARS characters occupying NBYTES bytes at
1464 CONTENTS. The argument MULTIBYTE controls whether to label the
1465 string as multibyte. */
1466
1467Lisp_Object
1468make_specified_string (contents, nchars, nbytes, multibyte)
1469 char *contents;
1470 int nchars, nbytes;
1471 int multibyte;
1472{
1473 register Lisp_Object val;
1474 val = make_uninit_multibyte_string (nchars, nbytes);
1475 bcopy (contents, XSTRING (val)->data, nbytes);
1476 if (!multibyte)
1477 SET_STRING_BYTES (XSTRING (val), -1);
1478 return val;
1479}
1480
1481
1482/* Make a string from the data at STR, treating it as multibyte if the
1483 data warrants. */
1484
1485Lisp_Object
1486build_string (str)
1487 char *str;
1488{
1489 return make_string (str, strlen (str));
1490}
1491
1492
1493/* Return an unibyte Lisp_String set up to hold LENGTH characters
1494 occupying LENGTH bytes. */
1495
1496Lisp_Object
1497make_uninit_string (length)
1498 int length;
1499{
1500 Lisp_Object val;
1501 val = make_uninit_multibyte_string (length, length);
1502 SET_STRING_BYTES (XSTRING (val), -1);
1503 return val;
1504}
1505
1506
1507/* Return a multibyte Lisp_String set up to hold NCHARS characters
1508 which occupy NBYTES bytes. */
1509
1510Lisp_Object
1511make_uninit_multibyte_string (nchars, nbytes)
1512 int nchars, nbytes;
1513{
1514 Lisp_Object string;
1515 struct Lisp_String *s;
1516
1517 if (nchars < 0)
1518 abort ();
1519
1520 s = allocate_string ();
1521 allocate_string_data (s, nchars, nbytes);
1522 XSETSTRING (string, s);
1523 string_chars_consed += nbytes;
1524 return string;
1525}
1526
1527
1528\f
1529/***********************************************************************
1530 Float Allocation
1531 ***********************************************************************/
1532
2e471eb5
GM
1533/* We store float cells inside of float_blocks, allocating a new
1534 float_block with malloc whenever necessary. Float cells reclaimed
1535 by GC are put on a free list to be reallocated before allocating
1536 any new float cells from the latest float_block.
1537
1538 Each float_block is just under 1020 bytes long, since malloc really
1539 allocates in units of powers of two and uses 4 bytes for its own
1540 overhead. */
1541
1542#define FLOAT_BLOCK_SIZE \
1543 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
1544
1545struct float_block
1546{
1547 struct float_block *next;
1548 struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
1549};
1550
34400008
GM
1551/* Current float_block. */
1552
2e471eb5 1553struct float_block *float_block;
34400008
GM
1554
1555/* Index of first unused Lisp_Float in the current float_block. */
1556
2e471eb5
GM
1557int float_block_index;
1558
1559/* Total number of float blocks now in use. */
1560
1561int n_float_blocks;
1562
34400008
GM
1563/* Free-list of Lisp_Floats. */
1564
2e471eb5
GM
1565struct Lisp_Float *float_free_list;
1566
34400008
GM
1567
1568/* Initialze float allocation. */
1569
2e471eb5
GM
1570void
1571init_float ()
1572{
34400008
GM
1573 float_block = (struct float_block *) lisp_malloc (sizeof *float_block,
1574 MEM_TYPE_FLOAT);
2e471eb5
GM
1575 float_block->next = 0;
1576 bzero ((char *) float_block->floats, sizeof float_block->floats);
1577 float_block_index = 0;
1578 float_free_list = 0;
1579 n_float_blocks = 1;
1580}
1581
34400008
GM
1582
1583/* Explicitly free a float cell by putting it on the free-list. */
2e471eb5
GM
1584
1585void
1586free_float (ptr)
1587 struct Lisp_Float *ptr;
1588{
1589 *(struct Lisp_Float **)&ptr->data = float_free_list;
34400008
GM
1590#if GC_MARK_STACK
1591 ptr->type = Vdead;
1592#endif
2e471eb5
GM
1593 float_free_list = ptr;
1594}
1595
34400008
GM
1596
1597/* Return a new float object with value FLOAT_VALUE. */
1598
2e471eb5
GM
1599Lisp_Object
1600make_float (float_value)
1601 double float_value;
1602{
1603 register Lisp_Object val;
1604
1605 if (float_free_list)
1606 {
1607 /* We use the data field for chaining the free list
1608 so that we won't use the same field that has the mark bit. */
1609 XSETFLOAT (val, float_free_list);
1610 float_free_list = *(struct Lisp_Float **)&float_free_list->data;
1611 }
1612 else
1613 {
1614 if (float_block_index == FLOAT_BLOCK_SIZE)
1615 {
1616 register struct float_block *new;
1617
34400008
GM
1618 new = (struct float_block *) lisp_malloc (sizeof *new,
1619 MEM_TYPE_FLOAT);
2e471eb5
GM
1620 VALIDATE_LISP_STORAGE (new, sizeof *new);
1621 new->next = float_block;
1622 float_block = new;
1623 float_block_index = 0;
1624 n_float_blocks++;
1625 }
1626 XSETFLOAT (val, &float_block->floats[float_block_index++]);
1627 }
1628
1629 XFLOAT_DATA (val) = float_value;
1630 XSETFASTINT (XFLOAT (val)->type, 0); /* bug chasing -wsr */
1631 consing_since_gc += sizeof (struct Lisp_Float);
1632 floats_consed++;
1633 return val;
1634}
1635
2e471eb5
GM
1636
1637\f
1638/***********************************************************************
1639 Cons Allocation
1640 ***********************************************************************/
1641
1642/* We store cons cells inside of cons_blocks, allocating a new
1643 cons_block with malloc whenever necessary. Cons cells reclaimed by
1644 GC are put on a free list to be reallocated before allocating
1645 any new cons cells from the latest cons_block.
1646
1647 Each cons_block is just under 1020 bytes long,
1648 since malloc really allocates in units of powers of two
1649 and uses 4 bytes for its own overhead. */
1650
1651#define CONS_BLOCK_SIZE \
1652 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
1653
1654struct cons_block
1655{
1656 struct cons_block *next;
1657 struct Lisp_Cons conses[CONS_BLOCK_SIZE];
1658};
1659
34400008
GM
1660/* Current cons_block. */
1661
2e471eb5 1662struct cons_block *cons_block;
34400008
GM
1663
1664/* Index of first unused Lisp_Cons in the current block. */
1665
2e471eb5
GM
1666int cons_block_index;
1667
34400008
GM
1668/* Free-list of Lisp_Cons structures. */
1669
2e471eb5
GM
1670struct Lisp_Cons *cons_free_list;
1671
1672/* Total number of cons blocks now in use. */
1673
1674int n_cons_blocks;
1675
34400008
GM
1676
1677/* Initialize cons allocation. */
1678
2e471eb5
GM
1679void
1680init_cons ()
1681{
34400008
GM
1682 cons_block = (struct cons_block *) lisp_malloc (sizeof *cons_block,
1683 MEM_TYPE_CONS);
2e471eb5
GM
1684 cons_block->next = 0;
1685 bzero ((char *) cons_block->conses, sizeof cons_block->conses);
1686 cons_block_index = 0;
1687 cons_free_list = 0;
1688 n_cons_blocks = 1;
1689}
1690
34400008
GM
1691
1692/* Explicitly free a cons cell by putting it on the free-list. */
2e471eb5
GM
1693
1694void
1695free_cons (ptr)
1696 struct Lisp_Cons *ptr;
1697{
1698 *(struct Lisp_Cons **)&ptr->cdr = cons_free_list;
34400008
GM
1699#if GC_MARK_STACK
1700 ptr->car = Vdead;
1701#endif
2e471eb5
GM
1702 cons_free_list = ptr;
1703}
1704
34400008 1705
2e471eb5
GM
1706DEFUN ("cons", Fcons, Scons, 2, 2, 0,
1707 "Create a new cons, give it CAR and CDR as components, and return it.")
1708 (car, cdr)
1709 Lisp_Object car, cdr;
1710{
1711 register Lisp_Object val;
1712
1713 if (cons_free_list)
1714 {
1715 /* We use the cdr for chaining the free list
1716 so that we won't use the same field that has the mark bit. */
1717 XSETCONS (val, cons_free_list);
1718 cons_free_list = *(struct Lisp_Cons **)&cons_free_list->cdr;
1719 }
1720 else
1721 {
1722 if (cons_block_index == CONS_BLOCK_SIZE)
1723 {
1724 register struct cons_block *new;
34400008
GM
1725 new = (struct cons_block *) lisp_malloc (sizeof *new,
1726 MEM_TYPE_CONS);
2e471eb5
GM
1727 VALIDATE_LISP_STORAGE (new, sizeof *new);
1728 new->next = cons_block;
1729 cons_block = new;
1730 cons_block_index = 0;
1731 n_cons_blocks++;
1732 }
1733 XSETCONS (val, &cons_block->conses[cons_block_index++]);
1734 }
1735
1736 XCAR (val) = car;
1737 XCDR (val) = cdr;
1738 consing_since_gc += sizeof (struct Lisp_Cons);
1739 cons_cells_consed++;
1740 return val;
1741}
1742
34400008 1743
2e471eb5
GM
1744/* Make a list of 2, 3, 4 or 5 specified objects. */
1745
1746Lisp_Object
1747list2 (arg1, arg2)
1748 Lisp_Object arg1, arg2;
1749{
1750 return Fcons (arg1, Fcons (arg2, Qnil));
1751}
1752
34400008 1753
2e471eb5
GM
1754Lisp_Object
1755list3 (arg1, arg2, arg3)
1756 Lisp_Object arg1, arg2, arg3;
1757{
1758 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
1759}
1760
34400008 1761
2e471eb5
GM
1762Lisp_Object
1763list4 (arg1, arg2, arg3, arg4)
1764 Lisp_Object arg1, arg2, arg3, arg4;
1765{
1766 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil))));
1767}
1768
34400008 1769
2e471eb5
GM
1770Lisp_Object
1771list5 (arg1, arg2, arg3, arg4, arg5)
1772 Lisp_Object arg1, arg2, arg3, arg4, arg5;
1773{
1774 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
1775 Fcons (arg5, Qnil)))));
1776}
1777
34400008 1778
2e471eb5
GM
1779DEFUN ("list", Flist, Slist, 0, MANY, 0,
1780 "Return a newly created list with specified arguments as elements.\n\
1781Any number of arguments, even zero arguments, are allowed.")
1782 (nargs, args)
1783 int nargs;
1784 register Lisp_Object *args;
1785{
1786 register Lisp_Object val;
1787 val = Qnil;
1788
1789 while (nargs > 0)
1790 {
1791 nargs--;
1792 val = Fcons (args[nargs], val);
1793 }
1794 return val;
1795}
1796
34400008 1797
2e471eb5
GM
1798DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
1799 "Return a newly created list of length LENGTH, with each element being INIT.")
1800 (length, init)
1801 register Lisp_Object length, init;
1802{
1803 register Lisp_Object val;
1804 register int size;
1805
1806 CHECK_NATNUM (length, 0);
1807 size = XFASTINT (length);
1808
1809 val = Qnil;
7146af97
JB
1810 while (size-- > 0)
1811 val = Fcons (init, val);
1812 return val;
1813}
2e471eb5
GM
1814
1815
7146af97 1816\f
2e471eb5
GM
1817/***********************************************************************
1818 Vector Allocation
1819 ***********************************************************************/
7146af97 1820
34400008
GM
1821/* Singly-linked list of all vectors. */
1822
7146af97
JB
1823struct Lisp_Vector *all_vectors;
1824
2e471eb5
GM
1825/* Total number of vector-like objects now in use. */
1826
c8099634
RS
1827int n_vectors;
1828
34400008
GM
1829
1830/* Value is a pointer to a newly allocated Lisp_Vector structure
1831 with room for LEN Lisp_Objects. */
1832
1825c68d
KH
1833struct Lisp_Vector *
1834allocate_vectorlike (len)
1835 EMACS_INT len;
1836{
1837 struct Lisp_Vector *p;
675d5130 1838 size_t nbytes;
1825c68d 1839
d1658221 1840#ifdef DOUG_LEA_MALLOC
f8608968
GM
1841 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1842 because mapped region contents are not preserved in
1843 a dumped Emacs. */
d1658221
RS
1844 mallopt (M_MMAP_MAX, 0);
1845#endif
34400008
GM
1846
1847 nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
1848 p = (struct Lisp_Vector *) lisp_malloc (nbytes, MEM_TYPE_VECTOR);
1849
d1658221 1850#ifdef DOUG_LEA_MALLOC
34400008 1851 /* Back to a reasonable maximum of mmap'ed areas. */
81d492d5 1852 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
d1658221 1853#endif
34400008 1854
1825c68d 1855 VALIDATE_LISP_STORAGE (p, 0);
34400008 1856 consing_since_gc += nbytes;
310ea200 1857 vector_cells_consed += len;
1825c68d
KH
1858
1859 p->next = all_vectors;
1860 all_vectors = p;
34400008 1861 ++n_vectors;
1825c68d
KH
1862 return p;
1863}
1864
34400008 1865
7146af97
JB
1866DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
1867 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
1868See also the function `vector'.")
1869 (length, init)
1870 register Lisp_Object length, init;
1871{
1825c68d
KH
1872 Lisp_Object vector;
1873 register EMACS_INT sizei;
1874 register int index;
7146af97
JB
1875 register struct Lisp_Vector *p;
1876
c9dad5ed
KH
1877 CHECK_NATNUM (length, 0);
1878 sizei = XFASTINT (length);
7146af97 1879
1825c68d 1880 p = allocate_vectorlike (sizei);
7146af97 1881 p->size = sizei;
7146af97
JB
1882 for (index = 0; index < sizei; index++)
1883 p->contents[index] = init;
1884
1825c68d 1885 XSETVECTOR (vector, p);
7146af97
JB
1886 return vector;
1887}
1888
34400008 1889
a59de17b 1890DEFUN ("make-char-table", Fmake_char_table, Smake_char_table, 1, 2, 0,
c58b2b4d 1891 "Return a newly created char-table, with purpose PURPOSE.\n\
7b07587b 1892Each element is initialized to INIT, which defaults to nil.\n\
d7cd5d4f 1893PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
a59de17b
RS
1894The property's value should be an integer between 0 and 10.")
1895 (purpose, init)
1896 register Lisp_Object purpose, init;
7b07587b
RS
1897{
1898 Lisp_Object vector;
a59de17b
RS
1899 Lisp_Object n;
1900 CHECK_SYMBOL (purpose, 1);
0551bde3 1901 n = Fget (purpose, Qchar_table_extra_slots);
a59de17b 1902 CHECK_NUMBER (n, 0);
7b07587b
RS
1903 if (XINT (n) < 0 || XINT (n) > 10)
1904 args_out_of_range (n, Qnil);
1905 /* Add 2 to the size for the defalt and parent slots. */
1906 vector = Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS + XINT (n)),
1907 init);
0551bde3 1908 XCHAR_TABLE (vector)->top = Qt;
c96a008c 1909 XCHAR_TABLE (vector)->parent = Qnil;
a59de17b 1910 XCHAR_TABLE (vector)->purpose = purpose;
7b07587b
RS
1911 XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
1912 return vector;
1913}
1914
34400008 1915
0551bde3
KH
1916/* Return a newly created sub char table with default value DEFALT.
1917 Since a sub char table does not appear as a top level Emacs Lisp
1918 object, we don't need a Lisp interface to make it. */
1919
1920Lisp_Object
1921make_sub_char_table (defalt)
1922 Lisp_Object defalt;
1923{
1924 Lisp_Object vector
1925 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS), Qnil);
1926 XCHAR_TABLE (vector)->top = Qnil;
1927 XCHAR_TABLE (vector)->defalt = defalt;
1928 XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
1929 return vector;
1930}
1931
34400008 1932
7146af97
JB
1933DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
1934 "Return a newly created vector with specified arguments as elements.\n\
1935Any number of arguments, even zero arguments, are allowed.")
1936 (nargs, args)
1937 register int nargs;
1938 Lisp_Object *args;
1939{
1940 register Lisp_Object len, val;
1941 register int index;
1942 register struct Lisp_Vector *p;
1943
67ba9986 1944 XSETFASTINT (len, nargs);
7146af97
JB
1945 val = Fmake_vector (len, Qnil);
1946 p = XVECTOR (val);
1947 for (index = 0; index < nargs; index++)
1948 p->contents[index] = args[index];
1949 return val;
1950}
1951
34400008 1952
7146af97
JB
1953DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
1954 "Create a byte-code object with specified arguments as elements.\n\
1955The arguments should be the arglist, bytecode-string, constant vector,\n\
1956stack size, (optional) doc string, and (optional) interactive spec.\n\
1957The first four arguments are required; at most six have any\n\
1958significance.")
1959 (nargs, args)
1960 register int nargs;
1961 Lisp_Object *args;
1962{
1963 register Lisp_Object len, val;
1964 register int index;
1965 register struct Lisp_Vector *p;
1966
67ba9986 1967 XSETFASTINT (len, nargs);
265a9e55 1968 if (!NILP (Vpurify_flag))
5a053ea9 1969 val = make_pure_vector ((EMACS_INT) nargs);
7146af97
JB
1970 else
1971 val = Fmake_vector (len, Qnil);
9eac9d59
KH
1972
1973 if (STRINGP (args[1]) && STRING_MULTIBYTE (args[1]))
1974 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
1975 earlier because they produced a raw 8-bit string for byte-code
1976 and now such a byte-code string is loaded as multibyte while
1977 raw 8-bit characters converted to multibyte form. Thus, now we
1978 must convert them back to the original unibyte form. */
1979 args[1] = Fstring_as_unibyte (args[1]);
1980
7146af97
JB
1981 p = XVECTOR (val);
1982 for (index = 0; index < nargs; index++)
1983 {
265a9e55 1984 if (!NILP (Vpurify_flag))
7146af97
JB
1985 args[index] = Fpurecopy (args[index]);
1986 p->contents[index] = args[index];
1987 }
50aee051 1988 XSETCOMPILED (val, p);
7146af97
JB
1989 return val;
1990}
2e471eb5 1991
34400008 1992
7146af97 1993\f
2e471eb5
GM
1994/***********************************************************************
1995 Symbol Allocation
1996 ***********************************************************************/
7146af97 1997
2e471eb5
GM
1998/* Each symbol_block is just under 1020 bytes long, since malloc
1999 really allocates in units of powers of two and uses 4 bytes for its
2000 own overhead. */
7146af97
JB
2001
2002#define SYMBOL_BLOCK_SIZE \
2003 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
2004
2005struct symbol_block
2e471eb5
GM
2006{
2007 struct symbol_block *next;
2008 struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
2009};
7146af97 2010
34400008
GM
2011/* Current symbol block and index of first unused Lisp_Symbol
2012 structure in it. */
2013
7146af97
JB
2014struct symbol_block *symbol_block;
2015int symbol_block_index;
2016
34400008
GM
2017/* List of free symbols. */
2018
7146af97
JB
2019struct Lisp_Symbol *symbol_free_list;
2020
c8099634 2021/* Total number of symbol blocks now in use. */
2e471eb5 2022
c8099634
RS
2023int n_symbol_blocks;
2024
34400008
GM
2025
2026/* Initialize symbol allocation. */
2027
7146af97
JB
2028void
2029init_symbol ()
2030{
34400008
GM
2031 symbol_block = (struct symbol_block *) lisp_malloc (sizeof *symbol_block,
2032 MEM_TYPE_SYMBOL);
7146af97 2033 symbol_block->next = 0;
290c8f1e 2034 bzero ((char *) symbol_block->symbols, sizeof symbol_block->symbols);
7146af97
JB
2035 symbol_block_index = 0;
2036 symbol_free_list = 0;
c8099634 2037 n_symbol_blocks = 1;
7146af97
JB
2038}
2039
34400008 2040
7146af97
JB
2041DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
2042 "Return a newly allocated uninterned symbol whose name is NAME.\n\
2043Its value and function definition are void, and its property list is nil.")
54ee42dd
EN
2044 (name)
2045 Lisp_Object name;
7146af97
JB
2046{
2047 register Lisp_Object val;
2048 register struct Lisp_Symbol *p;
2049
54ee42dd 2050 CHECK_STRING (name, 0);
7146af97
JB
2051
2052 if (symbol_free_list)
2053 {
45d12a89 2054 XSETSYMBOL (val, symbol_free_list);
85481507 2055 symbol_free_list = *(struct Lisp_Symbol **)&symbol_free_list->value;
7146af97
JB
2056 }
2057 else
2058 {
2059 if (symbol_block_index == SYMBOL_BLOCK_SIZE)
2060 {
3c06d205 2061 struct symbol_block *new;
34400008
GM
2062 new = (struct symbol_block *) lisp_malloc (sizeof *new,
2063 MEM_TYPE_SYMBOL);
7146af97
JB
2064 VALIDATE_LISP_STORAGE (new, sizeof *new);
2065 new->next = symbol_block;
2066 symbol_block = new;
2067 symbol_block_index = 0;
c8099634 2068 n_symbol_blocks++;
7146af97 2069 }
45d12a89 2070 XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index++]);
7146af97 2071 }
2e471eb5 2072
7146af97 2073 p = XSYMBOL (val);
636b7260 2074 p->name = XSTRING (name);
47d5b31e 2075 p->obarray = Qnil;
7146af97 2076 p->plist = Qnil;
2e471eb5
GM
2077 p->value = Qunbound;
2078 p->function = Qunbound;
2079 p->next = 0;
2080 consing_since_gc += sizeof (struct Lisp_Symbol);
2081 symbols_consed++;
7146af97
JB
2082 return val;
2083}
2084
3f25e183 2085
2e471eb5
GM
2086\f
2087/***********************************************************************
34400008 2088 Marker (Misc) Allocation
2e471eb5 2089 ***********************************************************************/
3f25e183 2090
2e471eb5
GM
2091/* Allocation of markers and other objects that share that structure.
2092 Works like allocation of conses. */
c0696668 2093
2e471eb5
GM
2094#define MARKER_BLOCK_SIZE \
2095 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
2096
2097struct marker_block
c0696668 2098{
2e471eb5
GM
2099 struct marker_block *next;
2100 union Lisp_Misc markers[MARKER_BLOCK_SIZE];
2101};
c0696668 2102
2e471eb5
GM
2103struct marker_block *marker_block;
2104int marker_block_index;
c0696668 2105
2e471eb5 2106union Lisp_Misc *marker_free_list;
c0696668 2107
2e471eb5 2108/* Total number of marker blocks now in use. */
3f25e183 2109
2e471eb5
GM
2110int n_marker_blocks;
2111
2112void
2113init_marker ()
3f25e183 2114{
34400008
GM
2115 marker_block = (struct marker_block *) lisp_malloc (sizeof *marker_block,
2116 MEM_TYPE_MISC);
2e471eb5
GM
2117 marker_block->next = 0;
2118 bzero ((char *) marker_block->markers, sizeof marker_block->markers);
2119 marker_block_index = 0;
2120 marker_free_list = 0;
2121 n_marker_blocks = 1;
3f25e183
RS
2122}
2123
2e471eb5
GM
2124/* Return a newly allocated Lisp_Misc object, with no substructure. */
2125
3f25e183 2126Lisp_Object
2e471eb5 2127allocate_misc ()
7146af97 2128{
2e471eb5 2129 Lisp_Object val;
7146af97 2130
2e471eb5 2131 if (marker_free_list)
7146af97 2132 {
2e471eb5
GM
2133 XSETMISC (val, marker_free_list);
2134 marker_free_list = marker_free_list->u_free.chain;
7146af97
JB
2135 }
2136 else
7146af97 2137 {
2e471eb5
GM
2138 if (marker_block_index == MARKER_BLOCK_SIZE)
2139 {
2140 struct marker_block *new;
34400008
GM
2141 new = (struct marker_block *) lisp_malloc (sizeof *new,
2142 MEM_TYPE_MISC);
2e471eb5
GM
2143 VALIDATE_LISP_STORAGE (new, sizeof *new);
2144 new->next = marker_block;
2145 marker_block = new;
2146 marker_block_index = 0;
2147 n_marker_blocks++;
2148 }
2149 XSETMISC (val, &marker_block->markers[marker_block_index++]);
7146af97 2150 }
2e471eb5
GM
2151
2152 consing_since_gc += sizeof (union Lisp_Misc);
2153 misc_objects_consed++;
2154 return val;
2155}
2156
2157DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
2158 "Return a newly allocated marker which does not point at any place.")
2159 ()
2160{
2161 register Lisp_Object val;
2162 register struct Lisp_Marker *p;
7146af97 2163
2e471eb5
GM
2164 val = allocate_misc ();
2165 XMISCTYPE (val) = Lisp_Misc_Marker;
2166 p = XMARKER (val);
2167 p->buffer = 0;
2168 p->bytepos = 0;
2169 p->charpos = 0;
2170 p->chain = Qnil;
2171 p->insertion_type = 0;
7146af97
JB
2172 return val;
2173}
2e471eb5
GM
2174
2175/* Put MARKER back on the free list after using it temporarily. */
2176
2177void
2178free_marker (marker)
2179 Lisp_Object marker;
2180{
2181 unchain_marker (marker);
2182
2183 XMISC (marker)->u_marker.type = Lisp_Misc_Free;
2184 XMISC (marker)->u_free.chain = marker_free_list;
2185 marker_free_list = XMISC (marker);
2186
2187 total_free_markers++;
2188}
2189
c0696668 2190\f
7146af97 2191/* Return a newly created vector or string with specified arguments as
736471d1
RS
2192 elements. If all the arguments are characters that can fit
2193 in a string of events, make a string; otherwise, make a vector.
2194
2195 Any number of arguments, even zero arguments, are allowed. */
7146af97
JB
2196
2197Lisp_Object
736471d1 2198make_event_array (nargs, args)
7146af97
JB
2199 register int nargs;
2200 Lisp_Object *args;
2201{
2202 int i;
2203
2204 for (i = 0; i < nargs; i++)
736471d1 2205 /* The things that fit in a string
c9ca4659
RS
2206 are characters that are in 0...127,
2207 after discarding the meta bit and all the bits above it. */
e687453f 2208 if (!INTEGERP (args[i])
c9ca4659 2209 || (XUINT (args[i]) & ~(-CHAR_META)) >= 0200)
7146af97
JB
2210 return Fvector (nargs, args);
2211
2212 /* Since the loop exited, we know that all the things in it are
2213 characters, so we can make a string. */
2214 {
c13ccad2 2215 Lisp_Object result;
7146af97 2216
50aee051 2217 result = Fmake_string (make_number (nargs), make_number (0));
7146af97 2218 for (i = 0; i < nargs; i++)
736471d1
RS
2219 {
2220 XSTRING (result)->data[i] = XINT (args[i]);
2221 /* Move the meta bit to the right place for a string char. */
2222 if (XINT (args[i]) & CHAR_META)
2223 XSTRING (result)->data[i] |= 0x80;
2224 }
7146af97
JB
2225
2226 return result;
2227 }
2228}
2e471eb5
GM
2229
2230
7146af97 2231\f
34400008
GM
2232/************************************************************************
2233 C Stack Marking
2234 ************************************************************************/
2235
2236#if GC_MARK_STACK
2237
2238
2239/* Base address of stack. Set in main. */
2240
2241Lisp_Object *stack_base;
2242
2243/* A node in the red-black tree describing allocated memory containing
2244 Lisp data. Each such block is recorded with its start and end
2245 address when it is allocated, and removed from the tree when it
2246 is freed.
2247
2248 A red-black tree is a balanced binary tree with the following
2249 properties:
2250
2251 1. Every node is either red or black.
2252 2. Every leaf is black.
2253 3. If a node is red, then both of its children are black.
2254 4. Every simple path from a node to a descendant leaf contains
2255 the same number of black nodes.
2256 5. The root is always black.
2257
2258 When nodes are inserted into the tree, or deleted from the tree,
2259 the tree is "fixed" so that these properties are always true.
2260
2261 A red-black tree with N internal nodes has height at most 2
2262 log(N+1). Searches, insertions and deletions are done in O(log N).
2263 Please see a text book about data structures for a detailed
2264 description of red-black trees. Any book worth its salt should
2265 describe them. */
2266
2267struct mem_node
2268{
2269 struct mem_node *left, *right, *parent;
2270
2271 /* Start and end of allocated region. */
2272 void *start, *end;
2273
2274 /* Node color. */
2275 enum {MEM_BLACK, MEM_RED} color;
2276
2277 /* Memory type. */
2278 enum mem_type type;
2279};
2280
2281/* Root of the tree describing allocated Lisp memory. */
2282
2283static struct mem_node *mem_root;
2284
2285/* Sentinel node of the tree. */
2286
2287static struct mem_node mem_z;
2288#define MEM_NIL &mem_z
2289
2290
2291/* Initialize this part of alloc.c. */
2292
2293static void
2294mem_init ()
2295{
2296 mem_z.left = mem_z.right = MEM_NIL;
2297 mem_z.parent = NULL;
2298 mem_z.color = MEM_BLACK;
2299 mem_z.start = mem_z.end = NULL;
2300 mem_root = MEM_NIL;
2301}
2302
2303
2304/* Value is a pointer to the mem_node containing START. Value is
2305 MEM_NIL if there is no node in the tree containing START. */
2306
2307static INLINE struct mem_node *
2308mem_find (start)
2309 void *start;
2310{
2311 struct mem_node *p;
2312
2313 /* Make the search always successful to speed up the loop below. */
2314 mem_z.start = start;
2315 mem_z.end = (char *) start + 1;
2316
2317 p = mem_root;
2318 while (start < p->start || start >= p->end)
2319 p = start < p->start ? p->left : p->right;
2320 return p;
2321}
2322
2323
2324/* Insert a new node into the tree for a block of memory with start
2325 address START, end address END, and type TYPE. Value is a
2326 pointer to the node that was inserted. */
2327
2328static struct mem_node *
2329mem_insert (start, end, type)
2330 void *start, *end;
2331 enum mem_type type;
2332{
2333 struct mem_node *c, *parent, *x;
2334
2335 /* See where in the tree a node for START belongs. In this
2336 particular application, it shouldn't happen that a node is already
2337 present. For debugging purposes, let's check that. */
2338 c = mem_root;
2339 parent = NULL;
2340
2341#if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
2342
2343 while (c != MEM_NIL)
2344 {
2345 if (start >= c->start && start < c->end)
2346 abort ();
2347 parent = c;
2348 c = start < c->start ? c->left : c->right;
2349 }
2350
2351#else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2352
2353 while (c != MEM_NIL)
2354 {
2355 parent = c;
2356 c = start < c->start ? c->left : c->right;
2357 }
2358
2359#endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2360
2361 /* Create a new node. */
2362 x = (struct mem_node *) xmalloc (sizeof *x);
2363 x->start = start;
2364 x->end = end;
2365 x->type = type;
2366 x->parent = parent;
2367 x->left = x->right = MEM_NIL;
2368 x->color = MEM_RED;
2369
2370 /* Insert it as child of PARENT or install it as root. */
2371 if (parent)
2372 {
2373 if (start < parent->start)
2374 parent->left = x;
2375 else
2376 parent->right = x;
2377 }
2378 else
2379 mem_root = x;
2380
2381 /* Re-establish red-black tree properties. */
2382 mem_insert_fixup (x);
2383 return x;
2384}
2385
2386
2387/* Re-establish the red-black properties of the tree, and thereby
2388 balance the tree, after node X has been inserted; X is always red. */
2389
2390static void
2391mem_insert_fixup (x)
2392 struct mem_node *x;
2393{
2394 while (x != mem_root && x->parent->color == MEM_RED)
2395 {
2396 /* X is red and its parent is red. This is a violation of
2397 red-black tree property #3. */
2398
2399 if (x->parent == x->parent->parent->left)
2400 {
2401 /* We're on the left side of our grandparent, and Y is our
2402 "uncle". */
2403 struct mem_node *y = x->parent->parent->right;
2404
2405 if (y->color == MEM_RED)
2406 {
2407 /* Uncle and parent are red but should be black because
2408 X is red. Change the colors accordingly and proceed
2409 with the grandparent. */
2410 x->parent->color = MEM_BLACK;
2411 y->color = MEM_BLACK;
2412 x->parent->parent->color = MEM_RED;
2413 x = x->parent->parent;
2414 }
2415 else
2416 {
2417 /* Parent and uncle have different colors; parent is
2418 red, uncle is black. */
2419 if (x == x->parent->right)
2420 {
2421 x = x->parent;
2422 mem_rotate_left (x);
2423 }
2424
2425 x->parent->color = MEM_BLACK;
2426 x->parent->parent->color = MEM_RED;
2427 mem_rotate_right (x->parent->parent);
2428 }
2429 }
2430 else
2431 {
2432 /* This is the symmetrical case of above. */
2433 struct mem_node *y = x->parent->parent->left;
2434
2435 if (y->color == MEM_RED)
2436 {
2437 x->parent->color = MEM_BLACK;
2438 y->color = MEM_BLACK;
2439 x->parent->parent->color = MEM_RED;
2440 x = x->parent->parent;
2441 }
2442 else
2443 {
2444 if (x == x->parent->left)
2445 {
2446 x = x->parent;
2447 mem_rotate_right (x);
2448 }
2449
2450 x->parent->color = MEM_BLACK;
2451 x->parent->parent->color = MEM_RED;
2452 mem_rotate_left (x->parent->parent);
2453 }
2454 }
2455 }
2456
2457 /* The root may have been changed to red due to the algorithm. Set
2458 it to black so that property #5 is satisfied. */
2459 mem_root->color = MEM_BLACK;
2460}
2461
2462
2463/* (x) (y)
2464 / \ / \
2465 a (y) ===> (x) c
2466 / \ / \
2467 b c a b */
2468
2469static void
2470mem_rotate_left (x)
2471 struct mem_node *x;
2472{
2473 struct mem_node *y;
2474
2475 /* Turn y's left sub-tree into x's right sub-tree. */
2476 y = x->right;
2477 x->right = y->left;
2478 if (y->left != MEM_NIL)
2479 y->left->parent = x;
2480
2481 /* Y's parent was x's parent. */
2482 if (y != MEM_NIL)
2483 y->parent = x->parent;
2484
2485 /* Get the parent to point to y instead of x. */
2486 if (x->parent)
2487 {
2488 if (x == x->parent->left)
2489 x->parent->left = y;
2490 else
2491 x->parent->right = y;
2492 }
2493 else
2494 mem_root = y;
2495
2496 /* Put x on y's left. */
2497 y->left = x;
2498 if (x != MEM_NIL)
2499 x->parent = y;
2500}
2501
2502
2503/* (x) (Y)
2504 / \ / \
2505 (y) c ===> a (x)
2506 / \ / \
2507 a b b c */
2508
2509static void
2510mem_rotate_right (x)
2511 struct mem_node *x;
2512{
2513 struct mem_node *y = x->left;
2514
2515 x->left = y->right;
2516 if (y->right != MEM_NIL)
2517 y->right->parent = x;
2518
2519 if (y != MEM_NIL)
2520 y->parent = x->parent;
2521 if (x->parent)
2522 {
2523 if (x == x->parent->right)
2524 x->parent->right = y;
2525 else
2526 x->parent->left = y;
2527 }
2528 else
2529 mem_root = y;
2530
2531 y->right = x;
2532 if (x != MEM_NIL)
2533 x->parent = y;
2534}
2535
2536
2537/* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
2538
2539static void
2540mem_delete (z)
2541 struct mem_node *z;
2542{
2543 struct mem_node *x, *y;
2544
2545 if (!z || z == MEM_NIL)
2546 return;
2547
2548 if (z->left == MEM_NIL || z->right == MEM_NIL)
2549 y = z;
2550 else
2551 {
2552 y = z->right;
2553 while (y->left != MEM_NIL)
2554 y = y->left;
2555 }
2556
2557 if (y->left != MEM_NIL)
2558 x = y->left;
2559 else
2560 x = y->right;
2561
2562 x->parent = y->parent;
2563 if (y->parent)
2564 {
2565 if (y == y->parent->left)
2566 y->parent->left = x;
2567 else
2568 y->parent->right = x;
2569 }
2570 else
2571 mem_root = x;
2572
2573 if (y != z)
2574 {
2575 z->start = y->start;
2576 z->end = y->end;
2577 z->type = y->type;
2578 }
2579
2580 if (y->color == MEM_BLACK)
2581 mem_delete_fixup (x);
2582 xfree (y);
2583}
2584
2585
2586/* Re-establish the red-black properties of the tree, after a
2587 deletion. */
2588
2589static void
2590mem_delete_fixup (x)
2591 struct mem_node *x;
2592{
2593 while (x != mem_root && x->color == MEM_BLACK)
2594 {
2595 if (x == x->parent->left)
2596 {
2597 struct mem_node *w = x->parent->right;
2598
2599 if (w->color == MEM_RED)
2600 {
2601 w->color = MEM_BLACK;
2602 x->parent->color = MEM_RED;
2603 mem_rotate_left (x->parent);
2604 w = x->parent->right;
2605 }
2606
2607 if (w->left->color == MEM_BLACK && w->right->color == MEM_BLACK)
2608 {
2609 w->color = MEM_RED;
2610 x = x->parent;
2611 }
2612 else
2613 {
2614 if (w->right->color == MEM_BLACK)
2615 {
2616 w->left->color = MEM_BLACK;
2617 w->color = MEM_RED;
2618 mem_rotate_right (w);
2619 w = x->parent->right;
2620 }
2621 w->color = x->parent->color;
2622 x->parent->color = MEM_BLACK;
2623 w->right->color = MEM_BLACK;
2624 mem_rotate_left (x->parent);
2625 x = mem_root;
2626 }
2627 }
2628 else
2629 {
2630 struct mem_node *w = x->parent->left;
2631
2632 if (w->color == MEM_RED)
2633 {
2634 w->color = MEM_BLACK;
2635 x->parent->color = MEM_RED;
2636 mem_rotate_right (x->parent);
2637 w = x->parent->left;
2638 }
2639
2640 if (w->right->color == MEM_BLACK && w->left->color == MEM_BLACK)
2641 {
2642 w->color = MEM_RED;
2643 x = x->parent;
2644 }
2645 else
2646 {
2647 if (w->left->color == MEM_BLACK)
2648 {
2649 w->right->color = MEM_BLACK;
2650 w->color = MEM_RED;
2651 mem_rotate_left (w);
2652 w = x->parent->left;
2653 }
2654
2655 w->color = x->parent->color;
2656 x->parent->color = MEM_BLACK;
2657 w->left->color = MEM_BLACK;
2658 mem_rotate_right (x->parent);
2659 x = mem_root;
2660 }
2661 }
2662 }
2663
2664 x->color = MEM_BLACK;
2665}
2666
2667
2668/* Value is non-zero if P is a pointer to a live Lisp string on
2669 the heap. M is a pointer to the mem_block for P. */
2670
2671static INLINE int
2672live_string_p (m, p)
2673 struct mem_node *m;
2674 void *p;
2675{
2676 if (m->type == MEM_TYPE_STRING)
2677 {
2678 struct string_block *b = (struct string_block *) m->start;
2679 int offset = (char *) p - (char *) &b->strings[0];
2680
2681 /* P must point to the start of a Lisp_String structure, and it
2682 must not be on the free-list. */
2683 return (offset % sizeof b->strings[0] == 0
2684 && ((struct Lisp_String *) p)->data != NULL);
2685 }
2686 else
2687 return 0;
2688}
2689
2690
2691/* Value is non-zero if P is a pointer to a live Lisp cons on
2692 the heap. M is a pointer to the mem_block for P. */
2693
2694static INLINE int
2695live_cons_p (m, p)
2696 struct mem_node *m;
2697 void *p;
2698{
2699 if (m->type == MEM_TYPE_CONS)
2700 {
2701 struct cons_block *b = (struct cons_block *) m->start;
2702 int offset = (char *) p - (char *) &b->conses[0];
2703
2704 /* P must point to the start of a Lisp_Cons, not be
2705 one of the unused cells in the current cons block,
2706 and not be on the free-list. */
2707 return (offset % sizeof b->conses[0] == 0
2708 && (b != cons_block
2709 || offset / sizeof b->conses[0] < cons_block_index)
2710 && !EQ (((struct Lisp_Cons *) p)->car, Vdead));
2711 }
2712 else
2713 return 0;
2714}
2715
2716
2717/* Value is non-zero if P is a pointer to a live Lisp symbol on
2718 the heap. M is a pointer to the mem_block for P. */
2719
2720static INLINE int
2721live_symbol_p (m, p)
2722 struct mem_node *m;
2723 void *p;
2724{
2725 if (m->type == MEM_TYPE_SYMBOL)
2726 {
2727 struct symbol_block *b = (struct symbol_block *) m->start;
2728 int offset = (char *) p - (char *) &b->symbols[0];
2729
2730 /* P must point to the start of a Lisp_Symbol, not be
2731 one of the unused cells in the current symbol block,
2732 and not be on the free-list. */
2733 return (offset % sizeof b->symbols[0] == 0
2734 && (b != symbol_block
2735 || offset / sizeof b->symbols[0] < symbol_block_index)
2736 && !EQ (((struct Lisp_Symbol *) p)->function, Vdead));
2737 }
2738 else
2739 return 0;
2740}
2741
2742
2743/* Value is non-zero if P is a pointer to a live Lisp float on
2744 the heap. M is a pointer to the mem_block for P. */
2745
2746static INLINE int
2747live_float_p (m, p)
2748 struct mem_node *m;
2749 void *p;
2750{
2751 if (m->type == MEM_TYPE_FLOAT)
2752 {
2753 struct float_block *b = (struct float_block *) m->start;
2754 int offset = (char *) p - (char *) &b->floats[0];
2755
2756 /* P must point to the start of a Lisp_Float, not be
2757 one of the unused cells in the current float block,
2758 and not be on the free-list. */
2759 return (offset % sizeof b->floats[0] == 0
2760 && (b != float_block
2761 || offset / sizeof b->floats[0] < float_block_index)
2762 && !EQ (((struct Lisp_Float *) p)->type, Vdead));
2763 }
2764 else
2765 return 0;
2766}
2767
2768
2769/* Value is non-zero if P is a pointer to a live Lisp Misc on
2770 the heap. M is a pointer to the mem_block for P. */
2771
2772static INLINE int
2773live_misc_p (m, p)
2774 struct mem_node *m;
2775 void *p;
2776{
2777 if (m->type == MEM_TYPE_MISC)
2778 {
2779 struct marker_block *b = (struct marker_block *) m->start;
2780 int offset = (char *) p - (char *) &b->markers[0];
2781
2782 /* P must point to the start of a Lisp_Misc, not be
2783 one of the unused cells in the current misc block,
2784 and not be on the free-list. */
2785 return (offset % sizeof b->markers[0] == 0
2786 && (b != marker_block
2787 || offset / sizeof b->markers[0] < marker_block_index)
2788 && ((union Lisp_Misc *) p)->u_marker.type != Lisp_Misc_Free);
2789 }
2790 else
2791 return 0;
2792}
2793
2794
2795/* Value is non-zero if P is a pointer to a live vector-like object.
2796 M is a pointer to the mem_block for P. */
2797
2798static INLINE int
2799live_vector_p (m, p)
2800 struct mem_node *m;
2801 void *p;
2802{
2803 return m->type == MEM_TYPE_VECTOR && p == m->start;
2804}
2805
2806
2807/* Value is non-zero of P is a pointer to a live buffer. M is a
2808 pointer to the mem_block for P. */
2809
2810static INLINE int
2811live_buffer_p (m, p)
2812 struct mem_node *m;
2813 void *p;
2814{
2815 /* P must point to the start of the block, and the buffer
2816 must not have been killed. */
2817 return (m->type == MEM_TYPE_BUFFER
2818 && p == m->start
2819 && !NILP (((struct buffer *) p)->name));
2820}
2821
2822
2823#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2824
2825/* Array of objects that are kept alive because the C stack contains
2826 a pattern that looks like a reference to them . */
2827
2828#define MAX_ZOMBIES 10
2829static Lisp_Object zombies[MAX_ZOMBIES];
2830
2831/* Number of zombie objects. */
2832
2833static int nzombies;
2834
2835/* Number of garbage collections. */
2836
2837static int ngcs;
2838
2839/* Average percentage of zombies per collection. */
2840
2841static double avg_zombies;
2842
2843/* Max. number of live and zombie objects. */
2844
2845static int max_live, max_zombies;
2846
2847/* Average number of live objects per GC. */
2848
2849static double avg_live;
2850
2851DEFUN ("gc-status", Fgc_status, Sgc_status, 0, 0, "",
2852 "Show information about live and zombie objects.")
2853 ()
2854{
2855 Lisp_Object args[7];
2856 args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d");
2857 args[1] = make_number (ngcs);
2858 args[2] = make_float (avg_live);
2859 args[3] = make_float (avg_zombies);
2860 args[4] = make_float (avg_zombies / avg_live / 100);
2861 args[5] = make_number (max_live);
2862 args[6] = make_number (max_zombies);
2863 return Fmessage (7, args);
2864}
2865
2866#endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
2867
2868
182ff242
GM
2869/* Mark OBJ if we can prove it's a Lisp_Object. */
2870
2871static INLINE void
2872mark_maybe_object (obj)
2873 Lisp_Object obj;
2874{
2875 void *po = (void *) XPNTR (obj);
2876 struct mem_node *m = mem_find (po);
2877
2878 if (m != MEM_NIL)
2879 {
2880 int mark_p = 0;
2881
2882 switch (XGCTYPE (obj))
2883 {
2884 case Lisp_String:
2885 mark_p = (live_string_p (m, po)
2886 && !STRING_MARKED_P ((struct Lisp_String *) po));
2887 break;
2888
2889 case Lisp_Cons:
2890 mark_p = (live_cons_p (m, po)
2891 && !XMARKBIT (XCONS (obj)->car));
2892 break;
2893
2894 case Lisp_Symbol:
2895 mark_p = (live_symbol_p (m, po)
2896 && !XMARKBIT (XSYMBOL (obj)->plist));
2897 break;
2898
2899 case Lisp_Float:
2900 mark_p = (live_float_p (m, po)
2901 && !XMARKBIT (XFLOAT (obj)->type));
2902 break;
2903
2904 case Lisp_Vectorlike:
2905 /* Note: can't check GC_BUFFERP before we know it's a
2906 buffer because checking that dereferences the pointer
2907 PO which might point anywhere. */
2908 if (live_vector_p (m, po))
2909 mark_p = (!GC_SUBRP (obj)
2910 && !(XVECTOR (obj)->size & ARRAY_MARK_FLAG));
2911 else if (live_buffer_p (m, po))
2912 mark_p = GC_BUFFERP (obj) && !XMARKBIT (XBUFFER (obj)->name);
2913 break;
2914
2915 case Lisp_Misc:
2916 if (live_misc_p (m, po))
2917 {
2918 switch (XMISCTYPE (obj))
2919 {
2920 case Lisp_Misc_Marker:
2921 mark_p = !XMARKBIT (XMARKER (obj)->chain);
2922 break;
2923
2924 case Lisp_Misc_Buffer_Local_Value:
2925 case Lisp_Misc_Some_Buffer_Local_Value:
2926 mark_p = !XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue);
2927 break;
2928
2929 case Lisp_Misc_Overlay:
2930 mark_p = !XMARKBIT (XOVERLAY (obj)->plist);
2931 break;
2932 }
2933 }
2934 break;
6bbd7a29
GM
2935
2936 case Lisp_Int:
2937 break;
182ff242
GM
2938 }
2939
2940 if (mark_p)
2941 {
2942#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2943 if (nzombies < MAX_ZOMBIES)
2944 zombies[nzombies] = *p;
2945 ++nzombies;
2946#endif
2947 mark_object (&obj);
2948 }
2949 }
2950}
2951
34400008
GM
2952/* Mark Lisp objects in the address range START..END. */
2953
2954static void
2955mark_memory (start, end)
2956 void *start, *end;
2957{
2958 Lisp_Object *p;
2959
2960#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2961 nzombies = 0;
2962#endif
2963
2964 /* Make START the pointer to the start of the memory region,
2965 if it isn't already. */
2966 if (end < start)
2967 {
2968 void *tem = start;
2969 start = end;
2970 end = tem;
2971 }
182ff242 2972
34400008 2973 for (p = (Lisp_Object *) start; (void *) p < end; ++p)
182ff242
GM
2974 mark_maybe_object (*p);
2975}
2976
2977
2978#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
2979
2980static int setjmp_tested_p, longjmps_done;
2981
2982#define SETJMP_WILL_LIKELY_WORK "\
2983\n\
2984Emacs garbage collector has been changed to use conservative stack\n\
2985marking. Emacs has determined that the method it uses to do the\n\
2986marking will likely work on your system, but this isn't sure.\n\
2987\n\
2988If you are a system-programmer, or can get the help of a local wizard\n\
2989who is, please take a look at the function mark_stack in alloc.c, and\n\
2990verify that the methods used are appropriate for your system.\n\
2991\n\
2992Please mail the result to <gerd@gnu.org>.\n\
2993"
2994
2995#define SETJMP_WILL_NOT_WORK "\
2996\n\
2997Emacs garbage collector has been changed to use conservative stack\n\
2998marking. Emacs has determined that the default method it uses to do the\n\
2999marking will not work on your system. We will need a system-dependent\n\
3000solution for your system.\n\
3001\n\
3002Please take a look at the function mark_stack in alloc.c, and\n\
3003try to find a way to make it work on your system.\n\
3004Please mail the result to <gerd@gnu.org>.\n\
3005"
3006
3007
3008/* Perform a quick check if it looks like setjmp saves registers in a
3009 jmp_buf. Print a message to stderr saying so. When this test
3010 succeeds, this is _not_ a proof that setjmp is sufficient for
3011 conservative stack marking. Only the sources or a disassembly
3012 can prove that. */
3013
3014static void
3015test_setjmp ()
3016{
3017 char buf[10];
3018 register int x;
3019 jmp_buf jbuf;
3020 int result = 0;
3021
3022 /* Arrange for X to be put in a register. */
3023 sprintf (buf, "1");
3024 x = strlen (buf);
3025 x = 2 * x - 1;
3026
3027 setjmp (jbuf);
3028 if (longjmps_done == 1)
34400008 3029 {
182ff242 3030 /* Came here after the longjmp at the end of the function.
34400008 3031
182ff242
GM
3032 If x == 1, the longjmp has restored the register to its
3033 value before the setjmp, and we can hope that setjmp
3034 saves all such registers in the jmp_buf, although that
3035 isn't sure.
34400008 3036
182ff242
GM
3037 For other values of X, either something really strange is
3038 taking place, or the setjmp just didn't save the register. */
3039
3040 if (x == 1)
3041 fprintf (stderr, SETJMP_WILL_LIKELY_WORK);
3042 else
3043 {
3044 fprintf (stderr, SETJMP_WILL_NOT_WORK);
3045 exit (1);
34400008
GM
3046 }
3047 }
182ff242
GM
3048
3049 ++longjmps_done;
3050 x = 2;
3051 if (longjmps_done == 1)
3052 longjmp (jbuf, 1);
34400008
GM
3053}
3054
182ff242
GM
3055#endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
3056
34400008
GM
3057
3058#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3059
3060/* Abort if anything GCPRO'd doesn't survive the GC. */
3061
3062static void
3063check_gcpros ()
3064{
3065 struct gcpro *p;
3066 int i;
3067
3068 for (p = gcprolist; p; p = p->next)
3069 for (i = 0; i < p->nvars; ++i)
3070 if (!survives_gc_p (p->var[i]))
3071 abort ();
3072}
3073
3074#elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3075
3076static void
3077dump_zombies ()
3078{
3079 int i;
3080
3081 fprintf (stderr, "\nZombies kept alive = %d:\n", nzombies);
3082 for (i = 0; i < min (MAX_ZOMBIES, nzombies); ++i)
3083 {
3084 fprintf (stderr, " %d = ", i);
3085 debug_print (zombies[i]);
3086 }
3087}
3088
3089#endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3090
3091
182ff242
GM
3092/* Mark live Lisp objects on the C stack.
3093
3094 There are several system-dependent problems to consider when
3095 porting this to new architectures:
3096
3097 Processor Registers
3098
3099 We have to mark Lisp objects in CPU registers that can hold local
3100 variables or are used to pass parameters.
3101
3102 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
3103 something that either saves relevant registers on the stack, or
3104 calls mark_maybe_object passing it each register's contents.
3105
3106 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
3107 implementation assumes that calling setjmp saves registers we need
3108 to see in a jmp_buf which itself lies on the stack. This doesn't
3109 have to be true! It must be verified for each system, possibly
3110 by taking a look at the source code of setjmp.
3111
3112 Stack Layout
3113
3114 Architectures differ in the way their processor stack is organized.
3115 For example, the stack might look like this
3116
3117 +----------------+
3118 | Lisp_Object | size = 4
3119 +----------------+
3120 | something else | size = 2
3121 +----------------+
3122 | Lisp_Object | size = 4
3123 +----------------+
3124 | ... |
3125
3126 In such a case, not every Lisp_Object will be aligned equally. To
3127 find all Lisp_Object on the stack it won't be sufficient to walk
3128 the stack in steps of 4 bytes. Instead, two passes will be
3129 necessary, one starting at the start of the stack, and a second
3130 pass starting at the start of the stack + 2. Likewise, if the
3131 minimal alignment of Lisp_Objects on the stack is 1, four passes
3132 would be necessary, each one starting with one byte more offset
3133 from the stack start.
3134
3135 The current code assumes by default that Lisp_Objects are aligned
3136 equally on the stack. */
34400008
GM
3137
3138static void
3139mark_stack ()
3140{
3141 jmp_buf j;
6bbd7a29 3142 volatile int stack_grows_down_p = (char *) &j > (char *) stack_base;
34400008
GM
3143 void *end;
3144
3145 /* This trick flushes the register windows so that all the state of
3146 the process is contained in the stack. */
3147#ifdef sparc
3148 asm ("ta 3");
3149#endif
3150
3151 /* Save registers that we need to see on the stack. We need to see
3152 registers used to hold register variables and registers used to
3153 pass parameters. */
3154#ifdef GC_SAVE_REGISTERS_ON_STACK
3155 GC_SAVE_REGISTERS_ON_STACK (end);
182ff242
GM
3156#else /* not GC_SAVE_REGISTERS_ON_STACK */
3157
3158#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
3159 setjmp will definitely work, test it
3160 and print a message with the result
3161 of the test. */
3162 if (!setjmp_tested_p)
3163 {
3164 setjmp_tested_p = 1;
3165 test_setjmp ();
3166 }
3167#endif /* GC_SETJMP_WORKS */
3168
34400008
GM
3169 setjmp (j);
3170 end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
182ff242 3171#endif /* not GC_SAVE_REGISTERS_ON_STACK */
34400008
GM
3172
3173 /* This assumes that the stack is a contiguous region in memory. If
182ff242
GM
3174 that's not the case, something has to be done here to iterate
3175 over the stack segments. */
3176#if GC_LISP_OBJECT_ALIGNMENT == 1
3177 mark_memory (stack_base, end);
3178 mark_memory ((char *) stack_base + 1, end);
3179 mark_memory ((char *) stack_base + 2, end);
3180 mark_memory ((char *) stack_base + 3, end);
3181#elif GC_LISP_OBJECT_ALIGNMENT == 2
3182 mark_memory (stack_base, end);
3183 mark_memory ((char *) stack_base + 2, end);
3184#else
34400008 3185 mark_memory (stack_base, end);
182ff242 3186#endif
34400008
GM
3187
3188#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3189 check_gcpros ();
3190#endif
3191}
3192
3193
3194#endif /* GC_MARK_STACK != 0 */
3195
3196
3197\f
2e471eb5
GM
3198/***********************************************************************
3199 Pure Storage Management
3200 ***********************************************************************/
3201
3202/* Return a string allocated in pure space. DATA is a buffer holding
3203 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
3204 non-zero means make the result string multibyte.
1a4f1e2c 3205
2e471eb5
GM
3206 Must get an error if pure storage is full, since if it cannot hold
3207 a large string it may be able to hold conses that point to that
3208 string; then the string is not protected from gc. */
7146af97
JB
3209
3210Lisp_Object
2e471eb5 3211make_pure_string (data, nchars, nbytes, multibyte)
7146af97 3212 char *data;
2e471eb5 3213 int nchars, nbytes;
c0696668 3214 int multibyte;
7146af97 3215{
2e471eb5
GM
3216 Lisp_Object string;
3217 struct Lisp_String *s;
3218 int string_size, data_size;
c0696668 3219
2e471eb5 3220#define PAD(SZ) (((SZ) + sizeof (EMACS_INT) - 1) & ~(sizeof (EMACS_INT) - 1))
7146af97 3221
2e471eb5
GM
3222 string_size = PAD (sizeof (struct Lisp_String));
3223 data_size = PAD (nbytes + 1);
3224
3225#undef PAD
3226
3227 if (pureptr + string_size + data_size > PURESIZE)
7146af97 3228 error ("Pure Lisp storage exhausted");
2e471eb5
GM
3229
3230 s = (struct Lisp_String *) (PUREBEG + pureptr);
3231 pureptr += string_size;
3232 s->data = (unsigned char *) (PUREBEG + pureptr);
3233 pureptr += data_size;
3234
3235 s->size = nchars;
3236 s->size_byte = multibyte ? nbytes : -1;
3237 bcopy (data, s->data, nbytes);
3238 s->data[nbytes] = '\0';
3239 s->intervals = NULL_INTERVAL;
3240
3241 XSETSTRING (string, s);
3242 return string;
7146af97
JB
3243}
3244
2e471eb5 3245
34400008
GM
3246/* Return a cons allocated from pure space. Give it pure copies
3247 of CAR as car and CDR as cdr. */
3248
7146af97
JB
3249Lisp_Object
3250pure_cons (car, cdr)
3251 Lisp_Object car, cdr;
3252{
3253 register Lisp_Object new;
3254
3255 if (pureptr + sizeof (struct Lisp_Cons) > PURESIZE)
3256 error ("Pure Lisp storage exhausted");
45d12a89 3257 XSETCONS (new, PUREBEG + pureptr);
7146af97 3258 pureptr += sizeof (struct Lisp_Cons);
70949dac
KR
3259 XCAR (new) = Fpurecopy (car);
3260 XCDR (new) = Fpurecopy (cdr);
7146af97
JB
3261 return new;
3262}
3263
7146af97 3264
34400008
GM
3265/* Value is a float object with value NUM allocated from pure space. */
3266
7146af97
JB
3267Lisp_Object
3268make_pure_float (num)
3269 double num;
3270{
3271 register Lisp_Object new;
3272
6d19f28a
JB
3273 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
3274 (double) boundary. Some architectures (like the sparc) require
3275 this, and I suspect that floats are rare enough that it's no
3276 tragedy for those that do. */
3277 {
675d5130 3278 size_t alignment;
6d19f28a
JB
3279 char *p = PUREBEG + pureptr;
3280
fe90ad97
JB
3281#ifdef __GNUC__
3282#if __GNUC__ >= 2
6d19f28a 3283 alignment = __alignof (struct Lisp_Float);
fe90ad97 3284#else
6d19f28a 3285 alignment = sizeof (struct Lisp_Float);
fe90ad97
JB
3286#endif
3287#else
6d19f28a 3288 alignment = sizeof (struct Lisp_Float);
fe90ad97 3289#endif
6d19f28a
JB
3290 p = (char *) (((unsigned long) p + alignment - 1) & - alignment);
3291 pureptr = p - PUREBEG;
3292 }
1a4f1e2c 3293
7146af97
JB
3294 if (pureptr + sizeof (struct Lisp_Float) > PURESIZE)
3295 error ("Pure Lisp storage exhausted");
45d12a89 3296 XSETFLOAT (new, PUREBEG + pureptr);
7146af97 3297 pureptr += sizeof (struct Lisp_Float);
70949dac 3298 XFLOAT_DATA (new) = num;
67ba9986 3299 XSETFASTINT (XFLOAT (new)->type, 0); /* bug chasing -wsr */
7146af97
JB
3300 return new;
3301}
3302
34400008
GM
3303
3304/* Return a vector with room for LEN Lisp_Objects allocated from
3305 pure space. */
3306
7146af97
JB
3307Lisp_Object
3308make_pure_vector (len)
42607681 3309 EMACS_INT len;
7146af97
JB
3310{
3311 register Lisp_Object new;
34400008
GM
3312 register EMACS_INT size = (sizeof (struct Lisp_Vector)
3313 + (len - 1) * sizeof (Lisp_Object));
7146af97
JB
3314
3315 if (pureptr + size > PURESIZE)
3316 error ("Pure Lisp storage exhausted");
3317
45d12a89 3318 XSETVECTOR (new, PUREBEG + pureptr);
7146af97
JB
3319 pureptr += size;
3320 XVECTOR (new)->size = len;
3321 return new;
3322}
3323
34400008 3324
7146af97
JB
3325DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
3326 "Make a copy of OBJECT in pure storage.\n\
3327Recursively copies contents of vectors and cons cells.\n\
d71c0668 3328Does not copy symbols. Copies strings without text properties.")
7146af97
JB
3329 (obj)
3330 register Lisp_Object obj;
3331{
265a9e55 3332 if (NILP (Vpurify_flag))
7146af97
JB
3333 return obj;
3334
3335 if ((PNTR_COMPARISON_TYPE) XPNTR (obj) < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)
3336 && (PNTR_COMPARISON_TYPE) XPNTR (obj) >= (PNTR_COMPARISON_TYPE) pure)
3337 return obj;
3338
d6dd74bb 3339 if (CONSP (obj))
70949dac 3340 return pure_cons (XCAR (obj), XCDR (obj));
d6dd74bb 3341 else if (FLOATP (obj))
70949dac 3342 return make_pure_float (XFLOAT_DATA (obj));
d6dd74bb 3343 else if (STRINGP (obj))
3f25e183 3344 return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size,
c0696668
RS
3345 STRING_BYTES (XSTRING (obj)),
3346 STRING_MULTIBYTE (obj));
d6dd74bb
KH
3347 else if (COMPILEDP (obj) || VECTORP (obj))
3348 {
3349 register struct Lisp_Vector *vec;
3350 register int i, size;
3351
3352 size = XVECTOR (obj)->size;
7d535c68
KH
3353 if (size & PSEUDOVECTOR_FLAG)
3354 size &= PSEUDOVECTOR_SIZE_MASK;
01a4d290 3355 vec = XVECTOR (make_pure_vector ((EMACS_INT) size));
d6dd74bb
KH
3356 for (i = 0; i < size; i++)
3357 vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]);
3358 if (COMPILEDP (obj))
3359 XSETCOMPILED (obj, vec);
3360 else
3361 XSETVECTOR (obj, vec);
7146af97
JB
3362 return obj;
3363 }
d6dd74bb
KH
3364 else if (MARKERP (obj))
3365 error ("Attempt to copy a marker to pure storage");
6bbd7a29
GM
3366
3367 return obj;
7146af97 3368}
2e471eb5 3369
34400008 3370
7146af97 3371\f
34400008
GM
3372/***********************************************************************
3373 Protection from GC
3374 ***********************************************************************/
3375
7146af97
JB
3376/* Recording what needs to be marked for gc. */
3377
3378struct gcpro *gcprolist;
3379
34400008 3380/* Addresses of staticpro'd variables. */
7146af97 3381
34400008 3382#define NSTATICS 1024
7146af97
JB
3383Lisp_Object *staticvec[NSTATICS] = {0};
3384
34400008
GM
3385/* Index of next unused slot in staticvec. */
3386
7146af97
JB
3387int staticidx = 0;
3388
34400008 3389
2e471eb5
GM
3390/* Put an entry in staticvec, pointing at the variable with address
3391 VARADDRESS. */
7146af97
JB
3392
3393void
3394staticpro (varaddress)
3395 Lisp_Object *varaddress;
3396{
3397 staticvec[staticidx++] = varaddress;
3398 if (staticidx >= NSTATICS)
3399 abort ();
3400}
3401
3402struct catchtag
2e471eb5 3403{
7146af97
JB
3404 Lisp_Object tag;
3405 Lisp_Object val;
3406 struct catchtag *next;
2e471eb5 3407};
7146af97
JB
3408
3409struct backtrace
2e471eb5
GM
3410{
3411 struct backtrace *next;
3412 Lisp_Object *function;
3413 Lisp_Object *args; /* Points to vector of args. */
3414 int nargs; /* Length of vector. */
3415 /* If nargs is UNEVALLED, args points to slot holding list of
3416 unevalled args. */
3417 char evalargs;
3418};
3419
34400008 3420
7146af97 3421\f
34400008
GM
3422/***********************************************************************
3423 Protection from GC
3424 ***********************************************************************/
1a4f1e2c 3425
e8197642
RS
3426/* Temporarily prevent garbage collection. */
3427
3428int
3429inhibit_garbage_collection ()
3430{
3431 int count = specpdl_ptr - specpdl;
26b926e1 3432 Lisp_Object number;
68be917d 3433 int nbits = min (VALBITS, BITS_PER_INT);
e8197642 3434
b580578b 3435 XSETINT (number, ((EMACS_INT) 1 << (nbits - 1)) - 1);
26b926e1
RS
3436
3437 specbind (Qgc_cons_threshold, number);
e8197642
RS
3438
3439 return count;
3440}
3441
34400008 3442
7146af97
JB
3443DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
3444 "Reclaim storage for Lisp objects no longer needed.\n\
3445Returns info on amount of space in use:\n\
3446 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
3447 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
2e471eb5
GM
3448 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS\n\
3449 (USED-STRINGS . FREE-STRINGS))\n\
7146af97
JB
3450Garbage collection happens automatically if you cons more than\n\
3451`gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
3452 ()
3453{
3454 register struct gcpro *tail;
3455 register struct specbinding *bind;
3456 struct catchtag *catch;
3457 struct handler *handler;
3458 register struct backtrace *backlist;
7146af97
JB
3459 char stack_top_variable;
3460 register int i;
6efc7df7 3461 int message_p;
2e471eb5 3462 Lisp_Object total[7];
7146af97 3463
58595309
KH
3464 /* In case user calls debug_print during GC,
3465 don't let that cause a recursive GC. */
3466 consing_since_gc = 0;
3467
6efc7df7
GM
3468 /* Save what's currently displayed in the echo area. */
3469 message_p = push_message ();
41c28a37 3470
7146af97
JB
3471 /* Save a copy of the contents of the stack, for debugging. */
3472#if MAX_SAVE_STACK > 0
265a9e55 3473 if (NILP (Vpurify_flag))
7146af97
JB
3474 {
3475 i = &stack_top_variable - stack_bottom;
3476 if (i < 0) i = -i;
3477 if (i < MAX_SAVE_STACK)
3478 {
3479 if (stack_copy == 0)
9ac0d9e0 3480 stack_copy = (char *) xmalloc (stack_copy_size = i);
7146af97 3481 else if (stack_copy_size < i)
9ac0d9e0 3482 stack_copy = (char *) xrealloc (stack_copy, (stack_copy_size = i));
7146af97
JB
3483 if (stack_copy)
3484 {
42607681 3485 if ((EMACS_INT) (&stack_top_variable - stack_bottom) > 0)
7146af97
JB
3486 bcopy (stack_bottom, stack_copy, i);
3487 else
3488 bcopy (&stack_top_variable, stack_copy, i);
3489 }
3490 }
3491 }
3492#endif /* MAX_SAVE_STACK > 0 */
3493
299585ee 3494 if (garbage_collection_messages)
691c4285 3495 message1_nolog ("Garbage collecting...");
7146af97 3496
6e0fca1d
RS
3497 BLOCK_INPUT;
3498
eec7b73d
RS
3499 shrink_regexp_cache ();
3500
4929a878 3501 /* Don't keep undo information around forever. */
7146af97
JB
3502 {
3503 register struct buffer *nextb = all_buffers;
3504
3505 while (nextb)
3506 {
ffd56f97
JB
3507 /* If a buffer's undo list is Qt, that means that undo is
3508 turned off in that buffer. Calling truncate_undo_list on
3509 Qt tends to return NULL, which effectively turns undo back on.
3510 So don't call truncate_undo_list if undo_list is Qt. */
3511 if (! EQ (nextb->undo_list, Qt))
3512 nextb->undo_list
502b9b64
JB
3513 = truncate_undo_list (nextb->undo_list, undo_limit,
3514 undo_strong_limit);
7146af97
JB
3515 nextb = nextb->next;
3516 }
3517 }
3518
3519 gc_in_progress = 1;
3520
c23baf9f 3521 /* clear_marks (); */
7146af97 3522
7146af97
JB
3523 /* Mark all the special slots that serve as the roots of accessibility.
3524
3525 Usually the special slots to mark are contained in particular structures.
3526 Then we know no slot is marked twice because the structures don't overlap.
3527 In some cases, the structures point to the slots to be marked.
3528 For these, we use MARKBIT to avoid double marking of the slot. */
3529
3530 for (i = 0; i < staticidx; i++)
3531 mark_object (staticvec[i]);
34400008
GM
3532
3533#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
3534 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
3535 mark_stack ();
3536#else
7146af97
JB
3537 for (tail = gcprolist; tail; tail = tail->next)
3538 for (i = 0; i < tail->nvars; i++)
3539 if (!XMARKBIT (tail->var[i]))
3540 {
3541 mark_object (&tail->var[i]);
3542 XMARK (tail->var[i]);
3543 }
34400008
GM
3544#endif
3545
630686c8 3546 mark_byte_stack ();
7146af97
JB
3547 for (bind = specpdl; bind != specpdl_ptr; bind++)
3548 {
3549 mark_object (&bind->symbol);
3550 mark_object (&bind->old_value);
3551 }
3552 for (catch = catchlist; catch; catch = catch->next)
3553 {
3554 mark_object (&catch->tag);
3555 mark_object (&catch->val);
3556 }
3557 for (handler = handlerlist; handler; handler = handler->next)
3558 {
3559 mark_object (&handler->handler);
3560 mark_object (&handler->var);
3561 }
3562 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3563 {
3564 if (!XMARKBIT (*backlist->function))
3565 {
3566 mark_object (backlist->function);
3567 XMARK (*backlist->function);
3568 }
3569 if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
3570 i = 0;
3571 else
3572 i = backlist->nargs - 1;
3573 for (; i >= 0; i--)
3574 if (!XMARKBIT (backlist->args[i]))
3575 {
3576 mark_object (&backlist->args[i]);
3577 XMARK (backlist->args[i]);
3578 }
3579 }
b875d3f7 3580 mark_kboards ();
7146af97 3581
4c315bda
RS
3582 /* Look thru every buffer's undo list
3583 for elements that update markers that were not marked,
3584 and delete them. */
3585 {
3586 register struct buffer *nextb = all_buffers;
3587
3588 while (nextb)
3589 {
3590 /* If a buffer's undo list is Qt, that means that undo is
3591 turned off in that buffer. Calling truncate_undo_list on
3592 Qt tends to return NULL, which effectively turns undo back on.
3593 So don't call truncate_undo_list if undo_list is Qt. */
3594 if (! EQ (nextb->undo_list, Qt))
3595 {
3596 Lisp_Object tail, prev;
3597 tail = nextb->undo_list;
3598 prev = Qnil;
3599 while (CONSP (tail))
3600 {
70949dac
KR
3601 if (GC_CONSP (XCAR (tail))
3602 && GC_MARKERP (XCAR (XCAR (tail)))
3603 && ! XMARKBIT (XMARKER (XCAR (XCAR (tail)))->chain))
4c315bda
RS
3604 {
3605 if (NILP (prev))
70949dac 3606 nextb->undo_list = tail = XCDR (tail);
4c315bda 3607 else
70949dac 3608 tail = XCDR (prev) = XCDR (tail);
4c315bda
RS
3609 }
3610 else
3611 {
3612 prev = tail;
70949dac 3613 tail = XCDR (tail);
4c315bda
RS
3614 }
3615 }
3616 }
3617
3618 nextb = nextb->next;
3619 }
3620 }
3621
34400008
GM
3622#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3623 mark_stack ();
3624#endif
3625
7146af97
JB
3626 gc_sweep ();
3627
3628 /* Clear the mark bits that we set in certain root slots. */
3629
34400008
GM
3630#if (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE \
3631 || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
7146af97
JB
3632 for (tail = gcprolist; tail; tail = tail->next)
3633 for (i = 0; i < tail->nvars; i++)
3634 XUNMARK (tail->var[i]);
34400008
GM
3635#endif
3636
033a5fa3 3637 unmark_byte_stack ();
7146af97
JB
3638 for (backlist = backtrace_list; backlist; backlist = backlist->next)
3639 {
3640 XUNMARK (*backlist->function);
3641 if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
3642 i = 0;
3643 else
3644 i = backlist->nargs - 1;
3645 for (; i >= 0; i--)
3646 XUNMARK (backlist->args[i]);
3647 }
3648 XUNMARK (buffer_defaults.name);
3649 XUNMARK (buffer_local_symbols.name);
3650
34400008
GM
3651#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
3652 dump_zombies ();
3653#endif
3654
6e0fca1d
RS
3655 UNBLOCK_INPUT;
3656
c23baf9f 3657 /* clear_marks (); */
7146af97
JB
3658 gc_in_progress = 0;
3659
3660 consing_since_gc = 0;
3661 if (gc_cons_threshold < 10000)
3662 gc_cons_threshold = 10000;
3663
299585ee
RS
3664 if (garbage_collection_messages)
3665 {
6efc7df7
GM
3666 if (message_p || minibuf_level > 0)
3667 restore_message ();
299585ee
RS
3668 else
3669 message1_nolog ("Garbage collecting...done");
3670 }
7146af97 3671
6efc7df7 3672 pop_message ();
2e471eb5
GM
3673
3674 total[0] = Fcons (make_number (total_conses),
3675 make_number (total_free_conses));
3676 total[1] = Fcons (make_number (total_symbols),
3677 make_number (total_free_symbols));
3678 total[2] = Fcons (make_number (total_markers),
3679 make_number (total_free_markers));
3680 total[3] = Fcons (make_number (total_string_size),
3681 make_number (total_vector_size));
2e471eb5
GM
3682 total[4] = Fcons (make_number (total_floats),
3683 make_number (total_free_floats));
2e471eb5
GM
3684 total[5] = Fcons (make_number (total_intervals),
3685 make_number (total_free_intervals));
3686 total[6] = Fcons (make_number (total_strings),
3687 make_number (total_free_strings));
3688
34400008 3689#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
7146af97 3690 {
34400008
GM
3691 /* Compute average percentage of zombies. */
3692 double nlive = 0;
3693
3694 for (i = 0; i < 7; ++i)
3695 nlive += XFASTINT (XCAR (total[i]));
3696
3697 avg_live = (avg_live * ngcs + nlive) / (ngcs + 1);
3698 max_live = max (nlive, max_live);
3699 avg_zombies = (avg_zombies * ngcs + nzombies) / (ngcs + 1);
3700 max_zombies = max (nzombies, max_zombies);
3701 ++ngcs;
3702 }
3703#endif
7146af97 3704
34400008 3705 return Flist (7, total);
7146af97 3706}
34400008 3707
41c28a37 3708
3770920e
GM
3709/* Mark Lisp objects in glyph matrix MATRIX. Currently the
3710 only interesting objects referenced from glyphs are strings. */
41c28a37
GM
3711
3712static void
3713mark_glyph_matrix (matrix)
3714 struct glyph_matrix *matrix;
3715{
3716 struct glyph_row *row = matrix->rows;
3717 struct glyph_row *end = row + matrix->nrows;
3718
2e471eb5
GM
3719 for (; row < end; ++row)
3720 if (row->enabled_p)
3721 {
3722 int area;
3723 for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
3724 {
3725 struct glyph *glyph = row->glyphs[area];
3726 struct glyph *end_glyph = glyph + row->used[area];
3727
3728 for (; glyph < end_glyph; ++glyph)
3729 if (GC_STRINGP (glyph->object)
3730 && !STRING_MARKED_P (XSTRING (glyph->object)))
3731 mark_object (&glyph->object);
3732 }
3733 }
41c28a37
GM
3734}
3735
34400008 3736
41c28a37
GM
3737/* Mark Lisp faces in the face cache C. */
3738
3739static void
3740mark_face_cache (c)
3741 struct face_cache *c;
3742{
3743 if (c)
3744 {
3745 int i, j;
3746 for (i = 0; i < c->used; ++i)
3747 {
3748 struct face *face = FACE_FROM_ID (c->f, i);
3749
3750 if (face)
3751 {
3752 for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
3753 mark_object (&face->lface[j]);
41c28a37
GM
3754 }
3755 }
3756 }
3757}
3758
3759
3760#ifdef HAVE_WINDOW_SYSTEM
3761
3762/* Mark Lisp objects in image IMG. */
3763
3764static void
3765mark_image (img)
3766 struct image *img;
3767{
3768 mark_object (&img->spec);
3769
3e60b029 3770 if (!NILP (img->data.lisp_val))
41c28a37
GM
3771 mark_object (&img->data.lisp_val);
3772}
3773
3774
3775/* Mark Lisp objects in image cache of frame F. It's done this way so
3776 that we don't have to include xterm.h here. */
3777
3778static void
3779mark_image_cache (f)
3780 struct frame *f;
3781{
3782 forall_images_in_image_cache (f, mark_image);
3783}
3784
3785#endif /* HAVE_X_WINDOWS */
3786
3787
7146af97 3788\f
1a4f1e2c 3789/* Mark reference to a Lisp_Object.
2e471eb5
GM
3790 If the object referred to has not been seen yet, recursively mark
3791 all the references contained in it. */
7146af97 3792
785cd37f
RS
3793#define LAST_MARKED_SIZE 500
3794Lisp_Object *last_marked[LAST_MARKED_SIZE];
3795int last_marked_index;
3796
41c28a37 3797void
436c5811
RS
3798mark_object (argptr)
3799 Lisp_Object *argptr;
7146af97 3800{
436c5811 3801 Lisp_Object *objptr = argptr;
7146af97 3802 register Lisp_Object obj;
4f5c1376
GM
3803#ifdef GC_CHECK_MARKED_OBJECTS
3804 void *po;
3805 struct mem_node *m;
3806#endif
7146af97 3807
9149e743 3808 loop:
7146af97 3809 obj = *objptr;
9149e743 3810 loop2:
7146af97
JB
3811 XUNMARK (obj);
3812
34400008 3813 if (PURE_POINTER_P ((PNTR_COMPARISON_TYPE) XPNTR (obj)))
7146af97
JB
3814 return;
3815
785cd37f
RS
3816 last_marked[last_marked_index++] = objptr;
3817 if (last_marked_index == LAST_MARKED_SIZE)
3818 last_marked_index = 0;
3819
4f5c1376
GM
3820 /* Perform some sanity checks on the objects marked here. Abort if
3821 we encounter an object we know is bogus. This increases GC time
3822 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
3823#ifdef GC_CHECK_MARKED_OBJECTS
3824
3825 po = (void *) XPNTR (obj);
3826
3827 /* Check that the object pointed to by PO is known to be a Lisp
3828 structure allocated from the heap. */
3829#define CHECK_ALLOCATED() \
3830 do { \
3831 m = mem_find (po); \
3832 if (m == MEM_NIL) \
3833 abort (); \
3834 } while (0)
3835
3836 /* Check that the object pointed to by PO is live, using predicate
3837 function LIVEP. */
3838#define CHECK_LIVE(LIVEP) \
3839 do { \
3840 if (!LIVEP (m, po)) \
3841 abort (); \
3842 } while (0)
3843
3844 /* Check both of the above conditions. */
3845#define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
3846 do { \
3847 CHECK_ALLOCATED (); \
3848 CHECK_LIVE (LIVEP); \
3849 } while (0) \
3850
3851#else /* not GC_CHECK_MARKED_OBJECTS */
3852
3853#define CHECK_ALLOCATED() (void) 0
3854#define CHECK_LIVE(LIVEP) (void) 0
3855#define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
3856
3857#endif /* not GC_CHECK_MARKED_OBJECTS */
3858
0220c518 3859 switch (SWITCH_ENUM_CAST (XGCTYPE (obj)))
7146af97
JB
3860 {
3861 case Lisp_String:
3862 {
3863 register struct Lisp_String *ptr = XSTRING (obj);
4f5c1376 3864 CHECK_ALLOCATED_AND_LIVE (live_string_p);
d5e35230 3865 MARK_INTERVAL_TREE (ptr->intervals);
2e471eb5 3866 MARK_STRING (ptr);
7146af97
JB
3867 }
3868 break;
3869
76437631 3870 case Lisp_Vectorlike:
4f5c1376
GM
3871#ifdef GC_CHECK_MARKED_OBJECTS
3872 m = mem_find (po);
3873 if (m == MEM_NIL && !GC_SUBRP (obj)
3874 && po != &buffer_defaults
3875 && po != &buffer_local_symbols)
3876 abort ();
3877#endif /* GC_CHECK_MARKED_OBJECTS */
3878
30e3190a 3879 if (GC_BUFFERP (obj))
6b552283
KH
3880 {
3881 if (!XMARKBIT (XBUFFER (obj)->name))
4f5c1376
GM
3882 {
3883#ifdef GC_CHECK_MARKED_OBJECTS
3884 if (po != &buffer_defaults && po != &buffer_local_symbols)
3885 {
3886 struct buffer *b;
3887 for (b = all_buffers; b && b != po; b = b->next)
3888 ;
3889 if (b == NULL)
3890 abort ();
3891 }
3892#endif /* GC_CHECK_MARKED_OBJECTS */
3893 mark_buffer (obj);
3894 }
6b552283 3895 }
30e3190a 3896 else if (GC_SUBRP (obj))
169ee243
RS
3897 break;
3898 else if (GC_COMPILEDP (obj))
2e471eb5
GM
3899 /* We could treat this just like a vector, but it is better to
3900 save the COMPILED_CONSTANTS element for last and avoid
3901 recursion there. */
169ee243
RS
3902 {
3903 register struct Lisp_Vector *ptr = XVECTOR (obj);
3904 register EMACS_INT size = ptr->size;
3905 /* See comment above under Lisp_Vector. */
3906 struct Lisp_Vector *volatile ptr1 = ptr;
3907 register int i;
3908
3909 if (size & ARRAY_MARK_FLAG)
3910 break; /* Already marked */
4f5c1376
GM
3911
3912 CHECK_LIVE (live_vector_p);
169ee243 3913 ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
76437631 3914 size &= PSEUDOVECTOR_SIZE_MASK;
169ee243
RS
3915 for (i = 0; i < size; i++) /* and then mark its elements */
3916 {
3917 if (i != COMPILED_CONSTANTS)
3918 mark_object (&ptr1->contents[i]);
3919 }
3920 /* This cast should be unnecessary, but some Mips compiler complains
3921 (MIPS-ABI + SysVR4, DC/OSx, etc). */
3922 objptr = (Lisp_Object *) &ptr1->contents[COMPILED_CONSTANTS];
3923 goto loop;
3924 }
169ee243
RS
3925 else if (GC_FRAMEP (obj))
3926 {
3927 /* See comment above under Lisp_Vector for why this is volatile. */
3928 register struct frame *volatile ptr = XFRAME (obj);
3929 register EMACS_INT size = ptr->size;
3930
3931 if (size & ARRAY_MARK_FLAG) break; /* Already marked */
3932 ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
3933
4f5c1376 3934 CHECK_LIVE (live_vector_p);
169ee243 3935 mark_object (&ptr->name);
894a9d16 3936 mark_object (&ptr->icon_name);
aba6deb8 3937 mark_object (&ptr->title);
169ee243
RS
3938 mark_object (&ptr->focus_frame);
3939 mark_object (&ptr->selected_window);
3940 mark_object (&ptr->minibuffer_window);
3941 mark_object (&ptr->param_alist);
3942 mark_object (&ptr->scroll_bars);
3943 mark_object (&ptr->condemned_scroll_bars);
3944 mark_object (&ptr->menu_bar_items);
3945 mark_object (&ptr->face_alist);
3946 mark_object (&ptr->menu_bar_vector);
3947 mark_object (&ptr->buffer_predicate);
a0e1f185 3948 mark_object (&ptr->buffer_list);
41c28a37 3949 mark_object (&ptr->menu_bar_window);
9ea173e8 3950 mark_object (&ptr->tool_bar_window);
41c28a37
GM
3951 mark_face_cache (ptr->face_cache);
3952#ifdef HAVE_WINDOW_SYSTEM
3953 mark_image_cache (ptr);
9ea173e8
GM
3954 mark_object (&ptr->desired_tool_bar_items);
3955 mark_object (&ptr->current_tool_bar_items);
3956 mark_object (&ptr->desired_tool_bar_string);
3957 mark_object (&ptr->current_tool_bar_string);
41c28a37 3958#endif /* HAVE_WINDOW_SYSTEM */
169ee243 3959 }
7b07587b 3960 else if (GC_BOOL_VECTOR_P (obj))
707788bd
RS
3961 {
3962 register struct Lisp_Vector *ptr = XVECTOR (obj);
3963
3964 if (ptr->size & ARRAY_MARK_FLAG)
3965 break; /* Already marked */
4f5c1376 3966 CHECK_LIVE (live_vector_p);
707788bd
RS
3967 ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
3968 }
41c28a37
GM
3969 else if (GC_WINDOWP (obj))
3970 {
3971 register struct Lisp_Vector *ptr = XVECTOR (obj);
3972 struct window *w = XWINDOW (obj);
3973 register EMACS_INT size = ptr->size;
3974 /* The reason we use ptr1 is to avoid an apparent hardware bug
3975 that happens occasionally on the FSF's HP 300s.
3976 The bug is that a2 gets clobbered by recursive calls to mark_object.
3977 The clobberage seems to happen during function entry,
3978 perhaps in the moveml instruction.
3979 Yes, this is a crock, but we have to do it. */
3980 struct Lisp_Vector *volatile ptr1 = ptr;
3981 register int i;
3982
3983 /* Stop if already marked. */
3984 if (size & ARRAY_MARK_FLAG)
3985 break;
3986
3987 /* Mark it. */
4f5c1376 3988 CHECK_LIVE (live_vector_p);
41c28a37
GM
3989 ptr->size |= ARRAY_MARK_FLAG;
3990
3991 /* There is no Lisp data above The member CURRENT_MATRIX in
3992 struct WINDOW. Stop marking when that slot is reached. */
3993 for (i = 0;
3994 (char *) &ptr1->contents[i] < (char *) &w->current_matrix;
3995 i++)
3996 mark_object (&ptr1->contents[i]);
3997
3998 /* Mark glyphs for leaf windows. Marking window matrices is
3999 sufficient because frame matrices use the same glyph
4000 memory. */
4001 if (NILP (w->hchild)
4002 && NILP (w->vchild)
4003 && w->current_matrix)
4004 {
4005 mark_glyph_matrix (w->current_matrix);
4006 mark_glyph_matrix (w->desired_matrix);
4007 }
4008 }
4009 else if (GC_HASH_TABLE_P (obj))
4010 {
4011 struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
4012 EMACS_INT size = h->size;
4013
4014 /* Stop if already marked. */
4015 if (size & ARRAY_MARK_FLAG)
4016 break;
4f5c1376 4017
41c28a37 4018 /* Mark it. */
4f5c1376 4019 CHECK_LIVE (live_vector_p);
41c28a37
GM
4020 h->size |= ARRAY_MARK_FLAG;
4021
4022 /* Mark contents. */
4023 mark_object (&h->test);
4024 mark_object (&h->weak);
4025 mark_object (&h->rehash_size);
4026 mark_object (&h->rehash_threshold);
4027 mark_object (&h->hash);
4028 mark_object (&h->next);
4029 mark_object (&h->index);
4030 mark_object (&h->user_hash_function);
4031 mark_object (&h->user_cmp_function);
4032
4033 /* If hash table is not weak, mark all keys and values.
4034 For weak tables, mark only the vector. */
4035 if (GC_NILP (h->weak))
4036 mark_object (&h->key_and_value);
4037 else
4038 XVECTOR (h->key_and_value)->size |= ARRAY_MARK_FLAG;
4039
4040 }
04ff9756 4041 else
169ee243
RS
4042 {
4043 register struct Lisp_Vector *ptr = XVECTOR (obj);
4044 register EMACS_INT size = ptr->size;
4045 /* The reason we use ptr1 is to avoid an apparent hardware bug
4046 that happens occasionally on the FSF's HP 300s.
4047 The bug is that a2 gets clobbered by recursive calls to mark_object.
4048 The clobberage seems to happen during function entry,
4049 perhaps in the moveml instruction.
4050 Yes, this is a crock, but we have to do it. */
4051 struct Lisp_Vector *volatile ptr1 = ptr;
4052 register int i;
4053
4054 if (size & ARRAY_MARK_FLAG) break; /* Already marked */
4f5c1376 4055 CHECK_LIVE (live_vector_p);
169ee243
RS
4056 ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
4057 if (size & PSEUDOVECTOR_FLAG)
4058 size &= PSEUDOVECTOR_SIZE_MASK;
41c28a37 4059
169ee243
RS
4060 for (i = 0; i < size; i++) /* and then mark its elements */
4061 mark_object (&ptr1->contents[i]);
4062 }
4063 break;
7146af97 4064
7146af97
JB
4065 case Lisp_Symbol:
4066 {
41f54422
RS
4067 /* See comment above under Lisp_Vector for why this is volatile. */
4068 register struct Lisp_Symbol *volatile ptr = XSYMBOL (obj);
7146af97
JB
4069 struct Lisp_Symbol *ptrx;
4070
4071 if (XMARKBIT (ptr->plist)) break;
4f5c1376 4072 CHECK_ALLOCATED_AND_LIVE (live_symbol_p);
7146af97 4073 XMARK (ptr->plist);
7146af97
JB
4074 mark_object ((Lisp_Object *) &ptr->value);
4075 mark_object (&ptr->function);
4076 mark_object (&ptr->plist);
34400008
GM
4077
4078 if (!PURE_POINTER_P (ptr->name))
4079 MARK_STRING (ptr->name);
2e471eb5 4080 MARK_INTERVAL_TREE (ptr->name->intervals);
2e471eb5 4081
1c6bb482
RS
4082 /* Note that we do not mark the obarray of the symbol.
4083 It is safe not to do so because nothing accesses that
4084 slot except to check whether it is nil. */
7146af97
JB
4085 ptr = ptr->next;
4086 if (ptr)
4087 {
9149e743
KH
4088 /* For the benefit of the last_marked log. */
4089 objptr = (Lisp_Object *)&XSYMBOL (obj)->next;
b0846f52 4090 ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun */
7146af97 4091 XSETSYMBOL (obj, ptrx);
9149e743
KH
4092 /* We can't goto loop here because *objptr doesn't contain an
4093 actual Lisp_Object with valid datatype field. */
4094 goto loop2;
7146af97
JB
4095 }
4096 }
4097 break;
4098
a0a38eb7 4099 case Lisp_Misc:
4f5c1376 4100 CHECK_ALLOCATED_AND_LIVE (live_misc_p);
a5da44fe 4101 switch (XMISCTYPE (obj))
a0a38eb7
KH
4102 {
4103 case Lisp_Misc_Marker:
4104 XMARK (XMARKER (obj)->chain);
4105 /* DO NOT mark thru the marker's chain.
4106 The buffer's markers chain does not preserve markers from gc;
4107 instead, markers are removed from the chain when freed by gc. */
4108 break;
4109
465edf35
KH
4110 case Lisp_Misc_Buffer_Local_Value:
4111 case Lisp_Misc_Some_Buffer_Local_Value:
4112 {
4113 register struct Lisp_Buffer_Local_Value *ptr
4114 = XBUFFER_LOCAL_VALUE (obj);
a9faeabe
RS
4115 if (XMARKBIT (ptr->realvalue)) break;
4116 XMARK (ptr->realvalue);
465edf35
KH
4117 /* If the cdr is nil, avoid recursion for the car. */
4118 if (EQ (ptr->cdr, Qnil))
4119 {
a9faeabe 4120 objptr = &ptr->realvalue;
465edf35
KH
4121 goto loop;
4122 }
a9faeabe
RS
4123 mark_object (&ptr->realvalue);
4124 mark_object (&ptr->buffer);
4125 mark_object (&ptr->frame);
465edf35
KH
4126 /* See comment above under Lisp_Vector for why not use ptr here. */
4127 objptr = &XBUFFER_LOCAL_VALUE (obj)->cdr;
4128 goto loop;
4129 }
4130
c8616056
KH
4131 case Lisp_Misc_Intfwd:
4132 case Lisp_Misc_Boolfwd:
4133 case Lisp_Misc_Objfwd:
4134 case Lisp_Misc_Buffer_Objfwd:
b875d3f7 4135 case Lisp_Misc_Kboard_Objfwd:
c8616056
KH
4136 /* Don't bother with Lisp_Buffer_Objfwd,
4137 since all markable slots in current buffer marked anyway. */
4138 /* Don't need to do Lisp_Objfwd, since the places they point
4139 are protected with staticpro. */
4140 break;
4141
e202fa34
KH
4142 case Lisp_Misc_Overlay:
4143 {
4144 struct Lisp_Overlay *ptr = XOVERLAY (obj);
4145 if (!XMARKBIT (ptr->plist))
4146 {
4147 XMARK (ptr->plist);
4148 mark_object (&ptr->start);
4149 mark_object (&ptr->end);
4150 objptr = &ptr->plist;
4151 goto loop;
4152 }
4153 }
4154 break;
4155
a0a38eb7
KH
4156 default:
4157 abort ();
4158 }
7146af97
JB
4159 break;
4160
4161 case Lisp_Cons:
7146af97
JB
4162 {
4163 register struct Lisp_Cons *ptr = XCONS (obj);
4164 if (XMARKBIT (ptr->car)) break;
4f5c1376 4165 CHECK_ALLOCATED_AND_LIVE (live_cons_p);
7146af97 4166 XMARK (ptr->car);
c54ca951
RS
4167 /* If the cdr is nil, avoid recursion for the car. */
4168 if (EQ (ptr->cdr, Qnil))
4169 {
4170 objptr = &ptr->car;
c54ca951
RS
4171 goto loop;
4172 }
7146af97 4173 mark_object (&ptr->car);
41f54422 4174 /* See comment above under Lisp_Vector for why not use ptr here. */
70949dac 4175 objptr = &XCDR (obj);
7146af97
JB
4176 goto loop;
4177 }
4178
7146af97 4179 case Lisp_Float:
4f5c1376 4180 CHECK_ALLOCATED_AND_LIVE (live_float_p);
7146af97
JB
4181 XMARK (XFLOAT (obj)->type);
4182 break;
7146af97 4183
7146af97 4184 case Lisp_Int:
7146af97
JB
4185 break;
4186
4187 default:
4188 abort ();
4189 }
4f5c1376
GM
4190
4191#undef CHECK_LIVE
4192#undef CHECK_ALLOCATED
4193#undef CHECK_ALLOCATED_AND_LIVE
7146af97
JB
4194}
4195
4196/* Mark the pointers in a buffer structure. */
4197
4198static void
4199mark_buffer (buf)
4200 Lisp_Object buf;
4201{
7146af97
JB
4202 register struct buffer *buffer = XBUFFER (buf);
4203 register Lisp_Object *ptr;
30e3190a 4204 Lisp_Object base_buffer;
7146af97
JB
4205
4206 /* This is the buffer's markbit */
4207 mark_object (&buffer->name);
4208 XMARK (buffer->name);
4209
30e3190a 4210 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
d5e35230 4211
4c315bda
RS
4212 if (CONSP (buffer->undo_list))
4213 {
4214 Lisp_Object tail;
4215 tail = buffer->undo_list;
4216
4217 while (CONSP (tail))
4218 {
4219 register struct Lisp_Cons *ptr = XCONS (tail);
4220
4221 if (XMARKBIT (ptr->car))
4222 break;
4223 XMARK (ptr->car);
4224 if (GC_CONSP (ptr->car)
70949dac
KR
4225 && ! XMARKBIT (XCAR (ptr->car))
4226 && GC_MARKERP (XCAR (ptr->car)))
4c315bda 4227 {
70949dac
KR
4228 XMARK (XCAR (ptr->car));
4229 mark_object (&XCDR (ptr->car));
4c315bda
RS
4230 }
4231 else
4232 mark_object (&ptr->car);
4233
4234 if (CONSP (ptr->cdr))
4235 tail = ptr->cdr;
4236 else
4237 break;
4238 }
4239
70949dac 4240 mark_object (&XCDR (tail));
4c315bda
RS
4241 }
4242 else
4243 mark_object (&buffer->undo_list);
4244
7146af97
JB
4245 for (ptr = &buffer->name + 1;
4246 (char *)ptr < (char *)buffer + sizeof (struct buffer);
4247 ptr++)
4248 mark_object (ptr);
30e3190a
RS
4249
4250 /* If this is an indirect buffer, mark its base buffer. */
6b552283 4251 if (buffer->base_buffer && !XMARKBIT (buffer->base_buffer->name))
30e3190a
RS
4252 {
4253 XSETBUFFER (base_buffer, buffer->base_buffer);
4254 mark_buffer (base_buffer);
4255 }
7146af97 4256}
084b1a0c
KH
4257
4258
b875d3f7 4259/* Mark the pointers in the kboard objects. */
084b1a0c
KH
4260
4261static void
b875d3f7 4262mark_kboards ()
084b1a0c 4263{
b875d3f7 4264 KBOARD *kb;
b94daf1e 4265 Lisp_Object *p;
b875d3f7 4266 for (kb = all_kboards; kb; kb = kb->next_kboard)
084b1a0c 4267 {
b94daf1e
KH
4268 if (kb->kbd_macro_buffer)
4269 for (p = kb->kbd_macro_buffer; p < kb->kbd_macro_ptr; p++)
4270 mark_object (p);
4bfd0c4f
RS
4271 mark_object (&kb->Voverriding_terminal_local_map);
4272 mark_object (&kb->Vlast_command);
4273 mark_object (&kb->Vreal_last_command);
9671abc2 4274 mark_object (&kb->Vprefix_arg);
23c73c16 4275 mark_object (&kb->Vlast_prefix_arg);
b875d3f7 4276 mark_object (&kb->kbd_queue);
4bfd0c4f 4277 mark_object (&kb->defining_kbd_macro);
b875d3f7 4278 mark_object (&kb->Vlast_kbd_macro);
b94daf1e 4279 mark_object (&kb->Vsystem_key_alist);
6d03a6fd 4280 mark_object (&kb->system_key_syms);
4bfd0c4f 4281 mark_object (&kb->Vdefault_minibuffer_frame);
084b1a0c
KH
4282 }
4283}
41c28a37
GM
4284
4285
4286/* Value is non-zero if OBJ will survive the current GC because it's
4287 either marked or does not need to be marked to survive. */
4288
4289int
4290survives_gc_p (obj)
4291 Lisp_Object obj;
4292{
4293 int survives_p;
4294
4295 switch (XGCTYPE (obj))
4296 {
4297 case Lisp_Int:
4298 survives_p = 1;
4299 break;
4300
4301 case Lisp_Symbol:
4302 survives_p = XMARKBIT (XSYMBOL (obj)->plist);
4303 break;
4304
4305 case Lisp_Misc:
4306 switch (XMISCTYPE (obj))
4307 {
4308 case Lisp_Misc_Marker:
4309 survives_p = XMARKBIT (obj);
4310 break;
4311
4312 case Lisp_Misc_Buffer_Local_Value:
4313 case Lisp_Misc_Some_Buffer_Local_Value:
4314 survives_p = XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue);
4315 break;
4316
4317 case Lisp_Misc_Intfwd:
4318 case Lisp_Misc_Boolfwd:
4319 case Lisp_Misc_Objfwd:
4320 case Lisp_Misc_Buffer_Objfwd:
4321 case Lisp_Misc_Kboard_Objfwd:
4322 survives_p = 1;
4323 break;
4324
4325 case Lisp_Misc_Overlay:
4326 survives_p = XMARKBIT (XOVERLAY (obj)->plist);
4327 break;
4328
4329 default:
4330 abort ();
4331 }
4332 break;
4333
4334 case Lisp_String:
4335 {
4336 struct Lisp_String *s = XSTRING (obj);
2e471eb5 4337 survives_p = STRING_MARKED_P (s);
41c28a37
GM
4338 }
4339 break;
4340
4341 case Lisp_Vectorlike:
4342 if (GC_BUFFERP (obj))
4343 survives_p = XMARKBIT (XBUFFER (obj)->name);
4344 else if (GC_SUBRP (obj))
4345 survives_p = 1;
4346 else
4347 survives_p = XVECTOR (obj)->size & ARRAY_MARK_FLAG;
4348 break;
4349
4350 case Lisp_Cons:
4351 survives_p = XMARKBIT (XCAR (obj));
4352 break;
4353
41c28a37
GM
4354 case Lisp_Float:
4355 survives_p = XMARKBIT (XFLOAT (obj)->type);
4356 break;
41c28a37
GM
4357
4358 default:
4359 abort ();
4360 }
4361
34400008 4362 return survives_p || PURE_POINTER_P ((void *) XPNTR (obj));
41c28a37
GM
4363}
4364
4365
7146af97 4366\f
1a4f1e2c 4367/* Sweep: find all structures not marked, and free them. */
7146af97
JB
4368
4369static void
4370gc_sweep ()
4371{
41c28a37
GM
4372 /* Remove or mark entries in weak hash tables.
4373 This must be done before any object is unmarked. */
4374 sweep_weak_hash_tables ();
4375
2e471eb5 4376 sweep_strings ();
7146af97
JB
4377
4378 /* Put all unmarked conses on free list */
4379 {
4380 register struct cons_block *cblk;
6ca94ac9 4381 struct cons_block **cprev = &cons_block;
7146af97
JB
4382 register int lim = cons_block_index;
4383 register int num_free = 0, num_used = 0;
4384
4385 cons_free_list = 0;
4386
6ca94ac9 4387 for (cblk = cons_block; cblk; cblk = *cprev)
7146af97
JB
4388 {
4389 register int i;
6ca94ac9 4390 int this_free = 0;
7146af97
JB
4391 for (i = 0; i < lim; i++)
4392 if (!XMARKBIT (cblk->conses[i].car))
4393 {
6ca94ac9 4394 this_free++;
1cd5fe6a 4395 *(struct Lisp_Cons **)&cblk->conses[i].cdr = cons_free_list;
7146af97 4396 cons_free_list = &cblk->conses[i];
34400008
GM
4397#if GC_MARK_STACK
4398 cons_free_list->car = Vdead;
4399#endif
7146af97
JB
4400 }
4401 else
4402 {
4403 num_used++;
4404 XUNMARK (cblk->conses[i].car);
4405 }
4406 lim = CONS_BLOCK_SIZE;
6ca94ac9
KH
4407 /* If this block contains only free conses and we have already
4408 seen more than two blocks worth of free conses then deallocate
4409 this block. */
6feef451 4410 if (this_free == CONS_BLOCK_SIZE && num_free > CONS_BLOCK_SIZE)
6ca94ac9 4411 {
6ca94ac9
KH
4412 *cprev = cblk->next;
4413 /* Unhook from the free list. */
4414 cons_free_list = *(struct Lisp_Cons **) &cblk->conses[0].cdr;
c8099634
RS
4415 lisp_free (cblk);
4416 n_cons_blocks--;
6ca94ac9
KH
4417 }
4418 else
6feef451
AS
4419 {
4420 num_free += this_free;
4421 cprev = &cblk->next;
4422 }
7146af97
JB
4423 }
4424 total_conses = num_used;
4425 total_free_conses = num_free;
4426 }
4427
7146af97
JB
4428 /* Put all unmarked floats on free list */
4429 {
4430 register struct float_block *fblk;
6ca94ac9 4431 struct float_block **fprev = &float_block;
7146af97
JB
4432 register int lim = float_block_index;
4433 register int num_free = 0, num_used = 0;
4434
4435 float_free_list = 0;
4436
6ca94ac9 4437 for (fblk = float_block; fblk; fblk = *fprev)
7146af97
JB
4438 {
4439 register int i;
6ca94ac9 4440 int this_free = 0;
7146af97
JB
4441 for (i = 0; i < lim; i++)
4442 if (!XMARKBIT (fblk->floats[i].type))
4443 {
6ca94ac9 4444 this_free++;
1cd5fe6a 4445 *(struct Lisp_Float **)&fblk->floats[i].data = float_free_list;
7146af97 4446 float_free_list = &fblk->floats[i];
34400008
GM
4447#if GC_MARK_STACK
4448 float_free_list->type = Vdead;
4449#endif
7146af97
JB
4450 }
4451 else
4452 {
4453 num_used++;
4454 XUNMARK (fblk->floats[i].type);
4455 }
4456 lim = FLOAT_BLOCK_SIZE;
6ca94ac9
KH
4457 /* If this block contains only free floats and we have already
4458 seen more than two blocks worth of free floats then deallocate
4459 this block. */
6feef451 4460 if (this_free == FLOAT_BLOCK_SIZE && num_free > FLOAT_BLOCK_SIZE)
6ca94ac9 4461 {
6ca94ac9
KH
4462 *fprev = fblk->next;
4463 /* Unhook from the free list. */
4464 float_free_list = *(struct Lisp_Float **) &fblk->floats[0].data;
c8099634
RS
4465 lisp_free (fblk);
4466 n_float_blocks--;
6ca94ac9
KH
4467 }
4468 else
6feef451
AS
4469 {
4470 num_free += this_free;
4471 fprev = &fblk->next;
4472 }
7146af97
JB
4473 }
4474 total_floats = num_used;
4475 total_free_floats = num_free;
4476 }
7146af97 4477
d5e35230
JA
4478 /* Put all unmarked intervals on free list */
4479 {
4480 register struct interval_block *iblk;
6ca94ac9 4481 struct interval_block **iprev = &interval_block;
d5e35230
JA
4482 register int lim = interval_block_index;
4483 register int num_free = 0, num_used = 0;
4484
4485 interval_free_list = 0;
4486
6ca94ac9 4487 for (iblk = interval_block; iblk; iblk = *iprev)
d5e35230
JA
4488 {
4489 register int i;
6ca94ac9 4490 int this_free = 0;
d5e35230
JA
4491
4492 for (i = 0; i < lim; i++)
4493 {
4494 if (! XMARKBIT (iblk->intervals[i].plist))
4495 {
439d5cb4 4496 SET_INTERVAL_PARENT (&iblk->intervals[i], interval_free_list);
d5e35230 4497 interval_free_list = &iblk->intervals[i];
6ca94ac9 4498 this_free++;
d5e35230
JA
4499 }
4500 else
4501 {
4502 num_used++;
4503 XUNMARK (iblk->intervals[i].plist);
4504 }
4505 }
4506 lim = INTERVAL_BLOCK_SIZE;
6ca94ac9
KH
4507 /* If this block contains only free intervals and we have already
4508 seen more than two blocks worth of free intervals then
4509 deallocate this block. */
6feef451 4510 if (this_free == INTERVAL_BLOCK_SIZE && num_free > INTERVAL_BLOCK_SIZE)
6ca94ac9 4511 {
6ca94ac9
KH
4512 *iprev = iblk->next;
4513 /* Unhook from the free list. */
439d5cb4 4514 interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
c8099634
RS
4515 lisp_free (iblk);
4516 n_interval_blocks--;
6ca94ac9
KH
4517 }
4518 else
6feef451
AS
4519 {
4520 num_free += this_free;
4521 iprev = &iblk->next;
4522 }
d5e35230
JA
4523 }
4524 total_intervals = num_used;
4525 total_free_intervals = num_free;
4526 }
d5e35230 4527
7146af97
JB
4528 /* Put all unmarked symbols on free list */
4529 {
4530 register struct symbol_block *sblk;
6ca94ac9 4531 struct symbol_block **sprev = &symbol_block;
7146af97
JB
4532 register int lim = symbol_block_index;
4533 register int num_free = 0, num_used = 0;
4534
4535 symbol_free_list = 0;
4536
6ca94ac9 4537 for (sblk = symbol_block; sblk; sblk = *sprev)
7146af97
JB
4538 {
4539 register int i;
6ca94ac9 4540 int this_free = 0;
7146af97
JB
4541 for (i = 0; i < lim; i++)
4542 if (!XMARKBIT (sblk->symbols[i].plist))
4543 {
85481507 4544 *(struct Lisp_Symbol **)&sblk->symbols[i].value = symbol_free_list;
7146af97 4545 symbol_free_list = &sblk->symbols[i];
34400008
GM
4546#if GC_MARK_STACK
4547 symbol_free_list->function = Vdead;
4548#endif
6ca94ac9 4549 this_free++;
7146af97
JB
4550 }
4551 else
4552 {
4553 num_used++;
34400008
GM
4554 if (!PURE_POINTER_P (sblk->symbols[i].name))
4555 UNMARK_STRING (sblk->symbols[i].name);
7146af97
JB
4556 XUNMARK (sblk->symbols[i].plist);
4557 }
4558 lim = SYMBOL_BLOCK_SIZE;
6ca94ac9
KH
4559 /* If this block contains only free symbols and we have already
4560 seen more than two blocks worth of free symbols then deallocate
4561 this block. */
6feef451 4562 if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)
6ca94ac9 4563 {
6ca94ac9
KH
4564 *sprev = sblk->next;
4565 /* Unhook from the free list. */
4566 symbol_free_list = *(struct Lisp_Symbol **)&sblk->symbols[0].value;
c8099634
RS
4567 lisp_free (sblk);
4568 n_symbol_blocks--;
6ca94ac9
KH
4569 }
4570 else
6feef451
AS
4571 {
4572 num_free += this_free;
4573 sprev = &sblk->next;
4574 }
7146af97
JB
4575 }
4576 total_symbols = num_used;
4577 total_free_symbols = num_free;
4578 }
4579
a9faeabe
RS
4580 /* Put all unmarked misc's on free list.
4581 For a marker, first unchain it from the buffer it points into. */
7146af97
JB
4582 {
4583 register struct marker_block *mblk;
6ca94ac9 4584 struct marker_block **mprev = &marker_block;
7146af97
JB
4585 register int lim = marker_block_index;
4586 register int num_free = 0, num_used = 0;
4587
4588 marker_free_list = 0;
4589
6ca94ac9 4590 for (mblk = marker_block; mblk; mblk = *mprev)
7146af97
JB
4591 {
4592 register int i;
6ca94ac9 4593 int this_free = 0;
26b926e1 4594 EMACS_INT already_free = -1;
fa05e253 4595
7146af97 4596 for (i = 0; i < lim; i++)
465edf35
KH
4597 {
4598 Lisp_Object *markword;
a5da44fe 4599 switch (mblk->markers[i].u_marker.type)
465edf35
KH
4600 {
4601 case Lisp_Misc_Marker:
4602 markword = &mblk->markers[i].u_marker.chain;
4603 break;
4604 case Lisp_Misc_Buffer_Local_Value:
4605 case Lisp_Misc_Some_Buffer_Local_Value:
a9faeabe 4606 markword = &mblk->markers[i].u_buffer_local_value.realvalue;
465edf35 4607 break;
e202fa34
KH
4608 case Lisp_Misc_Overlay:
4609 markword = &mblk->markers[i].u_overlay.plist;
4610 break;
fa05e253
RS
4611 case Lisp_Misc_Free:
4612 /* If the object was already free, keep it
4613 on the free list. */
74d84334 4614 markword = (Lisp_Object *) &already_free;
fa05e253 4615 break;
465edf35
KH
4616 default:
4617 markword = 0;
e202fa34 4618 break;
465edf35
KH
4619 }
4620 if (markword && !XMARKBIT (*markword))
4621 {
4622 Lisp_Object tem;
a5da44fe 4623 if (mblk->markers[i].u_marker.type == Lisp_Misc_Marker)
465edf35
KH
4624 {
4625 /* tem1 avoids Sun compiler bug */
4626 struct Lisp_Marker *tem1 = &mblk->markers[i].u_marker;
4627 XSETMARKER (tem, tem1);
4628 unchain_marker (tem);
4629 }
fa05e253
RS
4630 /* Set the type of the freed object to Lisp_Misc_Free.
4631 We could leave the type alone, since nobody checks it,
465edf35 4632 but this might catch bugs faster. */
a5da44fe 4633 mblk->markers[i].u_marker.type = Lisp_Misc_Free;
465edf35
KH
4634 mblk->markers[i].u_free.chain = marker_free_list;
4635 marker_free_list = &mblk->markers[i];
6ca94ac9 4636 this_free++;
465edf35
KH
4637 }
4638 else
4639 {
4640 num_used++;
4641 if (markword)
4642 XUNMARK (*markword);
4643 }
4644 }
7146af97 4645 lim = MARKER_BLOCK_SIZE;
6ca94ac9
KH
4646 /* If this block contains only free markers and we have already
4647 seen more than two blocks worth of free markers then deallocate
4648 this block. */
6feef451 4649 if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE)
6ca94ac9 4650 {
6ca94ac9
KH
4651 *mprev = mblk->next;
4652 /* Unhook from the free list. */
4653 marker_free_list = mblk->markers[0].u_free.chain;
c8099634
RS
4654 lisp_free (mblk);
4655 n_marker_blocks--;
6ca94ac9
KH
4656 }
4657 else
6feef451
AS
4658 {
4659 num_free += this_free;
4660 mprev = &mblk->next;
4661 }
7146af97
JB
4662 }
4663
4664 total_markers = num_used;
4665 total_free_markers = num_free;
4666 }
4667
4668 /* Free all unmarked buffers */
4669 {
4670 register struct buffer *buffer = all_buffers, *prev = 0, *next;
4671
4672 while (buffer)
4673 if (!XMARKBIT (buffer->name))
4674 {
4675 if (prev)
4676 prev->next = buffer->next;
4677 else
4678 all_buffers = buffer->next;
4679 next = buffer->next;
34400008 4680 lisp_free (buffer);
7146af97
JB
4681 buffer = next;
4682 }
4683 else
4684 {
4685 XUNMARK (buffer->name);
30e3190a 4686 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer));
7146af97
JB
4687 prev = buffer, buffer = buffer->next;
4688 }
4689 }
4690
7146af97
JB
4691 /* Free all unmarked vectors */
4692 {
4693 register struct Lisp_Vector *vector = all_vectors, *prev = 0, *next;
4694 total_vector_size = 0;
4695
4696 while (vector)
4697 if (!(vector->size & ARRAY_MARK_FLAG))
4698 {
4699 if (prev)
4700 prev->next = vector->next;
4701 else
4702 all_vectors = vector->next;
4703 next = vector->next;
c8099634
RS
4704 lisp_free (vector);
4705 n_vectors--;
7146af97 4706 vector = next;
41c28a37 4707
7146af97
JB
4708 }
4709 else
4710 {
4711 vector->size &= ~ARRAY_MARK_FLAG;
fa05e253
RS
4712 if (vector->size & PSEUDOVECTOR_FLAG)
4713 total_vector_size += (PSEUDOVECTOR_SIZE_MASK & vector->size);
4714 else
4715 total_vector_size += vector->size;
7146af97
JB
4716 prev = vector, vector = vector->next;
4717 }
4718 }
7146af97 4719}
7146af97 4720
7146af97 4721
7146af97 4722
7146af97 4723\f
20d24714
JB
4724/* Debugging aids. */
4725
31ce1c91 4726DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0,
20d24714
JB
4727 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
4728This may be helpful in debugging Emacs's memory usage.\n\
e41ae81f 4729We divide the value by 1024 to make sure it fits in a Lisp integer.")
20d24714
JB
4730 ()
4731{
4732 Lisp_Object end;
4733
45d12a89 4734 XSETINT (end, (EMACS_INT) sbrk (0) / 1024);
20d24714
JB
4735
4736 return end;
4737}
4738
310ea200
RS
4739DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0,
4740 "Return a list of counters that measure how much consing there has been.\n\
4741Each of these counters increments for a certain kind of object.\n\
4742The counters wrap around from the largest positive integer to zero.\n\
4743Garbage collection does not decrease them.\n\
4744The elements of the value are as follows:\n\
2e471eb5 4745 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)\n\
310ea200
RS
4746All are in units of 1 = one object consed\n\
4747except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
4748objects consed.\n\
4749MISCS include overlays, markers, and some internal types.\n\
4750Frames, windows, buffers, and subprocesses count as vectors\n\
4751 (but the contents of a buffer's text do not count here).")
4752 ()
4753{
2e471eb5 4754 Lisp_Object consed[8];
310ea200 4755
2e471eb5 4756 XSETINT (consed[0],
290c8f1e 4757 cons_cells_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
2e471eb5 4758 XSETINT (consed[1],
290c8f1e 4759 floats_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
2e471eb5 4760 XSETINT (consed[2],
290c8f1e 4761 vector_cells_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
2e471eb5 4762 XSETINT (consed[3],
290c8f1e 4763 symbols_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
2e471eb5 4764 XSETINT (consed[4],
290c8f1e 4765 string_chars_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
2e471eb5 4766 XSETINT (consed[5],
290c8f1e 4767 misc_objects_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
2e471eb5 4768 XSETINT (consed[6],
290c8f1e 4769 intervals_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
2e471eb5
GM
4770 XSETINT (consed[7],
4771 strings_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
310ea200 4772
2e471eb5 4773 return Flist (8, consed);
310ea200 4774}
e0b8c689
KR
4775
4776int suppress_checking;
4777void
4778die (msg, file, line)
4779 const char *msg;
4780 const char *file;
4781 int line;
4782{
4783 fprintf (stderr, "\r\nEmacs fatal error: %s:%d: %s\r\n",
4784 file, line, msg);
4785 abort ();
4786}
20d24714 4787\f
7146af97
JB
4788/* Initialization */
4789
dfcf069d 4790void
7146af97
JB
4791init_alloc_once ()
4792{
4793 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
4794 pureptr = 0;
34400008
GM
4795#if GC_MARK_STACK
4796 mem_init ();
4797 Vdead = make_pure_string ("DEAD", 4, 4, 0);
4798#endif
4c0be5f4
JB
4799#ifdef HAVE_SHM
4800 pure_size = PURESIZE;
4801#endif
7146af97
JB
4802 all_vectors = 0;
4803 ignore_warnings = 1;
d1658221
RS
4804#ifdef DOUG_LEA_MALLOC
4805 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
4806 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
81d492d5 4807 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* max. number of mmap'ed areas */
d1658221 4808#endif
7146af97
JB
4809 init_strings ();
4810 init_cons ();
4811 init_symbol ();
4812 init_marker ();
7146af97 4813 init_float ();
34400008 4814 init_intervals ();
d5e35230 4815
276cbe5a
RS
4816#ifdef REL_ALLOC
4817 malloc_hysteresis = 32;
4818#else
4819 malloc_hysteresis = 0;
4820#endif
4821
4822 spare_memory = (char *) malloc (SPARE_MEMORY);
4823
7146af97
JB
4824 ignore_warnings = 0;
4825 gcprolist = 0;
630686c8 4826 byte_stack_list = 0;
7146af97
JB
4827 staticidx = 0;
4828 consing_since_gc = 0;
7d179cea 4829 gc_cons_threshold = 100000 * sizeof (Lisp_Object);
7146af97
JB
4830#ifdef VIRT_ADDR_VARIES
4831 malloc_sbrk_unused = 1<<22; /* A large number */
4832 malloc_sbrk_used = 100000; /* as reasonable as any number */
4833#endif /* VIRT_ADDR_VARIES */
4834}
4835
dfcf069d 4836void
7146af97
JB
4837init_alloc ()
4838{
4839 gcprolist = 0;
630686c8 4840 byte_stack_list = 0;
182ff242
GM
4841#if GC_MARK_STACK
4842#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4843 setjmp_tested_p = longjmps_done = 0;
4844#endif
4845#endif
7146af97
JB
4846}
4847
4848void
4849syms_of_alloc ()
4850{
4851 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold,
4852 "*Number of bytes of consing between garbage collections.\n\
4853Garbage collection can happen automatically once this many bytes have been\n\
4854allocated since the last garbage collection. All data types count.\n\n\
4855Garbage collection happens automatically only when `eval' is called.\n\n\
4856By binding this temporarily to a large number, you can effectively\n\
4857prevent garbage collection during a part of the program.");
4858
4859 DEFVAR_INT ("pure-bytes-used", &pureptr,
4860 "Number of bytes of sharable Lisp data allocated so far.");
4861
0819585c
RS
4862 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed,
4863 "Number of cons cells that have been consed so far.");
4864
4865 DEFVAR_INT ("floats-consed", &floats_consed,
4866 "Number of floats that have been consed so far.");
4867
4868 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed,
4869 "Number of vector cells that have been consed so far.");
4870
4871 DEFVAR_INT ("symbols-consed", &symbols_consed,
4872 "Number of symbols that have been consed so far.");
4873
4874 DEFVAR_INT ("string-chars-consed", &string_chars_consed,
4875 "Number of string characters that have been consed so far.");
4876
4877 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed,
4878 "Number of miscellaneous objects that have been consed so far.");
4879
4880 DEFVAR_INT ("intervals-consed", &intervals_consed,
4881 "Number of intervals that have been consed so far.");
4882
2e471eb5
GM
4883 DEFVAR_INT ("strings-consed", &strings_consed,
4884 "Number of strings that have been consed so far.");
4885
7146af97
JB
4886 DEFVAR_LISP ("purify-flag", &Vpurify_flag,
4887 "Non-nil means loading Lisp code in order to dump an executable.\n\
4888This means that certain objects should be allocated in shared (pure) space.");
4889
502b9b64 4890 DEFVAR_INT ("undo-limit", &undo_limit,
7146af97 4891 "Keep no more undo information once it exceeds this size.\n\
502b9b64 4892This limit is applied when garbage collection happens.\n\
7146af97
JB
4893The size is counted as the number of bytes occupied,\n\
4894which includes both saved text and other data.");
502b9b64 4895 undo_limit = 20000;
7146af97 4896
502b9b64 4897 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit,
7146af97
JB
4898 "Don't keep more than this much size of undo information.\n\
4899A command which pushes past this size is itself forgotten.\n\
502b9b64 4900This limit is applied when garbage collection happens.\n\
7146af97
JB
4901The size is counted as the number of bytes occupied,\n\
4902which includes both saved text and other data.");
502b9b64 4903 undo_strong_limit = 30000;
7146af97 4904
299585ee
RS
4905 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages,
4906 "Non-nil means display messages at start and end of garbage collection.");
4907 garbage_collection_messages = 0;
4908
bcb61d60
KH
4909 /* We build this in advance because if we wait until we need it, we might
4910 not be able to allocate the memory to hold it. */
cf3540e4 4911 memory_signal_data
276cbe5a 4912 = Fcons (Qerror, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil));
bcb61d60
KH
4913 staticpro (&memory_signal_data);
4914
e8197642
RS
4915 staticpro (&Qgc_cons_threshold);
4916 Qgc_cons_threshold = intern ("gc-cons-threshold");
4917
a59de17b
RS
4918 staticpro (&Qchar_table_extra_slots);
4919 Qchar_table_extra_slots = intern ("char-table-extra-slots");
4920
7146af97
JB
4921 defsubr (&Scons);
4922 defsubr (&Slist);
4923 defsubr (&Svector);
4924 defsubr (&Smake_byte_code);
4925 defsubr (&Smake_list);
4926 defsubr (&Smake_vector);
7b07587b 4927 defsubr (&Smake_char_table);
7146af97 4928 defsubr (&Smake_string);
7b07587b 4929 defsubr (&Smake_bool_vector);
7146af97
JB
4930 defsubr (&Smake_symbol);
4931 defsubr (&Smake_marker);
4932 defsubr (&Spurecopy);
4933 defsubr (&Sgarbage_collect);
20d24714 4934 defsubr (&Smemory_limit);
310ea200 4935 defsubr (&Smemory_use_counts);
34400008
GM
4936
4937#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4938 defsubr (&Sgc_status);
4939#endif
7146af97 4940}