1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
24 #include "intervals.h"
30 #include "blockinput.h"
33 #include "syssignal.h"
35 #define max(A,B) ((A) > (B) ? (A) : (B))
37 /* Macro to verify that storage intended for Lisp objects is not
38 out of range to fit in the space for a pointer.
39 ADDRESS is the start of the block, and SIZE
40 is the amount of space within which objects can start. */
41 #define VALIDATE_LISP_STORAGE(address, size) \
45 XSETCONS (val, (char *) address + size); \
46 if ((char *) XCONS (val) != (char *) address + size) \
53 /* Number of bytes of consing done since the last gc */
56 /* Number of bytes of consing since gc before another gc should be done. */
57 int gc_cons_threshold
;
59 /* Nonzero during gc */
62 #ifndef VIRT_ADDR_VARIES
64 #endif /* VIRT_ADDR_VARIES */
67 #ifndef VIRT_ADDR_VARIES
69 #endif /* VIRT_ADDR_VARIES */
70 int malloc_sbrk_unused
;
72 /* Two limits controlling how much undo information to keep. */
74 int undo_strong_limit
;
76 /* Non-nil means defun should do purecopy on the function definition */
77 Lisp_Object Vpurify_flag
;
80 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
81 #define PUREBEG (char *) pure
83 #define pure PURE_SEG_BITS /* Use shared memory segment */
84 #define PUREBEG (char *)PURE_SEG_BITS
86 /* This variable is used only by the XPNTR macro when HAVE_SHM is
87 defined. If we used the PURESIZE macro directly there, that would
88 make most of emacs dependent on puresize.h, which we don't want -
89 you should be able to change that without too much recompilation.
90 So map_in_data initializes pure_size, and the dependencies work
93 #endif /* not HAVE_SHM */
95 /* Index in pure at which next pure object will be allocated. */
98 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
99 char *pending_malloc_warning
;
101 /* Pre-computed signal argument for use when memory is exhausted. */
102 Lisp_Object memory_signal_data
;
104 /* Maximum amount of C stack to save when a GC happens. */
106 #ifndef MAX_SAVE_STACK
107 #define MAX_SAVE_STACK 16000
110 /* Buffer in which we save a copy of the C stack at each GC. */
115 /* Non-zero means ignore malloc warnings. Set during initialization. */
118 static void mark_object (), mark_buffer ();
119 static void clear_marks (), gc_sweep ();
120 static void compact_strings ();
122 /* Versions of malloc and realloc that print warnings as memory gets full. */
125 malloc_warning_1 (str
)
128 Fprinc (str
, Vstandard_output
);
129 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
130 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
131 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
135 /* malloc calls this if it finds we are near exhausting storage */
139 pending_malloc_warning
= str
;
142 display_malloc_warning ()
144 register Lisp_Object val
;
146 val
= build_string (pending_malloc_warning
);
147 pending_malloc_warning
= 0;
148 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
151 /* Called if malloc returns zero */
154 /* This used to call error, but if we've run out of memory, we could get
155 infinite recursion trying to build the string. */
157 Fsignal (Qerror
, memory_signal_data
);
160 /* like malloc routines but check for no memory and block interrupt input. */
169 val
= (long *) malloc (size
);
172 if (!val
&& size
) memory_full ();
177 xrealloc (block
, size
)
184 /* We must call malloc explicitly when BLOCK is 0, since some
185 reallocs don't do this. */
187 val
= (long *) malloc (size
);
189 val
= (long *) realloc (block
, size
);
192 if (!val
&& size
) memory_full ();
206 /* Arranging to disable input signals while we're in malloc.
208 This only works with GNU malloc. To help out systems which can't
209 use GNU malloc, all the calls to malloc, realloc, and free
210 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
211 pairs; unfortunately, we have no idea what C library functions
212 might call malloc, so we can't really protect them unless you're
213 using GNU malloc. Fortunately, most of the major operating can use
216 #ifndef SYSTEM_MALLOC
217 extern void * (*__malloc_hook
) ();
218 static void * (*old_malloc_hook
) ();
219 extern void * (*__realloc_hook
) ();
220 static void * (*old_realloc_hook
) ();
221 extern void (*__free_hook
) ();
222 static void (*old_free_hook
) ();
225 emacs_blocked_free (ptr
)
229 __free_hook
= old_free_hook
;
231 __free_hook
= emacs_blocked_free
;
236 emacs_blocked_malloc (size
)
242 __malloc_hook
= old_malloc_hook
;
243 value
= (void *) malloc (size
);
244 __malloc_hook
= emacs_blocked_malloc
;
251 emacs_blocked_realloc (ptr
, size
)
258 __realloc_hook
= old_realloc_hook
;
259 value
= (void *) realloc (ptr
, size
);
260 __realloc_hook
= emacs_blocked_realloc
;
267 uninterrupt_malloc ()
269 old_free_hook
= __free_hook
;
270 __free_hook
= emacs_blocked_free
;
272 old_malloc_hook
= __malloc_hook
;
273 __malloc_hook
= emacs_blocked_malloc
;
275 old_realloc_hook
= __realloc_hook
;
276 __realloc_hook
= emacs_blocked_realloc
;
280 /* Interval allocation. */
282 #ifdef USE_TEXT_PROPERTIES
283 #define INTERVAL_BLOCK_SIZE \
284 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
286 struct interval_block
288 struct interval_block
*next
;
289 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
292 struct interval_block
*interval_block
;
293 static int interval_block_index
;
295 INTERVAL interval_free_list
;
301 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
302 interval_block
->next
= 0;
303 bzero (interval_block
->intervals
, sizeof interval_block
->intervals
);
304 interval_block_index
= 0;
305 interval_free_list
= 0;
308 #define INIT_INTERVALS init_intervals ()
315 if (interval_free_list
)
317 val
= interval_free_list
;
318 interval_free_list
= interval_free_list
->parent
;
322 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
324 register struct interval_block
*newi
325 = (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
327 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
328 newi
->next
= interval_block
;
329 interval_block
= newi
;
330 interval_block_index
= 0;
332 val
= &interval_block
->intervals
[interval_block_index
++];
334 consing_since_gc
+= sizeof (struct interval
);
335 RESET_INTERVAL (val
);
339 static int total_free_intervals
, total_intervals
;
341 /* Mark the pointers of one interval. */
344 mark_interval (i
, dummy
)
348 if (XMARKBIT (i
->plist
))
350 mark_object (&i
->plist
);
355 mark_interval_tree (tree
)
356 register INTERVAL tree
;
358 /* No need to test if this tree has been marked already; this
359 function is always called through the MARK_INTERVAL_TREE macro,
360 which takes care of that. */
362 /* XMARK expands to an assignment; the LHS of an assignment can't be
364 XMARK (* (Lisp_Object
*) &tree
->parent
);
366 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
369 #define MARK_INTERVAL_TREE(i) \
371 if (!NULL_INTERVAL_P (i) \
372 && ! XMARKBIT ((Lisp_Object) i->parent)) \
373 mark_interval_tree (i); \
376 /* The oddity in the call to XUNMARK is necessary because XUNMARK
377 expands to an assignment to its argument, and most C compilers don't
378 support casts on the left operand of `='. */
379 #define UNMARK_BALANCE_INTERVALS(i) \
381 if (! NULL_INTERVAL_P (i)) \
383 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
384 (i) = balance_intervals (i); \
388 #else /* no interval use */
390 #define INIT_INTERVALS
392 #define UNMARK_BALANCE_INTERVALS(i)
393 #define MARK_INTERVAL_TREE(i)
395 #endif /* no interval use */
397 /* Floating point allocation. */
399 #ifdef LISP_FLOAT_TYPE
400 /* Allocation of float cells, just like conses */
401 /* We store float cells inside of float_blocks, allocating a new
402 float_block with malloc whenever necessary. Float cells reclaimed by
403 GC are put on a free list to be reallocated before allocating
404 any new float cells from the latest float_block.
406 Each float_block is just under 1020 bytes long,
407 since malloc really allocates in units of powers of two
408 and uses 4 bytes for its own overhead. */
410 #define FLOAT_BLOCK_SIZE \
411 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
415 struct float_block
*next
;
416 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
419 struct float_block
*float_block
;
420 int float_block_index
;
422 struct Lisp_Float
*float_free_list
;
427 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
428 float_block
->next
= 0;
429 bzero (float_block
->floats
, sizeof float_block
->floats
);
430 float_block_index
= 0;
434 /* Explicitly free a float cell. */
436 struct Lisp_Float
*ptr
;
438 *(struct Lisp_Float
**)&ptr
->type
= float_free_list
;
439 float_free_list
= ptr
;
443 make_float (float_value
)
446 register Lisp_Object val
;
450 XSETFLOAT (val
, float_free_list
);
451 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->type
;
455 if (float_block_index
== FLOAT_BLOCK_SIZE
)
457 register struct float_block
*new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
458 VALIDATE_LISP_STORAGE (new, sizeof *new);
459 new->next
= float_block
;
461 float_block_index
= 0;
463 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
465 XFLOAT (val
)->data
= float_value
;
466 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
467 consing_since_gc
+= sizeof (struct Lisp_Float
);
471 #endif /* LISP_FLOAT_TYPE */
473 /* Allocation of cons cells */
474 /* We store cons cells inside of cons_blocks, allocating a new
475 cons_block with malloc whenever necessary. Cons cells reclaimed by
476 GC are put on a free list to be reallocated before allocating
477 any new cons cells from the latest cons_block.
479 Each cons_block is just under 1020 bytes long,
480 since malloc really allocates in units of powers of two
481 and uses 4 bytes for its own overhead. */
483 #define CONS_BLOCK_SIZE \
484 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
488 struct cons_block
*next
;
489 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
492 struct cons_block
*cons_block
;
493 int cons_block_index
;
495 struct Lisp_Cons
*cons_free_list
;
500 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
501 cons_block
->next
= 0;
502 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
503 cons_block_index
= 0;
507 /* Explicitly free a cons cell. */
509 struct Lisp_Cons
*ptr
;
511 *(struct Lisp_Cons
**)&ptr
->car
= cons_free_list
;
512 cons_free_list
= ptr
;
515 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
516 "Create a new cons, give it CAR and CDR as components, and return it.")
518 Lisp_Object car
, cdr
;
520 register Lisp_Object val
;
524 XSETCONS (val
, cons_free_list
);
525 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->car
;
529 if (cons_block_index
== CONS_BLOCK_SIZE
)
531 register struct cons_block
*new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
532 VALIDATE_LISP_STORAGE (new, sizeof *new);
533 new->next
= cons_block
;
535 cons_block_index
= 0;
537 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
539 XCONS (val
)->car
= car
;
540 XCONS (val
)->cdr
= cdr
;
541 consing_since_gc
+= sizeof (struct Lisp_Cons
);
545 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
546 "Return a newly created list with specified arguments as elements.\n\
547 Any number of arguments, even zero arguments, are allowed.")
550 register Lisp_Object
*args
;
552 register Lisp_Object len
, val
, val_tail
;
554 XSETFASTINT (len
, nargs
);
555 val
= Fmake_list (len
, Qnil
);
557 while (!NILP (val_tail
))
559 XCONS (val_tail
)->car
= *args
++;
560 val_tail
= XCONS (val_tail
)->cdr
;
565 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
566 "Return a newly created list of length LENGTH, with each element being INIT.")
568 register Lisp_Object length
, init
;
570 register Lisp_Object val
;
573 CHECK_NATNUM (length
, 0);
574 size
= XFASTINT (length
);
578 val
= Fcons (init
, val
);
582 /* Allocation of vectors */
584 struct Lisp_Vector
*all_vectors
;
587 allocate_vectorlike (len
)
590 struct Lisp_Vector
*p
;
592 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
593 + (len
- 1) * sizeof (Lisp_Object
));
594 VALIDATE_LISP_STORAGE (p
, 0);
595 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
596 + (len
- 1) * sizeof (Lisp_Object
));
598 p
->next
= all_vectors
;
603 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
604 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
605 See also the function `vector'.")
607 register Lisp_Object length
, init
;
610 register EMACS_INT sizei
;
612 register struct Lisp_Vector
*p
;
614 CHECK_NATNUM (length
, 0);
615 sizei
= XFASTINT (length
);
617 p
= allocate_vectorlike (sizei
);
619 for (index
= 0; index
< sizei
; index
++)
620 p
->contents
[index
] = init
;
622 XSETVECTOR (vector
, p
);
626 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
627 "Return a newly created vector with specified arguments as elements.\n\
628 Any number of arguments, even zero arguments, are allowed.")
633 register Lisp_Object len
, val
;
635 register struct Lisp_Vector
*p
;
637 XSETFASTINT (len
, nargs
);
638 val
= Fmake_vector (len
, Qnil
);
640 for (index
= 0; index
< nargs
; index
++)
641 p
->contents
[index
] = args
[index
];
645 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
646 "Create a byte-code object with specified arguments as elements.\n\
647 The arguments should be the arglist, bytecode-string, constant vector,\n\
648 stack size, (optional) doc string, and (optional) interactive spec.\n\
649 The first four arguments are required; at most six have any\n\
655 register Lisp_Object len
, val
;
657 register struct Lisp_Vector
*p
;
659 XSETFASTINT (len
, nargs
);
660 if (!NILP (Vpurify_flag
))
661 val
= make_pure_vector (len
);
663 val
= Fmake_vector (len
, Qnil
);
665 for (index
= 0; index
< nargs
; index
++)
667 if (!NILP (Vpurify_flag
))
668 args
[index
] = Fpurecopy (args
[index
]);
669 p
->contents
[index
] = args
[index
];
671 XSETCOMPILED (val
, val
);
675 /* Allocation of symbols.
676 Just like allocation of conses!
678 Each symbol_block is just under 1020 bytes long,
679 since malloc really allocates in units of powers of two
680 and uses 4 bytes for its own overhead. */
682 #define SYMBOL_BLOCK_SIZE \
683 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
687 struct symbol_block
*next
;
688 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
691 struct symbol_block
*symbol_block
;
692 int symbol_block_index
;
694 struct Lisp_Symbol
*symbol_free_list
;
699 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
700 symbol_block
->next
= 0;
701 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
702 symbol_block_index
= 0;
703 symbol_free_list
= 0;
706 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
707 "Return a newly allocated uninterned symbol whose name is NAME.\n\
708 Its value and function definition are void, and its property list is nil.")
712 register Lisp_Object val
;
713 register struct Lisp_Symbol
*p
;
715 CHECK_STRING (str
, 0);
717 if (symbol_free_list
)
719 XSETSYMBOL (val
, symbol_free_list
);
720 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
724 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
726 struct symbol_block
*new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
727 VALIDATE_LISP_STORAGE (new, sizeof *new);
728 new->next
= symbol_block
;
730 symbol_block_index
= 0;
732 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
735 p
->name
= XSTRING (str
);
738 p
->function
= Qunbound
;
740 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
744 /* Allocation of markers and other objects that share that structure.
745 Works like allocation of conses. */
747 #define MARKER_BLOCK_SIZE \
748 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
752 struct marker_block
*next
;
753 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
756 struct marker_block
*marker_block
;
757 int marker_block_index
;
759 union Lisp_Misc
*marker_free_list
;
764 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
765 marker_block
->next
= 0;
766 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
767 marker_block_index
= 0;
768 marker_free_list
= 0;
771 /* Return a newly allocated Lisp_Misc object, with no substructure. */
777 if (marker_free_list
)
779 XSETMISC (val
, marker_free_list
);
780 marker_free_list
= marker_free_list
->u_free
.chain
;
784 if (marker_block_index
== MARKER_BLOCK_SIZE
)
786 struct marker_block
*new
787 = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
788 VALIDATE_LISP_STORAGE (new, sizeof *new);
789 new->next
= marker_block
;
791 marker_block_index
= 0;
793 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
795 consing_since_gc
+= sizeof (union Lisp_Misc
);
799 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
800 "Return a newly allocated marker which does not point at any place.")
803 register Lisp_Object val
;
804 register struct Lisp_Marker
*p
;
806 val
= allocate_misc ();
807 XMISC (val
)->type
= Lisp_Misc_Marker
;
815 /* Allocation of strings */
817 /* Strings reside inside of string_blocks. The entire data of the string,
818 both the size and the contents, live in part of the `chars' component of a string_block.
819 The `pos' component is the index within `chars' of the first free byte.
821 first_string_block points to the first string_block ever allocated.
822 Each block points to the next one with its `next' field.
823 The `prev' fields chain in reverse order.
824 The last one allocated is the one currently being filled.
825 current_string_block points to it.
827 The string_blocks that hold individual large strings
828 go in a separate chain, started by large_string_blocks. */
831 /* String blocks contain this many useful bytes.
832 8188 is power of 2, minus 4 for malloc overhead. */
833 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
835 /* A string bigger than this gets its own specially-made string block
836 if it doesn't fit in the current one. */
837 #define STRING_BLOCK_OUTSIZE 1024
839 struct string_block_head
841 struct string_block
*next
, *prev
;
847 struct string_block
*next
, *prev
;
849 char chars
[STRING_BLOCK_SIZE
];
852 /* This points to the string block we are now allocating strings. */
854 struct string_block
*current_string_block
;
856 /* This points to the oldest string block, the one that starts the chain. */
858 struct string_block
*first_string_block
;
860 /* Last string block in chain of those made for individual large strings. */
862 struct string_block
*large_string_blocks
;
864 /* If SIZE is the length of a string, this returns how many bytes
865 the string occupies in a string_block (including padding). */
867 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
869 #define PAD (sizeof (EMACS_INT))
872 #define STRING_FULLSIZE(SIZE) \
873 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
879 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
880 first_string_block
= current_string_block
;
881 consing_since_gc
+= sizeof (struct string_block
);
882 current_string_block
->next
= 0;
883 current_string_block
->prev
= 0;
884 current_string_block
->pos
= 0;
885 large_string_blocks
= 0;
888 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
889 "Return a newly created string of length LENGTH, with each element being INIT.\n\
890 Both LENGTH and INIT must be numbers.")
892 Lisp_Object length
, init
;
894 register Lisp_Object val
;
895 register unsigned char *p
, *end
, c
;
897 CHECK_NATNUM (length
, 0);
898 CHECK_NUMBER (init
, 1);
899 val
= make_uninit_string (XFASTINT (length
));
901 p
= XSTRING (val
)->data
;
902 end
= p
+ XSTRING (val
)->size
;
910 make_string (contents
, length
)
914 register Lisp_Object val
;
915 val
= make_uninit_string (length
);
916 bcopy (contents
, XSTRING (val
)->data
, length
);
924 return make_string (str
, strlen (str
));
928 make_uninit_string (length
)
931 register Lisp_Object val
;
932 register int fullsize
= STRING_FULLSIZE (length
);
934 if (length
< 0) abort ();
936 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
937 /* This string can fit in the current string block */
940 ((struct Lisp_String
*)
941 (current_string_block
->chars
+ current_string_block
->pos
)));
942 current_string_block
->pos
+= fullsize
;
944 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
945 /* This string gets its own string block */
947 register struct string_block
*new
948 = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
949 VALIDATE_LISP_STORAGE (new, 0);
950 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
952 new->next
= large_string_blocks
;
953 large_string_blocks
= new;
955 ((struct Lisp_String
*)
956 ((struct string_block_head
*)new + 1)));
959 /* Make a new current string block and start it off with this string */
961 register struct string_block
*new
962 = (struct string_block
*) xmalloc (sizeof (struct string_block
));
963 VALIDATE_LISP_STORAGE (new, sizeof *new);
964 consing_since_gc
+= sizeof (struct string_block
);
965 current_string_block
->next
= new;
966 new->prev
= current_string_block
;
968 current_string_block
= new;
971 (struct Lisp_String
*) current_string_block
->chars
);
974 XSTRING (val
)->size
= length
;
975 XSTRING (val
)->data
[length
] = 0;
976 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
981 /* Return a newly created vector or string with specified arguments as
982 elements. If all the arguments are characters that can fit
983 in a string of events, make a string; otherwise, make a vector.
985 Any number of arguments, even zero arguments, are allowed. */
988 make_event_array (nargs
, args
)
994 for (i
= 0; i
< nargs
; i
++)
995 /* The things that fit in a string
996 are characters that are in 0...127,
997 after discarding the meta bit and all the bits above it. */
998 if (!INTEGERP (args
[i
])
999 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1000 return Fvector (nargs
, args
);
1002 /* Since the loop exited, we know that all the things in it are
1003 characters, so we can make a string. */
1007 result
= Fmake_string (nargs
, make_number (0));
1008 for (i
= 0; i
< nargs
; i
++)
1010 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1011 /* Move the meta bit to the right place for a string char. */
1012 if (XINT (args
[i
]) & CHAR_META
)
1013 XSTRING (result
)->data
[i
] |= 0x80;
1020 /* Pure storage management. */
1022 /* Must get an error if pure storage is full,
1023 since if it cannot hold a large string
1024 it may be able to hold conses that point to that string;
1025 then the string is not protected from gc. */
1028 make_pure_string (data
, length
)
1032 register Lisp_Object
new;
1033 register int size
= sizeof (EMACS_INT
) + INTERVAL_PTR_SIZE
+ length
+ 1;
1035 if (pureptr
+ size
> PURESIZE
)
1036 error ("Pure Lisp storage exhausted");
1037 XSETSTRING (new, PUREBEG
+ pureptr
);
1038 XSTRING (new)->size
= length
;
1039 bcopy (data
, XSTRING (new)->data
, length
);
1040 XSTRING (new)->data
[length
] = 0;
1042 /* We must give strings in pure storage some kind of interval. So we
1043 give them a null one. */
1044 #if defined (USE_TEXT_PROPERTIES)
1045 XSTRING (new)->intervals
= NULL_INTERVAL
;
1047 pureptr
+= (size
+ sizeof (EMACS_INT
) - 1)
1048 / sizeof (EMACS_INT
) * sizeof (EMACS_INT
);
1053 pure_cons (car
, cdr
)
1054 Lisp_Object car
, cdr
;
1056 register Lisp_Object
new;
1058 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1059 error ("Pure Lisp storage exhausted");
1060 XSETCONS (new, PUREBEG
+ pureptr
);
1061 pureptr
+= sizeof (struct Lisp_Cons
);
1062 XCONS (new)->car
= Fpurecopy (car
);
1063 XCONS (new)->cdr
= Fpurecopy (cdr
);
1067 #ifdef LISP_FLOAT_TYPE
1070 make_pure_float (num
)
1073 register Lisp_Object
new;
1075 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1076 (double) boundary. Some architectures (like the sparc) require
1077 this, and I suspect that floats are rare enough that it's no
1078 tragedy for those that do. */
1081 char *p
= PUREBEG
+ pureptr
;
1085 alignment
= __alignof (struct Lisp_Float
);
1087 alignment
= sizeof (struct Lisp_Float
);
1090 alignment
= sizeof (struct Lisp_Float
);
1092 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1093 pureptr
= p
- PUREBEG
;
1096 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1097 error ("Pure Lisp storage exhausted");
1098 XSETFLOAT (new, PUREBEG
+ pureptr
);
1099 pureptr
+= sizeof (struct Lisp_Float
);
1100 XFLOAT (new)->data
= num
;
1101 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1105 #endif /* LISP_FLOAT_TYPE */
1108 make_pure_vector (len
)
1111 register Lisp_Object
new;
1112 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1114 if (pureptr
+ size
> PURESIZE
)
1115 error ("Pure Lisp storage exhausted");
1117 XSETVECTOR (new, PUREBEG
+ pureptr
);
1119 XVECTOR (new)->size
= len
;
1123 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1124 "Make a copy of OBJECT in pure storage.\n\
1125 Recursively copies contents of vectors and cons cells.\n\
1126 Does not copy symbols.")
1128 register Lisp_Object obj
;
1130 if (NILP (Vpurify_flag
))
1133 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1134 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1138 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1139 #ifdef LISP_FLOAT_TYPE
1140 else if (FLOATP (obj
))
1141 return make_pure_float (XFLOAT (obj
)->data
);
1142 #endif /* LISP_FLOAT_TYPE */
1143 else if (STRINGP (obj
))
1144 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1145 else if (COMPILEDP (obj
) || VECTORP (obj
))
1147 register struct Lisp_Vector
*vec
;
1148 register int i
, size
;
1150 size
= XVECTOR (obj
)->size
;
1151 vec
= XVECTOR (make_pure_vector (size
));
1152 for (i
= 0; i
< size
; i
++)
1153 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1154 if (COMPILEDP (obj
))
1155 XSETCOMPILED (obj
, vec
);
1157 XSETVECTOR (obj
, vec
);
1160 else if (MARKERP (obj
))
1161 error ("Attempt to copy a marker to pure storage");
1166 /* Recording what needs to be marked for gc. */
1168 struct gcpro
*gcprolist
;
1170 #define NSTATICS 512
1172 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1176 /* Put an entry in staticvec, pointing at the variable whose address is given */
1179 staticpro (varaddress
)
1180 Lisp_Object
*varaddress
;
1182 staticvec
[staticidx
++] = varaddress
;
1183 if (staticidx
>= NSTATICS
)
1191 struct catchtag
*next
;
1192 /* jmp_buf jmp; /* We don't need this for GC purposes */
1197 struct backtrace
*next
;
1198 Lisp_Object
*function
;
1199 Lisp_Object
*args
; /* Points to vector of args. */
1200 int nargs
; /* length of vector */
1201 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1205 /* Garbage collection! */
1207 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1208 int total_free_conses
, total_free_markers
, total_free_symbols
;
1209 #ifdef LISP_FLOAT_TYPE
1210 int total_free_floats
, total_floats
;
1211 #endif /* LISP_FLOAT_TYPE */
1213 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1214 "Reclaim storage for Lisp objects no longer needed.\n\
1215 Returns info on amount of space in use:\n\
1216 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1217 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1218 (USED-FLOATS . FREE-FLOATS))\n\
1219 Garbage collection happens automatically if you cons more than\n\
1220 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1223 register struct gcpro
*tail
;
1224 register struct specbinding
*bind
;
1225 struct catchtag
*catch;
1226 struct handler
*handler
;
1227 register struct backtrace
*backlist
;
1228 register Lisp_Object tem
;
1229 char *omessage
= echo_area_glyphs
;
1230 int omessage_length
= echo_area_glyphs_length
;
1231 char stack_top_variable
;
1234 /* Save a copy of the contents of the stack, for debugging. */
1235 #if MAX_SAVE_STACK > 0
1236 if (NILP (Vpurify_flag
))
1238 i
= &stack_top_variable
- stack_bottom
;
1240 if (i
< MAX_SAVE_STACK
)
1242 if (stack_copy
== 0)
1243 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1244 else if (stack_copy_size
< i
)
1245 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1248 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1249 bcopy (stack_bottom
, stack_copy
, i
);
1251 bcopy (&stack_top_variable
, stack_copy
, i
);
1255 #endif /* MAX_SAVE_STACK > 0 */
1257 if (!noninteractive
)
1258 message1 ("Garbage collecting...");
1260 /* Don't keep command history around forever */
1261 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1263 XCONS (tem
)->cdr
= Qnil
;
1265 /* Likewise for undo information. */
1267 register struct buffer
*nextb
= all_buffers
;
1271 /* If a buffer's undo list is Qt, that means that undo is
1272 turned off in that buffer. Calling truncate_undo_list on
1273 Qt tends to return NULL, which effectively turns undo back on.
1274 So don't call truncate_undo_list if undo_list is Qt. */
1275 if (! EQ (nextb
->undo_list
, Qt
))
1277 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1279 nextb
= nextb
->next
;
1285 /* clear_marks (); */
1287 /* In each "large string", set the MARKBIT of the size field.
1288 That enables mark_object to recognize them. */
1290 register struct string_block
*b
;
1291 for (b
= large_string_blocks
; b
; b
= b
->next
)
1292 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1295 /* Mark all the special slots that serve as the roots of accessibility.
1297 Usually the special slots to mark are contained in particular structures.
1298 Then we know no slot is marked twice because the structures don't overlap.
1299 In some cases, the structures point to the slots to be marked.
1300 For these, we use MARKBIT to avoid double marking of the slot. */
1302 for (i
= 0; i
< staticidx
; i
++)
1303 mark_object (staticvec
[i
]);
1304 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1305 for (i
= 0; i
< tail
->nvars
; i
++)
1306 if (!XMARKBIT (tail
->var
[i
]))
1308 mark_object (&tail
->var
[i
]);
1309 XMARK (tail
->var
[i
]);
1311 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1313 mark_object (&bind
->symbol
);
1314 mark_object (&bind
->old_value
);
1316 for (catch = catchlist
; catch; catch = catch->next
)
1318 mark_object (&catch->tag
);
1319 mark_object (&catch->val
);
1321 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1323 mark_object (&handler
->handler
);
1324 mark_object (&handler
->var
);
1326 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1328 if (!XMARKBIT (*backlist
->function
))
1330 mark_object (backlist
->function
);
1331 XMARK (*backlist
->function
);
1333 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1336 i
= backlist
->nargs
- 1;
1338 if (!XMARKBIT (backlist
->args
[i
]))
1340 mark_object (&backlist
->args
[i
]);
1341 XMARK (backlist
->args
[i
]);
1347 /* Clear the mark bits that we set in certain root slots. */
1349 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1350 for (i
= 0; i
< tail
->nvars
; i
++)
1351 XUNMARK (tail
->var
[i
]);
1352 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1354 XUNMARK (*backlist
->function
);
1355 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1358 i
= backlist
->nargs
- 1;
1360 XUNMARK (backlist
->args
[i
]);
1362 XUNMARK (buffer_defaults
.name
);
1363 XUNMARK (buffer_local_symbols
.name
);
1365 /* clear_marks (); */
1368 consing_since_gc
= 0;
1369 if (gc_cons_threshold
< 10000)
1370 gc_cons_threshold
= 10000;
1372 if (omessage
|| minibuf_level
> 0)
1373 message2 (omessage
, omessage_length
);
1374 else if (!noninteractive
)
1375 message1 ("Garbage collecting...done");
1377 return Fcons (Fcons (make_number (total_conses
),
1378 make_number (total_free_conses
)),
1379 Fcons (Fcons (make_number (total_symbols
),
1380 make_number (total_free_symbols
)),
1381 Fcons (Fcons (make_number (total_markers
),
1382 make_number (total_free_markers
)),
1383 Fcons (make_number (total_string_size
),
1384 Fcons (make_number (total_vector_size
),
1386 #ifdef LISP_FLOAT_TYPE
1387 Fcons (Fcons (make_number (total_floats
),
1388 make_number (total_free_floats
)),
1390 #else /* not LISP_FLOAT_TYPE */
1392 #endif /* not LISP_FLOAT_TYPE */
1400 /* Clear marks on all conses */
1402 register struct cons_block
*cblk
;
1403 register int lim
= cons_block_index
;
1405 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1408 for (i
= 0; i
< lim
; i
++)
1409 XUNMARK (cblk
->conses
[i
].car
);
1410 lim
= CONS_BLOCK_SIZE
;
1413 /* Clear marks on all symbols */
1415 register struct symbol_block
*sblk
;
1416 register int lim
= symbol_block_index
;
1418 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1421 for (i
= 0; i
< lim
; i
++)
1423 XUNMARK (sblk
->symbols
[i
].plist
);
1425 lim
= SYMBOL_BLOCK_SIZE
;
1428 /* Clear marks on all markers */
1430 register struct marker_block
*sblk
;
1431 register int lim
= marker_block_index
;
1433 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1436 for (i
= 0; i
< lim
; i
++)
1437 if (sblk
->markers
[i
].type
== Lisp_Misc_Marker
)
1438 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1439 lim
= MARKER_BLOCK_SIZE
;
1442 /* Clear mark bits on all buffers */
1444 register struct buffer
*nextb
= all_buffers
;
1448 XUNMARK (nextb
->name
);
1449 nextb
= nextb
->next
;
1455 /* Mark reference to a Lisp_Object.
1456 If the object referred to has not been seen yet, recursively mark
1457 all the references contained in it.
1459 If the object referenced is a short string, the referencing slot
1460 is threaded into a chain of such slots, pointed to from
1461 the `size' field of the string. The actual string size
1462 lives in the last slot in the chain. We recognize the end
1463 because it is < (unsigned) STRING_BLOCK_SIZE. */
1465 #define LAST_MARKED_SIZE 500
1466 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1467 int last_marked_index
;
1470 mark_object (objptr
)
1471 Lisp_Object
*objptr
;
1473 register Lisp_Object obj
;
1480 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1481 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1484 last_marked
[last_marked_index
++] = objptr
;
1485 if (last_marked_index
== LAST_MARKED_SIZE
)
1486 last_marked_index
= 0;
1488 #ifdef SWITCH_ENUM_BUG
1489 switch ((int) XGCTYPE (obj
))
1491 switch (XGCTYPE (obj
))
1496 register struct Lisp_String
*ptr
= XSTRING (obj
);
1498 MARK_INTERVAL_TREE (ptr
->intervals
);
1499 if (ptr
->size
& MARKBIT
)
1500 /* A large string. Just set ARRAY_MARK_FLAG. */
1501 ptr
->size
|= ARRAY_MARK_FLAG
;
1504 /* A small string. Put this reference
1505 into the chain of references to it.
1506 The address OBJPTR is even, so if the address
1507 includes MARKBIT, put it in the low bit
1508 when we store OBJPTR into the size field. */
1510 if (XMARKBIT (*objptr
))
1512 XSETFASTINT (*objptr
, ptr
->size
);
1516 XSETFASTINT (*objptr
, ptr
->size
);
1517 if ((EMACS_INT
) objptr
& 1) abort ();
1518 ptr
->size
= (EMACS_INT
) objptr
& ~MARKBIT
;
1519 if ((EMACS_INT
) objptr
& MARKBIT
)
1525 case Lisp_Vectorlike
:
1526 if (GC_BUFFERP (obj
))
1528 if (!XMARKBIT (XBUFFER (obj
)->name
))
1531 else if (GC_SUBRP (obj
))
1533 else if (GC_COMPILEDP (obj
))
1534 /* We could treat this just like a vector, but it is better
1535 to save the COMPILED_CONSTANTS element for last and avoid recursion
1538 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1539 register EMACS_INT size
= ptr
->size
;
1540 /* See comment above under Lisp_Vector. */
1541 struct Lisp_Vector
*volatile ptr1
= ptr
;
1544 if (size
& ARRAY_MARK_FLAG
)
1545 break; /* Already marked */
1546 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1547 size
&= PSEUDOVECTOR_SIZE_MASK
;
1548 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1550 if (i
!= COMPILED_CONSTANTS
)
1551 mark_object (&ptr1
->contents
[i
]);
1553 /* This cast should be unnecessary, but some Mips compiler complains
1554 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1555 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1559 else if (GC_FRAMEP (obj
))
1561 /* See comment above under Lisp_Vector for why this is volatile. */
1562 register struct frame
*volatile ptr
= XFRAME (obj
);
1563 register EMACS_INT size
= ptr
->size
;
1565 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1566 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1568 mark_object (&ptr
->name
);
1569 mark_object (&ptr
->focus_frame
);
1570 mark_object (&ptr
->selected_window
);
1571 mark_object (&ptr
->minibuffer_window
);
1572 mark_object (&ptr
->param_alist
);
1573 mark_object (&ptr
->scroll_bars
);
1574 mark_object (&ptr
->condemned_scroll_bars
);
1575 mark_object (&ptr
->menu_bar_items
);
1576 mark_object (&ptr
->face_alist
);
1577 mark_object (&ptr
->menu_bar_vector
);
1578 mark_object (&ptr
->buffer_predicate
);
1580 #endif /* MULTI_FRAME */
1583 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1584 register EMACS_INT size
= ptr
->size
;
1585 /* The reason we use ptr1 is to avoid an apparent hardware bug
1586 that happens occasionally on the FSF's HP 300s.
1587 The bug is that a2 gets clobbered by recursive calls to mark_object.
1588 The clobberage seems to happen during function entry,
1589 perhaps in the moveml instruction.
1590 Yes, this is a crock, but we have to do it. */
1591 struct Lisp_Vector
*volatile ptr1
= ptr
;
1594 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1595 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1596 if (size
& PSEUDOVECTOR_FLAG
)
1597 size
&= PSEUDOVECTOR_SIZE_MASK
;
1598 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1599 mark_object (&ptr1
->contents
[i
]);
1605 /* See comment above under Lisp_Vector for why this is volatile. */
1606 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1607 struct Lisp_Symbol
*ptrx
;
1609 if (XMARKBIT (ptr
->plist
)) break;
1611 mark_object ((Lisp_Object
*) &ptr
->value
);
1612 mark_object (&ptr
->function
);
1613 mark_object (&ptr
->plist
);
1614 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1615 mark_object (&ptr
->name
);
1619 /* For the benefit of the last_marked log. */
1620 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1621 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1622 XSETSYMBOL (obj
, ptrx
);
1623 /* We can't goto loop here because *objptr doesn't contain an
1624 actual Lisp_Object with valid datatype field. */
1631 switch (XMISC (obj
)->type
)
1633 case Lisp_Misc_Marker
:
1634 XMARK (XMARKER (obj
)->chain
);
1635 /* DO NOT mark thru the marker's chain.
1636 The buffer's markers chain does not preserve markers from gc;
1637 instead, markers are removed from the chain when freed by gc. */
1640 case Lisp_Misc_Buffer_Local_Value
:
1641 case Lisp_Misc_Some_Buffer_Local_Value
:
1643 register struct Lisp_Buffer_Local_Value
*ptr
1644 = XBUFFER_LOCAL_VALUE (obj
);
1645 if (XMARKBIT (ptr
->car
)) break;
1647 /* If the cdr is nil, avoid recursion for the car. */
1648 if (EQ (ptr
->cdr
, Qnil
))
1653 mark_object (&ptr
->car
);
1654 /* See comment above under Lisp_Vector for why not use ptr here. */
1655 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
1659 case Lisp_Misc_Intfwd
:
1660 case Lisp_Misc_Boolfwd
:
1661 case Lisp_Misc_Objfwd
:
1662 case Lisp_Misc_Buffer_Objfwd
:
1663 /* Don't bother with Lisp_Buffer_Objfwd,
1664 since all markable slots in current buffer marked anyway. */
1665 /* Don't need to do Lisp_Objfwd, since the places they point
1666 are protected with staticpro. */
1669 case Lisp_Misc_Overlay
:
1671 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
1672 if (!XMARKBIT (ptr
->plist
))
1675 mark_object (&ptr
->start
);
1676 mark_object (&ptr
->end
);
1677 objptr
= &ptr
->plist
;
1690 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1691 if (XMARKBIT (ptr
->car
)) break;
1693 /* If the cdr is nil, avoid recursion for the car. */
1694 if (EQ (ptr
->cdr
, Qnil
))
1699 mark_object (&ptr
->car
);
1700 /* See comment above under Lisp_Vector for why not use ptr here. */
1701 objptr
= &XCONS (obj
)->cdr
;
1705 #ifdef LISP_FLOAT_TYPE
1707 XMARK (XFLOAT (obj
)->type
);
1709 #endif /* LISP_FLOAT_TYPE */
1719 /* Mark the pointers in a buffer structure. */
1725 register struct buffer
*buffer
= XBUFFER (buf
);
1726 register Lisp_Object
*ptr
;
1727 Lisp_Object base_buffer
;
1729 /* This is the buffer's markbit */
1730 mark_object (&buffer
->name
);
1731 XMARK (buffer
->name
);
1733 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
1736 mark_object (buffer
->syntax_table
);
1738 /* Mark the various string-pointers in the buffer object.
1739 Since the strings may be relocated, we must mark them
1740 in their actual slots. So gc_sweep must convert each slot
1741 back to an ordinary C pointer. */
1742 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
1743 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1744 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
1745 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1747 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
1748 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1749 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
1750 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1753 for (ptr
= &buffer
->name
+ 1;
1754 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1758 /* If this is an indirect buffer, mark its base buffer. */
1759 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
1761 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
1762 mark_buffer (base_buffer
);
1766 /* Sweep: find all structures not marked, and free them. */
1771 total_string_size
= 0;
1774 /* Put all unmarked conses on free list */
1776 register struct cons_block
*cblk
;
1777 register int lim
= cons_block_index
;
1778 register int num_free
= 0, num_used
= 0;
1782 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1785 for (i
= 0; i
< lim
; i
++)
1786 if (!XMARKBIT (cblk
->conses
[i
].car
))
1789 *(struct Lisp_Cons
**)&cblk
->conses
[i
].car
= cons_free_list
;
1790 cons_free_list
= &cblk
->conses
[i
];
1795 XUNMARK (cblk
->conses
[i
].car
);
1797 lim
= CONS_BLOCK_SIZE
;
1799 total_conses
= num_used
;
1800 total_free_conses
= num_free
;
1803 #ifdef LISP_FLOAT_TYPE
1804 /* Put all unmarked floats on free list */
1806 register struct float_block
*fblk
;
1807 register int lim
= float_block_index
;
1808 register int num_free
= 0, num_used
= 0;
1810 float_free_list
= 0;
1812 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1815 for (i
= 0; i
< lim
; i
++)
1816 if (!XMARKBIT (fblk
->floats
[i
].type
))
1819 *(struct Lisp_Float
**)&fblk
->floats
[i
].type
= float_free_list
;
1820 float_free_list
= &fblk
->floats
[i
];
1825 XUNMARK (fblk
->floats
[i
].type
);
1827 lim
= FLOAT_BLOCK_SIZE
;
1829 total_floats
= num_used
;
1830 total_free_floats
= num_free
;
1832 #endif /* LISP_FLOAT_TYPE */
1834 #ifdef USE_TEXT_PROPERTIES
1835 /* Put all unmarked intervals on free list */
1837 register struct interval_block
*iblk
;
1838 register int lim
= interval_block_index
;
1839 register int num_free
= 0, num_used
= 0;
1841 interval_free_list
= 0;
1843 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1847 for (i
= 0; i
< lim
; i
++)
1849 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1851 iblk
->intervals
[i
].parent
= interval_free_list
;
1852 interval_free_list
= &iblk
->intervals
[i
];
1858 XUNMARK (iblk
->intervals
[i
].plist
);
1861 lim
= INTERVAL_BLOCK_SIZE
;
1863 total_intervals
= num_used
;
1864 total_free_intervals
= num_free
;
1866 #endif /* USE_TEXT_PROPERTIES */
1868 /* Put all unmarked symbols on free list */
1870 register struct symbol_block
*sblk
;
1871 register int lim
= symbol_block_index
;
1872 register int num_free
= 0, num_used
= 0;
1874 symbol_free_list
= 0;
1876 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1879 for (i
= 0; i
< lim
; i
++)
1880 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1882 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
1883 symbol_free_list
= &sblk
->symbols
[i
];
1889 sblk
->symbols
[i
].name
1890 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1891 XUNMARK (sblk
->symbols
[i
].plist
);
1893 lim
= SYMBOL_BLOCK_SIZE
;
1895 total_symbols
= num_used
;
1896 total_free_symbols
= num_free
;
1900 /* Put all unmarked markers on free list.
1901 Dechain each one first from the buffer it points into,
1902 but only if it's a real marker. */
1904 register struct marker_block
*mblk
;
1905 register int lim
= marker_block_index
;
1906 register int num_free
= 0, num_used
= 0;
1908 marker_free_list
= 0;
1910 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1913 for (i
= 0; i
< lim
; i
++)
1915 Lisp_Object
*markword
;
1916 switch (mblk
->markers
[i
].type
)
1918 case Lisp_Misc_Marker
:
1919 markword
= &mblk
->markers
[i
].u_marker
.chain
;
1921 case Lisp_Misc_Buffer_Local_Value
:
1922 case Lisp_Misc_Some_Buffer_Local_Value
:
1923 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
1925 case Lisp_Misc_Overlay
:
1926 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
1932 if (markword
&& !XMARKBIT (*markword
))
1935 if (mblk
->markers
[i
].type
== Lisp_Misc_Marker
)
1937 /* tem1 avoids Sun compiler bug */
1938 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
1939 XSETMARKER (tem
, tem1
);
1940 unchain_marker (tem
);
1942 /* We could leave the type alone, since nobody checks it,
1943 but this might catch bugs faster. */
1944 mblk
->markers
[i
].type
= Lisp_Misc_Free
;
1945 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
1946 marker_free_list
= &mblk
->markers
[i
];
1953 XUNMARK (*markword
);
1956 lim
= MARKER_BLOCK_SIZE
;
1959 total_markers
= num_used
;
1960 total_free_markers
= num_free
;
1963 /* Free all unmarked buffers */
1965 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1968 if (!XMARKBIT (buffer
->name
))
1971 prev
->next
= buffer
->next
;
1973 all_buffers
= buffer
->next
;
1974 next
= buffer
->next
;
1980 XUNMARK (buffer
->name
);
1981 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
1984 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1985 for purposes of marking and relocation.
1986 Turn them back into C pointers now. */
1987 buffer
->upcase_table
1988 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
1989 buffer
->downcase_table
1990 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
1992 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
1993 buffer
->folding_sort_table
1994 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
1997 prev
= buffer
, buffer
= buffer
->next
;
2001 #endif /* standalone */
2003 /* Free all unmarked vectors */
2005 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2006 total_vector_size
= 0;
2009 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2012 prev
->next
= vector
->next
;
2014 all_vectors
= vector
->next
;
2015 next
= vector
->next
;
2021 vector
->size
&= ~ARRAY_MARK_FLAG
;
2022 total_vector_size
+= vector
->size
;
2023 prev
= vector
, vector
= vector
->next
;
2027 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2029 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2030 struct Lisp_String
*s
;
2034 s
= (struct Lisp_String
*) &sb
->chars
[0];
2035 if (s
->size
& ARRAY_MARK_FLAG
)
2037 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2038 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2039 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2040 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2041 prev
= sb
, sb
= sb
->next
;
2046 prev
->next
= sb
->next
;
2048 large_string_blocks
= sb
->next
;
2057 /* Compactify strings, relocate references, and free empty string blocks. */
2062 /* String block of old strings we are scanning. */
2063 register struct string_block
*from_sb
;
2064 /* A preceding string block (or maybe the same one)
2065 where we are copying the still-live strings to. */
2066 register struct string_block
*to_sb
;
2070 to_sb
= first_string_block
;
2073 /* Scan each existing string block sequentially, string by string. */
2074 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2077 /* POS is the index of the next string in the block. */
2078 while (pos
< from_sb
->pos
)
2080 register struct Lisp_String
*nextstr
2081 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2083 register struct Lisp_String
*newaddr
;
2084 register EMACS_INT size
= nextstr
->size
;
2086 /* NEXTSTR is the old address of the next string.
2087 Just skip it if it isn't marked. */
2088 if ((EMACS_UINT
) size
> STRING_BLOCK_SIZE
)
2090 /* It is marked, so its size field is really a chain of refs.
2091 Find the end of the chain, where the actual size lives. */
2092 while ((EMACS_UINT
) size
> STRING_BLOCK_SIZE
)
2094 if (size
& 1) size
^= MARKBIT
| 1;
2095 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2098 total_string_size
+= size
;
2100 /* If it won't fit in TO_SB, close it out,
2101 and move to the next sb. Keep doing so until
2102 TO_SB reaches a large enough, empty enough string block.
2103 We know that TO_SB cannot advance past FROM_SB here
2104 since FROM_SB is large enough to contain this string.
2105 Any string blocks skipped here
2106 will be patched out and freed later. */
2107 while (to_pos
+ STRING_FULLSIZE (size
)
2108 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2110 to_sb
->pos
= to_pos
;
2111 to_sb
= to_sb
->next
;
2114 /* Compute new address of this string
2115 and update TO_POS for the space being used. */
2116 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2117 to_pos
+= STRING_FULLSIZE (size
);
2119 /* Copy the string itself to the new place. */
2120 if (nextstr
!= newaddr
)
2121 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2122 + INTERVAL_PTR_SIZE
);
2124 /* Go through NEXTSTR's chain of references
2125 and make each slot in the chain point to
2126 the new address of this string. */
2127 size
= newaddr
->size
;
2128 while ((EMACS_UINT
) size
> STRING_BLOCK_SIZE
)
2130 register Lisp_Object
*objptr
;
2131 if (size
& 1) size
^= MARKBIT
| 1;
2132 objptr
= (Lisp_Object
*)size
;
2134 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2135 if (XMARKBIT (*objptr
))
2137 XSETSTRING (*objptr
, newaddr
);
2141 XSETSTRING (*objptr
, newaddr
);
2143 /* Store the actual size in the size field. */
2144 newaddr
->size
= size
;
2146 #ifdef USE_TEXT_PROPERTIES
2147 /* Now that the string has been relocated, rebalance its
2148 interval tree, and update the tree's parent pointer. */
2149 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2151 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2152 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2155 #endif /* USE_TEXT_PROPERTIES */
2157 pos
+= STRING_FULLSIZE (size
);
2161 /* Close out the last string block still used and free any that follow. */
2162 to_sb
->pos
= to_pos
;
2163 current_string_block
= to_sb
;
2165 from_sb
= to_sb
->next
;
2169 to_sb
= from_sb
->next
;
2174 /* Free any empty string blocks further back in the chain.
2175 This loop will never free first_string_block, but it is very
2176 unlikely that that one will become empty, so why bother checking? */
2178 from_sb
= first_string_block
;
2179 while (to_sb
= from_sb
->next
)
2181 if (to_sb
->pos
== 0)
2183 if (from_sb
->next
= to_sb
->next
)
2184 from_sb
->next
->prev
= from_sb
;
2192 /* Debugging aids. */
2194 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2195 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2196 This may be helpful in debugging Emacs's memory usage.\n\
2197 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2202 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2208 /* Initialization */
2212 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2215 pure_size
= PURESIZE
;
2218 ignore_warnings
= 1;
2223 #ifdef LISP_FLOAT_TYPE
2225 #endif /* LISP_FLOAT_TYPE */
2228 ignore_warnings
= 0;
2231 consing_since_gc
= 0;
2232 gc_cons_threshold
= 100000;
2233 #ifdef VIRT_ADDR_VARIES
2234 malloc_sbrk_unused
= 1<<22; /* A large number */
2235 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2236 #endif /* VIRT_ADDR_VARIES */
2247 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2248 "*Number of bytes of consing between garbage collections.\n\
2249 Garbage collection can happen automatically once this many bytes have been\n\
2250 allocated since the last garbage collection. All data types count.\n\n\
2251 Garbage collection happens automatically only when `eval' is called.\n\n\
2252 By binding this temporarily to a large number, you can effectively\n\
2253 prevent garbage collection during a part of the program.");
2255 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2256 "Number of bytes of sharable Lisp data allocated so far.");
2259 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2260 "Number of bytes of unshared memory allocated in this session.");
2262 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2263 "Number of bytes of unshared memory remaining available in this session.");
2266 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2267 "Non-nil means loading Lisp code in order to dump an executable.\n\
2268 This means that certain objects should be allocated in shared (pure) space.");
2270 DEFVAR_INT ("undo-limit", &undo_limit
,
2271 "Keep no more undo information once it exceeds this size.\n\
2272 This limit is applied when garbage collection happens.\n\
2273 The size is counted as the number of bytes occupied,\n\
2274 which includes both saved text and other data.");
2277 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2278 "Don't keep more than this much size of undo information.\n\
2279 A command which pushes past this size is itself forgotten.\n\
2280 This limit is applied when garbage collection happens.\n\
2281 The size is counted as the number of bytes occupied,\n\
2282 which includes both saved text and other data.");
2283 undo_strong_limit
= 30000;
2285 /* We build this in advance because if we wait until we need it, we might
2286 not be able to allocate the memory to hold it. */
2288 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted"), Qnil
));
2289 staticpro (&memory_signal_data
);
2294 defsubr (&Smake_byte_code
);
2295 defsubr (&Smake_list
);
2296 defsubr (&Smake_vector
);
2297 defsubr (&Smake_string
);
2298 defsubr (&Smake_symbol
);
2299 defsubr (&Smake_marker
);
2300 defsubr (&Spurecopy
);
2301 defsubr (&Sgarbage_collect
);
2302 defsubr (&Smemory_limit
);