1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95 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 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
111 pointer to a Lisp_Object, when that pointer is viewed as an integer.
112 (On most machines, pointers are even, so we can use the low bit.
113 Word-addressible architectures may need to override this in the m-file.)
114 When linking references to small strings through the size field, we
115 use this slot to hold the bit that would otherwise be interpreted as
117 #ifndef DONT_COPY_FLAG
118 #define DONT_COPY_FLAG 1
119 #endif /* no DONT_COPY_FLAG */
121 #if DONT_COPY_FLAG == MARKBIT
125 /* Buffer in which we save a copy of the C stack at each GC. */
130 /* Non-zero means ignore malloc warnings. Set during initialization. */
133 static void mark_object (), mark_buffer ();
134 static void clear_marks (), gc_sweep ();
135 static void compact_strings ();
137 /* Versions of malloc and realloc that print warnings as memory gets full. */
140 malloc_warning_1 (str
)
143 Fprinc (str
, Vstandard_output
);
144 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
145 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
146 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
150 /* malloc calls this if it finds we are near exhausting storage */
154 pending_malloc_warning
= str
;
157 display_malloc_warning ()
159 register Lisp_Object val
;
161 val
= build_string (pending_malloc_warning
);
162 pending_malloc_warning
= 0;
163 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
166 /* Called if malloc returns zero */
169 /* This used to call error, but if we've run out of memory, we could get
170 infinite recursion trying to build the string. */
172 Fsignal (Qerror
, memory_signal_data
);
175 /* like malloc routines but check for no memory and block interrupt input. */
184 val
= (long *) malloc (size
);
187 if (!val
&& size
) memory_full ();
192 xrealloc (block
, size
)
199 /* We must call malloc explicitly when BLOCK is 0, since some
200 reallocs don't do this. */
202 val
= (long *) malloc (size
);
204 val
= (long *) realloc (block
, size
);
207 if (!val
&& size
) memory_full ();
221 /* Arranging to disable input signals while we're in malloc.
223 This only works with GNU malloc. To help out systems which can't
224 use GNU malloc, all the calls to malloc, realloc, and free
225 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
226 pairs; unfortunately, we have no idea what C library functions
227 might call malloc, so we can't really protect them unless you're
228 using GNU malloc. Fortunately, most of the major operating can use
231 #ifndef SYSTEM_MALLOC
232 extern void * (*__malloc_hook
) ();
233 static void * (*old_malloc_hook
) ();
234 extern void * (*__realloc_hook
) ();
235 static void * (*old_realloc_hook
) ();
236 extern void (*__free_hook
) ();
237 static void (*old_free_hook
) ();
240 emacs_blocked_free (ptr
)
244 __free_hook
= old_free_hook
;
246 __free_hook
= emacs_blocked_free
;
251 emacs_blocked_malloc (size
)
257 __malloc_hook
= old_malloc_hook
;
258 value
= (void *) malloc (size
);
259 __malloc_hook
= emacs_blocked_malloc
;
266 emacs_blocked_realloc (ptr
, size
)
273 __realloc_hook
= old_realloc_hook
;
274 value
= (void *) realloc (ptr
, size
);
275 __realloc_hook
= emacs_blocked_realloc
;
282 uninterrupt_malloc ()
284 old_free_hook
= __free_hook
;
285 __free_hook
= emacs_blocked_free
;
287 old_malloc_hook
= __malloc_hook
;
288 __malloc_hook
= emacs_blocked_malloc
;
290 old_realloc_hook
= __realloc_hook
;
291 __realloc_hook
= emacs_blocked_realloc
;
295 /* Interval allocation. */
297 #ifdef USE_TEXT_PROPERTIES
298 #define INTERVAL_BLOCK_SIZE \
299 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
301 struct interval_block
303 struct interval_block
*next
;
304 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
307 struct interval_block
*interval_block
;
308 static int interval_block_index
;
310 INTERVAL interval_free_list
;
316 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
317 interval_block
->next
= 0;
318 bzero (interval_block
->intervals
, sizeof interval_block
->intervals
);
319 interval_block_index
= 0;
320 interval_free_list
= 0;
323 #define INIT_INTERVALS init_intervals ()
330 if (interval_free_list
)
332 val
= interval_free_list
;
333 interval_free_list
= interval_free_list
->parent
;
337 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
339 register struct interval_block
*newi
340 = (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
342 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
343 newi
->next
= interval_block
;
344 interval_block
= newi
;
345 interval_block_index
= 0;
347 val
= &interval_block
->intervals
[interval_block_index
++];
349 consing_since_gc
+= sizeof (struct interval
);
350 RESET_INTERVAL (val
);
354 static int total_free_intervals
, total_intervals
;
356 /* Mark the pointers of one interval. */
359 mark_interval (i
, dummy
)
363 if (XMARKBIT (i
->plist
))
365 mark_object (&i
->plist
);
370 mark_interval_tree (tree
)
371 register INTERVAL tree
;
373 /* No need to test if this tree has been marked already; this
374 function is always called through the MARK_INTERVAL_TREE macro,
375 which takes care of that. */
377 /* XMARK expands to an assignment; the LHS of an assignment can't be
379 XMARK (* (Lisp_Object
*) &tree
->parent
);
381 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
384 #define MARK_INTERVAL_TREE(i) \
386 if (!NULL_INTERVAL_P (i) \
387 && ! XMARKBIT ((Lisp_Object) i->parent)) \
388 mark_interval_tree (i); \
391 /* The oddity in the call to XUNMARK is necessary because XUNMARK
392 expands to an assignment to its argument, and most C compilers don't
393 support casts on the left operand of `='. */
394 #define UNMARK_BALANCE_INTERVALS(i) \
396 if (! NULL_INTERVAL_P (i)) \
398 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
399 (i) = balance_intervals (i); \
403 #else /* no interval use */
405 #define INIT_INTERVALS
407 #define UNMARK_BALANCE_INTERVALS(i)
408 #define MARK_INTERVAL_TREE(i)
410 #endif /* no interval use */
412 /* Floating point allocation. */
414 #ifdef LISP_FLOAT_TYPE
415 /* Allocation of float cells, just like conses */
416 /* We store float cells inside of float_blocks, allocating a new
417 float_block with malloc whenever necessary. Float cells reclaimed by
418 GC are put on a free list to be reallocated before allocating
419 any new float cells from the latest float_block.
421 Each float_block is just under 1020 bytes long,
422 since malloc really allocates in units of powers of two
423 and uses 4 bytes for its own overhead. */
425 #define FLOAT_BLOCK_SIZE \
426 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
430 struct float_block
*next
;
431 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
434 struct float_block
*float_block
;
435 int float_block_index
;
437 struct Lisp_Float
*float_free_list
;
442 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
443 float_block
->next
= 0;
444 bzero (float_block
->floats
, sizeof float_block
->floats
);
445 float_block_index
= 0;
449 /* Explicitly free a float cell. */
451 struct Lisp_Float
*ptr
;
453 *(struct Lisp_Float
**)&ptr
->type
= float_free_list
;
454 float_free_list
= ptr
;
458 make_float (float_value
)
461 register Lisp_Object val
;
465 XSETFLOAT (val
, float_free_list
);
466 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->type
;
470 if (float_block_index
== FLOAT_BLOCK_SIZE
)
472 register struct float_block
*new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
473 VALIDATE_LISP_STORAGE (new, sizeof *new);
474 new->next
= float_block
;
476 float_block_index
= 0;
478 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
480 XFLOAT (val
)->data
= float_value
;
481 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
482 consing_since_gc
+= sizeof (struct Lisp_Float
);
486 #endif /* LISP_FLOAT_TYPE */
488 /* Allocation of cons cells */
489 /* We store cons cells inside of cons_blocks, allocating a new
490 cons_block with malloc whenever necessary. Cons cells reclaimed by
491 GC are put on a free list to be reallocated before allocating
492 any new cons cells from the latest cons_block.
494 Each cons_block is just under 1020 bytes long,
495 since malloc really allocates in units of powers of two
496 and uses 4 bytes for its own overhead. */
498 #define CONS_BLOCK_SIZE \
499 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
503 struct cons_block
*next
;
504 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
507 struct cons_block
*cons_block
;
508 int cons_block_index
;
510 struct Lisp_Cons
*cons_free_list
;
515 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
516 cons_block
->next
= 0;
517 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
518 cons_block_index
= 0;
522 /* Explicitly free a cons cell. */
524 struct Lisp_Cons
*ptr
;
526 *(struct Lisp_Cons
**)&ptr
->car
= cons_free_list
;
527 cons_free_list
= ptr
;
530 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
531 "Create a new cons, give it CAR and CDR as components, and return it.")
533 Lisp_Object car
, cdr
;
535 register Lisp_Object val
;
539 XSETCONS (val
, cons_free_list
);
540 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->car
;
544 if (cons_block_index
== CONS_BLOCK_SIZE
)
546 register struct cons_block
*new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
547 VALIDATE_LISP_STORAGE (new, sizeof *new);
548 new->next
= cons_block
;
550 cons_block_index
= 0;
552 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
554 XCONS (val
)->car
= car
;
555 XCONS (val
)->cdr
= cdr
;
556 consing_since_gc
+= sizeof (struct Lisp_Cons
);
560 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
561 "Return a newly created list with specified arguments as elements.\n\
562 Any number of arguments, even zero arguments, are allowed.")
565 register Lisp_Object
*args
;
567 register Lisp_Object len
, val
, val_tail
;
569 XSETFASTINT (len
, nargs
);
570 val
= Fmake_list (len
, Qnil
);
572 while (!NILP (val_tail
))
574 XCONS (val_tail
)->car
= *args
++;
575 val_tail
= XCONS (val_tail
)->cdr
;
580 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
581 "Return a newly created list of length LENGTH, with each element being INIT.")
583 register Lisp_Object length
, init
;
585 register Lisp_Object val
;
588 CHECK_NATNUM (length
, 0);
589 size
= XFASTINT (length
);
593 val
= Fcons (init
, val
);
597 /* Allocation of vectors */
599 struct Lisp_Vector
*all_vectors
;
602 allocate_vectorlike (len
)
605 struct Lisp_Vector
*p
;
607 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
608 + (len
- 1) * sizeof (Lisp_Object
));
609 VALIDATE_LISP_STORAGE (p
, 0);
610 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
611 + (len
- 1) * sizeof (Lisp_Object
));
613 p
->next
= all_vectors
;
618 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
619 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
620 See also the function `vector'.")
622 register Lisp_Object length
, init
;
625 register EMACS_INT sizei
;
627 register struct Lisp_Vector
*p
;
629 CHECK_NATNUM (length
, 0);
630 sizei
= XFASTINT (length
);
632 p
= allocate_vectorlike (sizei
);
634 for (index
= 0; index
< sizei
; index
++)
635 p
->contents
[index
] = init
;
637 XSETVECTOR (vector
, p
);
641 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
642 "Return a newly created vector with specified arguments as elements.\n\
643 Any number of arguments, even zero arguments, are allowed.")
648 register Lisp_Object len
, val
;
650 register struct Lisp_Vector
*p
;
652 XSETFASTINT (len
, nargs
);
653 val
= Fmake_vector (len
, Qnil
);
655 for (index
= 0; index
< nargs
; index
++)
656 p
->contents
[index
] = args
[index
];
660 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
661 "Create a byte-code object with specified arguments as elements.\n\
662 The arguments should be the arglist, bytecode-string, constant vector,\n\
663 stack size, (optional) doc string, and (optional) interactive spec.\n\
664 The first four arguments are required; at most six have any\n\
670 register Lisp_Object len
, val
;
672 register struct Lisp_Vector
*p
;
674 XSETFASTINT (len
, nargs
);
675 if (!NILP (Vpurify_flag
))
676 val
= make_pure_vector (len
);
678 val
= Fmake_vector (len
, Qnil
);
680 for (index
= 0; index
< nargs
; index
++)
682 if (!NILP (Vpurify_flag
))
683 args
[index
] = Fpurecopy (args
[index
]);
684 p
->contents
[index
] = args
[index
];
686 XSETCOMPILED (val
, val
);
690 /* Allocation of symbols.
691 Just like allocation of conses!
693 Each symbol_block is just under 1020 bytes long,
694 since malloc really allocates in units of powers of two
695 and uses 4 bytes for its own overhead. */
697 #define SYMBOL_BLOCK_SIZE \
698 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
702 struct symbol_block
*next
;
703 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
706 struct symbol_block
*symbol_block
;
707 int symbol_block_index
;
709 struct Lisp_Symbol
*symbol_free_list
;
714 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
715 symbol_block
->next
= 0;
716 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
717 symbol_block_index
= 0;
718 symbol_free_list
= 0;
721 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
722 "Return a newly allocated uninterned symbol whose name is NAME.\n\
723 Its value and function definition are void, and its property list is nil.")
727 register Lisp_Object val
;
728 register struct Lisp_Symbol
*p
;
730 CHECK_STRING (str
, 0);
732 if (symbol_free_list
)
734 XSETSYMBOL (val
, symbol_free_list
);
735 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
739 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
741 struct symbol_block
*new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
742 VALIDATE_LISP_STORAGE (new, sizeof *new);
743 new->next
= symbol_block
;
745 symbol_block_index
= 0;
747 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
750 p
->name
= XSTRING (str
);
753 p
->function
= Qunbound
;
755 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
759 /* Allocation of markers and other objects that share that structure.
760 Works like allocation of conses. */
762 #define MARKER_BLOCK_SIZE \
763 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
767 struct marker_block
*next
;
768 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
771 struct marker_block
*marker_block
;
772 int marker_block_index
;
774 union Lisp_Misc
*marker_free_list
;
779 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
780 marker_block
->next
= 0;
781 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
782 marker_block_index
= 0;
783 marker_free_list
= 0;
786 /* Return a newly allocated Lisp_Misc object, with no substructure. */
792 if (marker_free_list
)
794 XSETMISC (val
, marker_free_list
);
795 marker_free_list
= marker_free_list
->u_free
.chain
;
799 if (marker_block_index
== MARKER_BLOCK_SIZE
)
801 struct marker_block
*new
802 = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
803 VALIDATE_LISP_STORAGE (new, sizeof *new);
804 new->next
= marker_block
;
806 marker_block_index
= 0;
808 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
810 consing_since_gc
+= sizeof (union Lisp_Misc
);
814 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
815 "Return a newly allocated marker which does not point at any place.")
818 register Lisp_Object val
;
819 register struct Lisp_Marker
*p
;
821 val
= allocate_misc ();
822 XMISC (val
)->type
= Lisp_Misc_Marker
;
830 /* Allocation of strings */
832 /* Strings reside inside of string_blocks. The entire data of the string,
833 both the size and the contents, live in part of the `chars' component of a string_block.
834 The `pos' component is the index within `chars' of the first free byte.
836 first_string_block points to the first string_block ever allocated.
837 Each block points to the next one with its `next' field.
838 The `prev' fields chain in reverse order.
839 The last one allocated is the one currently being filled.
840 current_string_block points to it.
842 The string_blocks that hold individual large strings
843 go in a separate chain, started by large_string_blocks. */
846 /* String blocks contain this many useful bytes.
847 8188 is power of 2, minus 4 for malloc overhead. */
848 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
850 /* A string bigger than this gets its own specially-made string block
851 if it doesn't fit in the current one. */
852 #define STRING_BLOCK_OUTSIZE 1024
854 struct string_block_head
856 struct string_block
*next
, *prev
;
862 struct string_block
*next
, *prev
;
864 char chars
[STRING_BLOCK_SIZE
];
867 /* This points to the string block we are now allocating strings. */
869 struct string_block
*current_string_block
;
871 /* This points to the oldest string block, the one that starts the chain. */
873 struct string_block
*first_string_block
;
875 /* Last string block in chain of those made for individual large strings. */
877 struct string_block
*large_string_blocks
;
879 /* If SIZE is the length of a string, this returns how many bytes
880 the string occupies in a string_block (including padding). */
882 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
884 #define PAD (sizeof (EMACS_INT))
887 #define STRING_FULLSIZE(SIZE) \
888 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
894 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
895 first_string_block
= current_string_block
;
896 consing_since_gc
+= sizeof (struct string_block
);
897 current_string_block
->next
= 0;
898 current_string_block
->prev
= 0;
899 current_string_block
->pos
= 0;
900 large_string_blocks
= 0;
903 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
904 "Return a newly created string of length LENGTH, with each element being INIT.\n\
905 Both LENGTH and INIT must be numbers.")
907 Lisp_Object length
, init
;
909 register Lisp_Object val
;
910 register unsigned char *p
, *end
, c
;
912 CHECK_NATNUM (length
, 0);
913 CHECK_NUMBER (init
, 1);
914 val
= make_uninit_string (XFASTINT (length
));
916 p
= XSTRING (val
)->data
;
917 end
= p
+ XSTRING (val
)->size
;
925 make_string (contents
, length
)
929 register Lisp_Object val
;
930 val
= make_uninit_string (length
);
931 bcopy (contents
, XSTRING (val
)->data
, length
);
939 return make_string (str
, strlen (str
));
943 make_uninit_string (length
)
946 register Lisp_Object val
;
947 register int fullsize
= STRING_FULLSIZE (length
);
949 if (length
< 0) abort ();
951 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
952 /* This string can fit in the current string block */
955 ((struct Lisp_String
*)
956 (current_string_block
->chars
+ current_string_block
->pos
)));
957 current_string_block
->pos
+= fullsize
;
959 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
960 /* This string gets its own string block */
962 register struct string_block
*new
963 = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
964 VALIDATE_LISP_STORAGE (new, 0);
965 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
967 new->next
= large_string_blocks
;
968 large_string_blocks
= new;
970 ((struct Lisp_String
*)
971 ((struct string_block_head
*)new + 1)));
974 /* Make a new current string block and start it off with this string */
976 register struct string_block
*new
977 = (struct string_block
*) xmalloc (sizeof (struct string_block
));
978 VALIDATE_LISP_STORAGE (new, sizeof *new);
979 consing_since_gc
+= sizeof (struct string_block
);
980 current_string_block
->next
= new;
981 new->prev
= current_string_block
;
983 current_string_block
= new;
986 (struct Lisp_String
*) current_string_block
->chars
);
989 XSTRING (val
)->size
= length
;
990 XSTRING (val
)->data
[length
] = 0;
991 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
996 /* Return a newly created vector or string with specified arguments as
997 elements. If all the arguments are characters that can fit
998 in a string of events, make a string; otherwise, make a vector.
1000 Any number of arguments, even zero arguments, are allowed. */
1003 make_event_array (nargs
, args
)
1009 for (i
= 0; i
< nargs
; i
++)
1010 /* The things that fit in a string
1011 are characters that are in 0...127,
1012 after discarding the meta bit and all the bits above it. */
1013 if (!INTEGERP (args
[i
])
1014 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1015 return Fvector (nargs
, args
);
1017 /* Since the loop exited, we know that all the things in it are
1018 characters, so we can make a string. */
1022 result
= Fmake_string (nargs
, make_number (0));
1023 for (i
= 0; i
< nargs
; i
++)
1025 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1026 /* Move the meta bit to the right place for a string char. */
1027 if (XINT (args
[i
]) & CHAR_META
)
1028 XSTRING (result
)->data
[i
] |= 0x80;
1035 /* Pure storage management. */
1037 /* Must get an error if pure storage is full,
1038 since if it cannot hold a large string
1039 it may be able to hold conses that point to that string;
1040 then the string is not protected from gc. */
1043 make_pure_string (data
, length
)
1047 register Lisp_Object
new;
1048 register int size
= sizeof (EMACS_INT
) + INTERVAL_PTR_SIZE
+ length
+ 1;
1050 if (pureptr
+ size
> PURESIZE
)
1051 error ("Pure Lisp storage exhausted");
1052 XSETSTRING (new, PUREBEG
+ pureptr
);
1053 XSTRING (new)->size
= length
;
1054 bcopy (data
, XSTRING (new)->data
, length
);
1055 XSTRING (new)->data
[length
] = 0;
1057 /* We must give strings in pure storage some kind of interval. So we
1058 give them a null one. */
1059 #if defined (USE_TEXT_PROPERTIES)
1060 XSTRING (new)->intervals
= NULL_INTERVAL
;
1062 pureptr
+= (size
+ sizeof (EMACS_INT
) - 1)
1063 / sizeof (EMACS_INT
) * sizeof (EMACS_INT
);
1068 pure_cons (car
, cdr
)
1069 Lisp_Object car
, cdr
;
1071 register Lisp_Object
new;
1073 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1074 error ("Pure Lisp storage exhausted");
1075 XSETCONS (new, PUREBEG
+ pureptr
);
1076 pureptr
+= sizeof (struct Lisp_Cons
);
1077 XCONS (new)->car
= Fpurecopy (car
);
1078 XCONS (new)->cdr
= Fpurecopy (cdr
);
1082 #ifdef LISP_FLOAT_TYPE
1085 make_pure_float (num
)
1088 register Lisp_Object
new;
1090 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1091 (double) boundary. Some architectures (like the sparc) require
1092 this, and I suspect that floats are rare enough that it's no
1093 tragedy for those that do. */
1096 char *p
= PUREBEG
+ pureptr
;
1100 alignment
= __alignof (struct Lisp_Float
);
1102 alignment
= sizeof (struct Lisp_Float
);
1105 alignment
= sizeof (struct Lisp_Float
);
1107 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1108 pureptr
= p
- PUREBEG
;
1111 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1112 error ("Pure Lisp storage exhausted");
1113 XSETFLOAT (new, PUREBEG
+ pureptr
);
1114 pureptr
+= sizeof (struct Lisp_Float
);
1115 XFLOAT (new)->data
= num
;
1116 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1120 #endif /* LISP_FLOAT_TYPE */
1123 make_pure_vector (len
)
1126 register Lisp_Object
new;
1127 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1129 if (pureptr
+ size
> PURESIZE
)
1130 error ("Pure Lisp storage exhausted");
1132 XSETVECTOR (new, PUREBEG
+ pureptr
);
1134 XVECTOR (new)->size
= len
;
1138 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1139 "Make a copy of OBJECT in pure storage.\n\
1140 Recursively copies contents of vectors and cons cells.\n\
1141 Does not copy symbols.")
1143 register Lisp_Object obj
;
1145 if (NILP (Vpurify_flag
))
1148 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1149 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1153 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1154 #ifdef LISP_FLOAT_TYPE
1155 else if (FLOATP (obj
))
1156 return make_pure_float (XFLOAT (obj
)->data
);
1157 #endif /* LISP_FLOAT_TYPE */
1158 else if (STRINGP (obj
))
1159 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1160 else if (COMPILEDP (obj
) || VECTORP (obj
))
1162 register struct Lisp_Vector
*vec
;
1163 register int i
, size
;
1165 size
= XVECTOR (obj
)->size
;
1166 if (size
& PSEUDOVECTOR_FLAG
)
1167 size
&= PSEUDOVECTOR_SIZE_MASK
;
1168 vec
= XVECTOR (make_pure_vector (size
));
1169 for (i
= 0; i
< size
; i
++)
1170 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1171 if (COMPILEDP (obj
))
1172 XSETCOMPILED (obj
, vec
);
1174 XSETVECTOR (obj
, vec
);
1177 else if (MARKERP (obj
))
1178 error ("Attempt to copy a marker to pure storage");
1183 /* Recording what needs to be marked for gc. */
1185 struct gcpro
*gcprolist
;
1187 #define NSTATICS 512
1189 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1193 /* Put an entry in staticvec, pointing at the variable whose address is given */
1196 staticpro (varaddress
)
1197 Lisp_Object
*varaddress
;
1199 staticvec
[staticidx
++] = varaddress
;
1200 if (staticidx
>= NSTATICS
)
1208 struct catchtag
*next
;
1209 /* jmp_buf jmp; /* We don't need this for GC purposes */
1214 struct backtrace
*next
;
1215 Lisp_Object
*function
;
1216 Lisp_Object
*args
; /* Points to vector of args. */
1217 int nargs
; /* length of vector */
1218 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1222 /* Garbage collection! */
1224 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1225 int total_free_conses
, total_free_markers
, total_free_symbols
;
1226 #ifdef LISP_FLOAT_TYPE
1227 int total_free_floats
, total_floats
;
1228 #endif /* LISP_FLOAT_TYPE */
1230 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1231 "Reclaim storage for Lisp objects no longer needed.\n\
1232 Returns info on amount of space in use:\n\
1233 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1234 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1235 (USED-FLOATS . FREE-FLOATS))\n\
1236 Garbage collection happens automatically if you cons more than\n\
1237 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1240 register struct gcpro
*tail
;
1241 register struct specbinding
*bind
;
1242 struct catchtag
*catch;
1243 struct handler
*handler
;
1244 register struct backtrace
*backlist
;
1245 register Lisp_Object tem
;
1246 char *omessage
= echo_area_glyphs
;
1247 int omessage_length
= echo_area_glyphs_length
;
1248 char stack_top_variable
;
1251 /* Save a copy of the contents of the stack, for debugging. */
1252 #if MAX_SAVE_STACK > 0
1253 if (NILP (Vpurify_flag
))
1255 i
= &stack_top_variable
- stack_bottom
;
1257 if (i
< MAX_SAVE_STACK
)
1259 if (stack_copy
== 0)
1260 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1261 else if (stack_copy_size
< i
)
1262 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1265 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1266 bcopy (stack_bottom
, stack_copy
, i
);
1268 bcopy (&stack_top_variable
, stack_copy
, i
);
1272 #endif /* MAX_SAVE_STACK > 0 */
1274 if (!noninteractive
)
1275 message1_nolog ("Garbage collecting...");
1277 /* Don't keep command history around forever */
1278 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1280 XCONS (tem
)->cdr
= Qnil
;
1282 /* Likewise for undo information. */
1284 register struct buffer
*nextb
= all_buffers
;
1288 /* If a buffer's undo list is Qt, that means that undo is
1289 turned off in that buffer. Calling truncate_undo_list on
1290 Qt tends to return NULL, which effectively turns undo back on.
1291 So don't call truncate_undo_list if undo_list is Qt. */
1292 if (! EQ (nextb
->undo_list
, Qt
))
1294 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1296 nextb
= nextb
->next
;
1302 /* clear_marks (); */
1304 /* In each "large string", set the MARKBIT of the size field.
1305 That enables mark_object to recognize them. */
1307 register struct string_block
*b
;
1308 for (b
= large_string_blocks
; b
; b
= b
->next
)
1309 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1312 /* Mark all the special slots that serve as the roots of accessibility.
1314 Usually the special slots to mark are contained in particular structures.
1315 Then we know no slot is marked twice because the structures don't overlap.
1316 In some cases, the structures point to the slots to be marked.
1317 For these, we use MARKBIT to avoid double marking of the slot. */
1319 for (i
= 0; i
< staticidx
; i
++)
1320 mark_object (staticvec
[i
]);
1321 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1322 for (i
= 0; i
< tail
->nvars
; i
++)
1323 if (!XMARKBIT (tail
->var
[i
]))
1325 mark_object (&tail
->var
[i
]);
1326 XMARK (tail
->var
[i
]);
1328 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1330 mark_object (&bind
->symbol
);
1331 mark_object (&bind
->old_value
);
1333 for (catch = catchlist
; catch; catch = catch->next
)
1335 mark_object (&catch->tag
);
1336 mark_object (&catch->val
);
1338 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1340 mark_object (&handler
->handler
);
1341 mark_object (&handler
->var
);
1343 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1345 if (!XMARKBIT (*backlist
->function
))
1347 mark_object (backlist
->function
);
1348 XMARK (*backlist
->function
);
1350 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1353 i
= backlist
->nargs
- 1;
1355 if (!XMARKBIT (backlist
->args
[i
]))
1357 mark_object (&backlist
->args
[i
]);
1358 XMARK (backlist
->args
[i
]);
1364 /* Clear the mark bits that we set in certain root slots. */
1366 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1367 for (i
= 0; i
< tail
->nvars
; i
++)
1368 XUNMARK (tail
->var
[i
]);
1369 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1371 XUNMARK (*backlist
->function
);
1372 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1375 i
= backlist
->nargs
- 1;
1377 XUNMARK (backlist
->args
[i
]);
1379 XUNMARK (buffer_defaults
.name
);
1380 XUNMARK (buffer_local_symbols
.name
);
1382 /* clear_marks (); */
1385 consing_since_gc
= 0;
1386 if (gc_cons_threshold
< 10000)
1387 gc_cons_threshold
= 10000;
1389 if (omessage
|| minibuf_level
> 0)
1390 message2_nolog (omessage
, omessage_length
);
1391 else if (!noninteractive
)
1392 message1_nolog ("Garbage collecting...done");
1394 return Fcons (Fcons (make_number (total_conses
),
1395 make_number (total_free_conses
)),
1396 Fcons (Fcons (make_number (total_symbols
),
1397 make_number (total_free_symbols
)),
1398 Fcons (Fcons (make_number (total_markers
),
1399 make_number (total_free_markers
)),
1400 Fcons (make_number (total_string_size
),
1401 Fcons (make_number (total_vector_size
),
1403 #ifdef LISP_FLOAT_TYPE
1404 Fcons (Fcons (make_number (total_floats
),
1405 make_number (total_free_floats
)),
1407 #else /* not LISP_FLOAT_TYPE */
1409 #endif /* not LISP_FLOAT_TYPE */
1417 /* Clear marks on all conses */
1419 register struct cons_block
*cblk
;
1420 register int lim
= cons_block_index
;
1422 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1425 for (i
= 0; i
< lim
; i
++)
1426 XUNMARK (cblk
->conses
[i
].car
);
1427 lim
= CONS_BLOCK_SIZE
;
1430 /* Clear marks on all symbols */
1432 register struct symbol_block
*sblk
;
1433 register int lim
= symbol_block_index
;
1435 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1438 for (i
= 0; i
< lim
; i
++)
1440 XUNMARK (sblk
->symbols
[i
].plist
);
1442 lim
= SYMBOL_BLOCK_SIZE
;
1445 /* Clear marks on all markers */
1447 register struct marker_block
*sblk
;
1448 register int lim
= marker_block_index
;
1450 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1453 for (i
= 0; i
< lim
; i
++)
1454 if (sblk
->markers
[i
].type
== Lisp_Misc_Marker
)
1455 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1456 lim
= MARKER_BLOCK_SIZE
;
1459 /* Clear mark bits on all buffers */
1461 register struct buffer
*nextb
= all_buffers
;
1465 XUNMARK (nextb
->name
);
1466 nextb
= nextb
->next
;
1472 /* Mark reference to a Lisp_Object.
1473 If the object referred to has not been seen yet, recursively mark
1474 all the references contained in it.
1476 If the object referenced is a short string, the referencing slot
1477 is threaded into a chain of such slots, pointed to from
1478 the `size' field of the string. The actual string size
1479 lives in the last slot in the chain. We recognize the end
1480 because it is < (unsigned) STRING_BLOCK_SIZE. */
1482 #define LAST_MARKED_SIZE 500
1483 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1484 int last_marked_index
;
1487 mark_object (objptr
)
1488 Lisp_Object
*objptr
;
1490 register Lisp_Object obj
;
1497 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1498 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1501 last_marked
[last_marked_index
++] = objptr
;
1502 if (last_marked_index
== LAST_MARKED_SIZE
)
1503 last_marked_index
= 0;
1505 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
1509 register struct Lisp_String
*ptr
= XSTRING (obj
);
1511 MARK_INTERVAL_TREE (ptr
->intervals
);
1512 if (ptr
->size
& MARKBIT
)
1513 /* A large string. Just set ARRAY_MARK_FLAG. */
1514 ptr
->size
|= ARRAY_MARK_FLAG
;
1517 /* A small string. Put this reference
1518 into the chain of references to it.
1519 If the address includes MARKBIT, put that bit elsewhere
1520 when we store OBJPTR into the size field. */
1522 if (XMARKBIT (*objptr
))
1524 XSETFASTINT (*objptr
, ptr
->size
);
1528 XSETFASTINT (*objptr
, ptr
->size
);
1530 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
1532 ptr
->size
= (EMACS_INT
) objptr
;
1533 if (ptr
->size
& MARKBIT
)
1534 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
1539 case Lisp_Vectorlike
:
1540 if (GC_BUFFERP (obj
))
1542 if (!XMARKBIT (XBUFFER (obj
)->name
))
1545 else if (GC_SUBRP (obj
))
1547 else if (GC_COMPILEDP (obj
))
1548 /* We could treat this just like a vector, but it is better
1549 to save the COMPILED_CONSTANTS element for last and avoid recursion
1552 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1553 register EMACS_INT size
= ptr
->size
;
1554 /* See comment above under Lisp_Vector. */
1555 struct Lisp_Vector
*volatile ptr1
= ptr
;
1558 if (size
& ARRAY_MARK_FLAG
)
1559 break; /* Already marked */
1560 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1561 size
&= PSEUDOVECTOR_SIZE_MASK
;
1562 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1564 if (i
!= COMPILED_CONSTANTS
)
1565 mark_object (&ptr1
->contents
[i
]);
1567 /* This cast should be unnecessary, but some Mips compiler complains
1568 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1569 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1573 else if (GC_FRAMEP (obj
))
1575 /* See comment above under Lisp_Vector for why this is volatile. */
1576 register struct frame
*volatile ptr
= XFRAME (obj
);
1577 register EMACS_INT size
= ptr
->size
;
1579 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1580 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1582 mark_object (&ptr
->name
);
1583 mark_object (&ptr
->focus_frame
);
1584 mark_object (&ptr
->selected_window
);
1585 mark_object (&ptr
->minibuffer_window
);
1586 mark_object (&ptr
->param_alist
);
1587 mark_object (&ptr
->scroll_bars
);
1588 mark_object (&ptr
->condemned_scroll_bars
);
1589 mark_object (&ptr
->menu_bar_items
);
1590 mark_object (&ptr
->face_alist
);
1591 mark_object (&ptr
->menu_bar_vector
);
1592 mark_object (&ptr
->buffer_predicate
);
1594 #endif /* MULTI_FRAME */
1597 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1598 register EMACS_INT size
= ptr
->size
;
1599 /* The reason we use ptr1 is to avoid an apparent hardware bug
1600 that happens occasionally on the FSF's HP 300s.
1601 The bug is that a2 gets clobbered by recursive calls to mark_object.
1602 The clobberage seems to happen during function entry,
1603 perhaps in the moveml instruction.
1604 Yes, this is a crock, but we have to do it. */
1605 struct Lisp_Vector
*volatile ptr1
= ptr
;
1608 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1609 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1610 if (size
& PSEUDOVECTOR_FLAG
)
1611 size
&= PSEUDOVECTOR_SIZE_MASK
;
1612 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1613 mark_object (&ptr1
->contents
[i
]);
1619 /* See comment above under Lisp_Vector for why this is volatile. */
1620 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1621 struct Lisp_Symbol
*ptrx
;
1623 if (XMARKBIT (ptr
->plist
)) break;
1625 mark_object ((Lisp_Object
*) &ptr
->value
);
1626 mark_object (&ptr
->function
);
1627 mark_object (&ptr
->plist
);
1628 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1629 mark_object (&ptr
->name
);
1633 /* For the benefit of the last_marked log. */
1634 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1635 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1636 XSETSYMBOL (obj
, ptrx
);
1637 /* We can't goto loop here because *objptr doesn't contain an
1638 actual Lisp_Object with valid datatype field. */
1645 switch (XMISC (obj
)->type
)
1647 case Lisp_Misc_Marker
:
1648 XMARK (XMARKER (obj
)->chain
);
1649 /* DO NOT mark thru the marker's chain.
1650 The buffer's markers chain does not preserve markers from gc;
1651 instead, markers are removed from the chain when freed by gc. */
1654 case Lisp_Misc_Buffer_Local_Value
:
1655 case Lisp_Misc_Some_Buffer_Local_Value
:
1657 register struct Lisp_Buffer_Local_Value
*ptr
1658 = XBUFFER_LOCAL_VALUE (obj
);
1659 if (XMARKBIT (ptr
->car
)) break;
1661 /* If the cdr is nil, avoid recursion for the car. */
1662 if (EQ (ptr
->cdr
, Qnil
))
1667 mark_object (&ptr
->car
);
1668 /* See comment above under Lisp_Vector for why not use ptr here. */
1669 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
1673 case Lisp_Misc_Intfwd
:
1674 case Lisp_Misc_Boolfwd
:
1675 case Lisp_Misc_Objfwd
:
1676 case Lisp_Misc_Buffer_Objfwd
:
1677 case Lisp_Misc_Display_Objfwd
:
1678 /* Don't bother with Lisp_Buffer_Objfwd,
1679 since all markable slots in current buffer marked anyway. */
1680 /* Don't need to do Lisp_Objfwd, since the places they point
1681 are protected with staticpro. */
1684 case Lisp_Misc_Overlay
:
1686 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
1687 if (!XMARKBIT (ptr
->plist
))
1690 mark_object (&ptr
->start
);
1691 mark_object (&ptr
->end
);
1692 objptr
= &ptr
->plist
;
1705 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1706 if (XMARKBIT (ptr
->car
)) break;
1708 /* If the cdr is nil, avoid recursion for the car. */
1709 if (EQ (ptr
->cdr
, Qnil
))
1714 mark_object (&ptr
->car
);
1715 /* See comment above under Lisp_Vector for why not use ptr here. */
1716 objptr
= &XCONS (obj
)->cdr
;
1720 #ifdef LISP_FLOAT_TYPE
1722 XMARK (XFLOAT (obj
)->type
);
1724 #endif /* LISP_FLOAT_TYPE */
1734 /* Mark the pointers in a buffer structure. */
1740 register struct buffer
*buffer
= XBUFFER (buf
);
1741 register Lisp_Object
*ptr
;
1742 Lisp_Object base_buffer
;
1744 /* This is the buffer's markbit */
1745 mark_object (&buffer
->name
);
1746 XMARK (buffer
->name
);
1748 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
1751 mark_object (buffer
->syntax_table
);
1753 /* Mark the various string-pointers in the buffer object.
1754 Since the strings may be relocated, we must mark them
1755 in their actual slots. So gc_sweep must convert each slot
1756 back to an ordinary C pointer. */
1757 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
1758 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1759 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
1760 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1762 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
1763 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1764 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
1765 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1768 for (ptr
= &buffer
->name
+ 1;
1769 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1773 /* If this is an indirect buffer, mark its base buffer. */
1774 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
1776 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
1777 mark_buffer (base_buffer
);
1781 /* Sweep: find all structures not marked, and free them. */
1786 total_string_size
= 0;
1789 /* Put all unmarked conses on free list */
1791 register struct cons_block
*cblk
;
1792 register int lim
= cons_block_index
;
1793 register int num_free
= 0, num_used
= 0;
1797 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1800 for (i
= 0; i
< lim
; i
++)
1801 if (!XMARKBIT (cblk
->conses
[i
].car
))
1804 *(struct Lisp_Cons
**)&cblk
->conses
[i
].car
= cons_free_list
;
1805 cons_free_list
= &cblk
->conses
[i
];
1810 XUNMARK (cblk
->conses
[i
].car
);
1812 lim
= CONS_BLOCK_SIZE
;
1814 total_conses
= num_used
;
1815 total_free_conses
= num_free
;
1818 #ifdef LISP_FLOAT_TYPE
1819 /* Put all unmarked floats on free list */
1821 register struct float_block
*fblk
;
1822 register int lim
= float_block_index
;
1823 register int num_free
= 0, num_used
= 0;
1825 float_free_list
= 0;
1827 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1830 for (i
= 0; i
< lim
; i
++)
1831 if (!XMARKBIT (fblk
->floats
[i
].type
))
1834 *(struct Lisp_Float
**)&fblk
->floats
[i
].type
= float_free_list
;
1835 float_free_list
= &fblk
->floats
[i
];
1840 XUNMARK (fblk
->floats
[i
].type
);
1842 lim
= FLOAT_BLOCK_SIZE
;
1844 total_floats
= num_used
;
1845 total_free_floats
= num_free
;
1847 #endif /* LISP_FLOAT_TYPE */
1849 #ifdef USE_TEXT_PROPERTIES
1850 /* Put all unmarked intervals on free list */
1852 register struct interval_block
*iblk
;
1853 register int lim
= interval_block_index
;
1854 register int num_free
= 0, num_used
= 0;
1856 interval_free_list
= 0;
1858 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1862 for (i
= 0; i
< lim
; i
++)
1864 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1866 iblk
->intervals
[i
].parent
= interval_free_list
;
1867 interval_free_list
= &iblk
->intervals
[i
];
1873 XUNMARK (iblk
->intervals
[i
].plist
);
1876 lim
= INTERVAL_BLOCK_SIZE
;
1878 total_intervals
= num_used
;
1879 total_free_intervals
= num_free
;
1881 #endif /* USE_TEXT_PROPERTIES */
1883 /* Put all unmarked symbols on free list */
1885 register struct symbol_block
*sblk
;
1886 register int lim
= symbol_block_index
;
1887 register int num_free
= 0, num_used
= 0;
1889 symbol_free_list
= 0;
1891 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1894 for (i
= 0; i
< lim
; i
++)
1895 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1897 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
1898 symbol_free_list
= &sblk
->symbols
[i
];
1904 sblk
->symbols
[i
].name
1905 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1906 XUNMARK (sblk
->symbols
[i
].plist
);
1908 lim
= SYMBOL_BLOCK_SIZE
;
1910 total_symbols
= num_used
;
1911 total_free_symbols
= num_free
;
1915 /* Put all unmarked markers on free list.
1916 Dechain each one first from the buffer it points into,
1917 but only if it's a real marker. */
1919 register struct marker_block
*mblk
;
1920 register int lim
= marker_block_index
;
1921 register int num_free
= 0, num_used
= 0;
1923 marker_free_list
= 0;
1925 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1928 for (i
= 0; i
< lim
; i
++)
1930 Lisp_Object
*markword
;
1931 switch (mblk
->markers
[i
].type
)
1933 case Lisp_Misc_Marker
:
1934 markword
= &mblk
->markers
[i
].u_marker
.chain
;
1936 case Lisp_Misc_Buffer_Local_Value
:
1937 case Lisp_Misc_Some_Buffer_Local_Value
:
1938 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
1940 case Lisp_Misc_Overlay
:
1941 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
1947 if (markword
&& !XMARKBIT (*markword
))
1950 if (mblk
->markers
[i
].type
== Lisp_Misc_Marker
)
1952 /* tem1 avoids Sun compiler bug */
1953 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
1954 XSETMARKER (tem
, tem1
);
1955 unchain_marker (tem
);
1957 /* We could leave the type alone, since nobody checks it,
1958 but this might catch bugs faster. */
1959 mblk
->markers
[i
].type
= Lisp_Misc_Free
;
1960 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
1961 marker_free_list
= &mblk
->markers
[i
];
1968 XUNMARK (*markword
);
1971 lim
= MARKER_BLOCK_SIZE
;
1974 total_markers
= num_used
;
1975 total_free_markers
= num_free
;
1978 /* Free all unmarked buffers */
1980 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1983 if (!XMARKBIT (buffer
->name
))
1986 prev
->next
= buffer
->next
;
1988 all_buffers
= buffer
->next
;
1989 next
= buffer
->next
;
1995 XUNMARK (buffer
->name
);
1996 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
1999 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2000 for purposes of marking and relocation.
2001 Turn them back into C pointers now. */
2002 buffer
->upcase_table
2003 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2004 buffer
->downcase_table
2005 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2007 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2008 buffer
->folding_sort_table
2009 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2012 prev
= buffer
, buffer
= buffer
->next
;
2016 #endif /* standalone */
2018 /* Free all unmarked vectors */
2020 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2021 total_vector_size
= 0;
2024 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2027 prev
->next
= vector
->next
;
2029 all_vectors
= vector
->next
;
2030 next
= vector
->next
;
2036 vector
->size
&= ~ARRAY_MARK_FLAG
;
2037 total_vector_size
+= vector
->size
;
2038 prev
= vector
, vector
= vector
->next
;
2042 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2044 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2045 struct Lisp_String
*s
;
2049 s
= (struct Lisp_String
*) &sb
->chars
[0];
2050 if (s
->size
& ARRAY_MARK_FLAG
)
2052 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2053 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2054 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2055 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2056 prev
= sb
, sb
= sb
->next
;
2061 prev
->next
= sb
->next
;
2063 large_string_blocks
= sb
->next
;
2072 /* Compactify strings, relocate references, and free empty string blocks. */
2077 /* String block of old strings we are scanning. */
2078 register struct string_block
*from_sb
;
2079 /* A preceding string block (or maybe the same one)
2080 where we are copying the still-live strings to. */
2081 register struct string_block
*to_sb
;
2085 to_sb
= first_string_block
;
2088 /* Scan each existing string block sequentially, string by string. */
2089 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2092 /* POS is the index of the next string in the block. */
2093 while (pos
< from_sb
->pos
)
2095 register struct Lisp_String
*nextstr
2096 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2098 register struct Lisp_String
*newaddr
;
2099 register EMACS_INT size
= nextstr
->size
;
2101 /* NEXTSTR is the old address of the next string.
2102 Just skip it if it isn't marked. */
2103 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2105 /* It is marked, so its size field is really a chain of refs.
2106 Find the end of the chain, where the actual size lives. */
2107 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2109 if (size
& DONT_COPY_FLAG
)
2110 size
^= MARKBIT
| DONT_COPY_FLAG
;
2111 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2114 total_string_size
+= size
;
2116 /* If it won't fit in TO_SB, close it out,
2117 and move to the next sb. Keep doing so until
2118 TO_SB reaches a large enough, empty enough string block.
2119 We know that TO_SB cannot advance past FROM_SB here
2120 since FROM_SB is large enough to contain this string.
2121 Any string blocks skipped here
2122 will be patched out and freed later. */
2123 while (to_pos
+ STRING_FULLSIZE (size
)
2124 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2126 to_sb
->pos
= to_pos
;
2127 to_sb
= to_sb
->next
;
2130 /* Compute new address of this string
2131 and update TO_POS for the space being used. */
2132 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2133 to_pos
+= STRING_FULLSIZE (size
);
2135 /* Copy the string itself to the new place. */
2136 if (nextstr
!= newaddr
)
2137 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2138 + INTERVAL_PTR_SIZE
);
2140 /* Go through NEXTSTR's chain of references
2141 and make each slot in the chain point to
2142 the new address of this string. */
2143 size
= newaddr
->size
;
2144 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2146 register Lisp_Object
*objptr
;
2147 if (size
& DONT_COPY_FLAG
)
2148 size
^= MARKBIT
| DONT_COPY_FLAG
;
2149 objptr
= (Lisp_Object
*)size
;
2151 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2152 if (XMARKBIT (*objptr
))
2154 XSETSTRING (*objptr
, newaddr
);
2158 XSETSTRING (*objptr
, newaddr
);
2160 /* Store the actual size in the size field. */
2161 newaddr
->size
= size
;
2163 #ifdef USE_TEXT_PROPERTIES
2164 /* Now that the string has been relocated, rebalance its
2165 interval tree, and update the tree's parent pointer. */
2166 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2168 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2169 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2172 #endif /* USE_TEXT_PROPERTIES */
2174 pos
+= STRING_FULLSIZE (size
);
2178 /* Close out the last string block still used and free any that follow. */
2179 to_sb
->pos
= to_pos
;
2180 current_string_block
= to_sb
;
2182 from_sb
= to_sb
->next
;
2186 to_sb
= from_sb
->next
;
2191 /* Free any empty string blocks further back in the chain.
2192 This loop will never free first_string_block, but it is very
2193 unlikely that that one will become empty, so why bother checking? */
2195 from_sb
= first_string_block
;
2196 while (to_sb
= from_sb
->next
)
2198 if (to_sb
->pos
== 0)
2200 if (from_sb
->next
= to_sb
->next
)
2201 from_sb
->next
->prev
= from_sb
;
2209 /* Debugging aids. */
2211 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2212 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2213 This may be helpful in debugging Emacs's memory usage.\n\
2214 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2219 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2225 /* Initialization */
2229 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2232 pure_size
= PURESIZE
;
2235 ignore_warnings
= 1;
2240 #ifdef LISP_FLOAT_TYPE
2242 #endif /* LISP_FLOAT_TYPE */
2245 ignore_warnings
= 0;
2248 consing_since_gc
= 0;
2249 gc_cons_threshold
= 100000;
2250 #ifdef VIRT_ADDR_VARIES
2251 malloc_sbrk_unused
= 1<<22; /* A large number */
2252 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2253 #endif /* VIRT_ADDR_VARIES */
2264 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2265 "*Number of bytes of consing between garbage collections.\n\
2266 Garbage collection can happen automatically once this many bytes have been\n\
2267 allocated since the last garbage collection. All data types count.\n\n\
2268 Garbage collection happens automatically only when `eval' is called.\n\n\
2269 By binding this temporarily to a large number, you can effectively\n\
2270 prevent garbage collection during a part of the program.");
2272 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2273 "Number of bytes of sharable Lisp data allocated so far.");
2276 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2277 "Number of bytes of unshared memory allocated in this session.");
2279 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2280 "Number of bytes of unshared memory remaining available in this session.");
2283 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2284 "Non-nil means loading Lisp code in order to dump an executable.\n\
2285 This means that certain objects should be allocated in shared (pure) space.");
2287 DEFVAR_INT ("undo-limit", &undo_limit
,
2288 "Keep no more undo information once it exceeds this size.\n\
2289 This limit is applied when garbage collection happens.\n\
2290 The size is counted as the number of bytes occupied,\n\
2291 which includes both saved text and other data.");
2294 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2295 "Don't keep more than this much size of undo information.\n\
2296 A command which pushes past this size is itself forgotten.\n\
2297 This limit is applied when garbage collection happens.\n\
2298 The size is counted as the number of bytes occupied,\n\
2299 which includes both saved text and other data.");
2300 undo_strong_limit
= 30000;
2302 /* We build this in advance because if we wait until we need it, we might
2303 not be able to allocate the memory to hold it. */
2305 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted"), Qnil
));
2306 staticpro (&memory_signal_data
);
2311 defsubr (&Smake_byte_code
);
2312 defsubr (&Smake_list
);
2313 defsubr (&Smake_vector
);
2314 defsubr (&Smake_string
);
2315 defsubr (&Smake_symbol
);
2316 defsubr (&Smake_marker
);
2317 defsubr (&Spurecopy
);
2318 defsubr (&Sgarbage_collect
);
2319 defsubr (&Smemory_limit
);