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 else if (GC_SUBRP (obj
))
1530 else if (GC_COMPILEDP (obj
))
1531 /* We could treat this just like a vector, but it is better
1532 to save the COMPILED_CONSTANTS element for last and avoid recursion
1535 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1536 register EMACS_INT size
= ptr
->size
;
1537 /* See comment above under Lisp_Vector. */
1538 struct Lisp_Vector
*volatile ptr1
= ptr
;
1541 if (size
& ARRAY_MARK_FLAG
)
1542 break; /* Already marked */
1543 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1544 size
&= PSEUDOVECTOR_SIZE_MASK
;
1545 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1547 if (i
!= COMPILED_CONSTANTS
)
1548 mark_object (&ptr1
->contents
[i
]);
1550 /* This cast should be unnecessary, but some Mips compiler complains
1551 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1552 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1556 else if (GC_FRAMEP (obj
))
1558 /* See comment above under Lisp_Vector for why this is volatile. */
1559 register struct frame
*volatile ptr
= XFRAME (obj
);
1560 register EMACS_INT size
= ptr
->size
;
1562 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1563 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1565 mark_object (&ptr
->name
);
1566 mark_object (&ptr
->focus_frame
);
1567 mark_object (&ptr
->selected_window
);
1568 mark_object (&ptr
->minibuffer_window
);
1569 mark_object (&ptr
->param_alist
);
1570 mark_object (&ptr
->scroll_bars
);
1571 mark_object (&ptr
->condemned_scroll_bars
);
1572 mark_object (&ptr
->menu_bar_items
);
1573 mark_object (&ptr
->face_alist
);
1574 mark_object (&ptr
->menu_bar_vector
);
1575 mark_object (&ptr
->buffer_predicate
);
1578 #endif /* MULTI_FRAME */
1580 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1581 register EMACS_INT size
= ptr
->size
;
1582 /* The reason we use ptr1 is to avoid an apparent hardware bug
1583 that happens occasionally on the FSF's HP 300s.
1584 The bug is that a2 gets clobbered by recursive calls to mark_object.
1585 The clobberage seems to happen during function entry,
1586 perhaps in the moveml instruction.
1587 Yes, this is a crock, but we have to do it. */
1588 struct Lisp_Vector
*volatile ptr1
= ptr
;
1591 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1592 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1593 if (size
& PSEUDOVECTOR_FLAG
)
1594 size
&= PSEUDOVECTOR_SIZE_MASK
;
1595 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1596 mark_object (&ptr1
->contents
[i
]);
1602 /* See comment above under Lisp_Vector for why this is volatile. */
1603 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1604 struct Lisp_Symbol
*ptrx
;
1606 if (XMARKBIT (ptr
->plist
)) break;
1608 mark_object ((Lisp_Object
*) &ptr
->value
);
1609 mark_object (&ptr
->function
);
1610 mark_object (&ptr
->plist
);
1611 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1612 mark_object (&ptr
->name
);
1616 /* For the benefit of the last_marked log. */
1617 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1618 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1619 XSETSYMBOL (obj
, ptrx
);
1620 /* We can't goto loop here because *objptr doesn't contain an
1621 actual Lisp_Object with valid datatype field. */
1628 switch (XMISC (obj
)->type
)
1630 case Lisp_Misc_Marker
:
1631 XMARK (XMARKER (obj
)->chain
);
1632 /* DO NOT mark thru the marker's chain.
1633 The buffer's markers chain does not preserve markers from gc;
1634 instead, markers are removed from the chain when freed by gc. */
1637 case Lisp_Misc_Buffer_Local_Value
:
1638 case Lisp_Misc_Some_Buffer_Local_Value
:
1640 register struct Lisp_Buffer_Local_Value
*ptr
1641 = XBUFFER_LOCAL_VALUE (obj
);
1642 if (XMARKBIT (ptr
->car
)) break;
1644 /* If the cdr is nil, avoid recursion for the car. */
1645 if (EQ (ptr
->cdr
, Qnil
))
1650 mark_object (&ptr
->car
);
1651 /* See comment above under Lisp_Vector for why not use ptr here. */
1652 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
1656 case Lisp_Misc_Intfwd
:
1657 case Lisp_Misc_Boolfwd
:
1658 case Lisp_Misc_Objfwd
:
1659 case Lisp_Misc_Buffer_Objfwd
:
1660 /* Don't bother with Lisp_Buffer_Objfwd,
1661 since all markable slots in current buffer marked anyway. */
1662 /* Don't need to do Lisp_Objfwd, since the places they point
1663 are protected with staticpro. */
1666 case Lisp_Misc_Overlay
:
1668 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
1669 if (!XMARKBIT (ptr
->plist
))
1672 mark_object (&ptr
->start
);
1673 mark_object (&ptr
->end
);
1674 objptr
= &ptr
->plist
;
1687 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1688 if (XMARKBIT (ptr
->car
)) break;
1690 /* If the cdr is nil, avoid recursion for the car. */
1691 if (EQ (ptr
->cdr
, Qnil
))
1696 mark_object (&ptr
->car
);
1697 /* See comment above under Lisp_Vector for why not use ptr here. */
1698 objptr
= &XCONS (obj
)->cdr
;
1702 #ifdef LISP_FLOAT_TYPE
1704 XMARK (XFLOAT (obj
)->type
);
1706 #endif /* LISP_FLOAT_TYPE */
1716 /* Mark the pointers in a buffer structure. */
1722 register struct buffer
*buffer
= XBUFFER (buf
);
1723 register Lisp_Object
*ptr
;
1724 Lisp_Object base_buffer
;
1726 /* This is the buffer's markbit */
1727 mark_object (&buffer
->name
);
1728 XMARK (buffer
->name
);
1730 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
1733 mark_object (buffer
->syntax_table
);
1735 /* Mark the various string-pointers in the buffer object.
1736 Since the strings may be relocated, we must mark them
1737 in their actual slots. So gc_sweep must convert each slot
1738 back to an ordinary C pointer. */
1739 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
1740 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1741 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
1742 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1744 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
1745 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1746 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
1747 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1750 for (ptr
= &buffer
->name
+ 1;
1751 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1755 /* If this is an indirect buffer, mark its base buffer. */
1756 if (buffer
->base_buffer
)
1758 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
1759 mark_buffer (base_buffer
);
1763 /* Sweep: find all structures not marked, and free them. */
1768 total_string_size
= 0;
1771 /* Put all unmarked conses on free list */
1773 register struct cons_block
*cblk
;
1774 register int lim
= cons_block_index
;
1775 register int num_free
= 0, num_used
= 0;
1779 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1782 for (i
= 0; i
< lim
; i
++)
1783 if (!XMARKBIT (cblk
->conses
[i
].car
))
1786 *(struct Lisp_Cons
**)&cblk
->conses
[i
].car
= cons_free_list
;
1787 cons_free_list
= &cblk
->conses
[i
];
1792 XUNMARK (cblk
->conses
[i
].car
);
1794 lim
= CONS_BLOCK_SIZE
;
1796 total_conses
= num_used
;
1797 total_free_conses
= num_free
;
1800 #ifdef LISP_FLOAT_TYPE
1801 /* Put all unmarked floats on free list */
1803 register struct float_block
*fblk
;
1804 register int lim
= float_block_index
;
1805 register int num_free
= 0, num_used
= 0;
1807 float_free_list
= 0;
1809 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1812 for (i
= 0; i
< lim
; i
++)
1813 if (!XMARKBIT (fblk
->floats
[i
].type
))
1816 *(struct Lisp_Float
**)&fblk
->floats
[i
].type
= float_free_list
;
1817 float_free_list
= &fblk
->floats
[i
];
1822 XUNMARK (fblk
->floats
[i
].type
);
1824 lim
= FLOAT_BLOCK_SIZE
;
1826 total_floats
= num_used
;
1827 total_free_floats
= num_free
;
1829 #endif /* LISP_FLOAT_TYPE */
1831 #ifdef USE_TEXT_PROPERTIES
1832 /* Put all unmarked intervals on free list */
1834 register struct interval_block
*iblk
;
1835 register int lim
= interval_block_index
;
1836 register int num_free
= 0, num_used
= 0;
1838 interval_free_list
= 0;
1840 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1844 for (i
= 0; i
< lim
; i
++)
1846 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1848 iblk
->intervals
[i
].parent
= interval_free_list
;
1849 interval_free_list
= &iblk
->intervals
[i
];
1855 XUNMARK (iblk
->intervals
[i
].plist
);
1858 lim
= INTERVAL_BLOCK_SIZE
;
1860 total_intervals
= num_used
;
1861 total_free_intervals
= num_free
;
1863 #endif /* USE_TEXT_PROPERTIES */
1865 /* Put all unmarked symbols on free list */
1867 register struct symbol_block
*sblk
;
1868 register int lim
= symbol_block_index
;
1869 register int num_free
= 0, num_used
= 0;
1871 symbol_free_list
= 0;
1873 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1876 for (i
= 0; i
< lim
; i
++)
1877 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1879 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
1880 symbol_free_list
= &sblk
->symbols
[i
];
1886 sblk
->symbols
[i
].name
1887 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1888 XUNMARK (sblk
->symbols
[i
].plist
);
1890 lim
= SYMBOL_BLOCK_SIZE
;
1892 total_symbols
= num_used
;
1893 total_free_symbols
= num_free
;
1897 /* Put all unmarked markers on free list.
1898 Dechain each one first from the buffer it points into,
1899 but only if it's a real marker. */
1901 register struct marker_block
*mblk
;
1902 register int lim
= marker_block_index
;
1903 register int num_free
= 0, num_used
= 0;
1905 marker_free_list
= 0;
1907 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1910 for (i
= 0; i
< lim
; i
++)
1912 Lisp_Object
*markword
;
1913 switch (mblk
->markers
[i
].type
)
1915 case Lisp_Misc_Marker
:
1916 markword
= &mblk
->markers
[i
].u_marker
.chain
;
1918 case Lisp_Misc_Buffer_Local_Value
:
1919 case Lisp_Misc_Some_Buffer_Local_Value
:
1920 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
1922 case Lisp_Misc_Overlay
:
1923 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
1929 if (markword
&& !XMARKBIT (*markword
))
1932 if (mblk
->markers
[i
].type
== Lisp_Misc_Marker
)
1934 /* tem1 avoids Sun compiler bug */
1935 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
1936 XSETMARKER (tem
, tem1
);
1937 unchain_marker (tem
);
1939 /* We could leave the type alone, since nobody checks it,
1940 but this might catch bugs faster. */
1941 mblk
->markers
[i
].type
= Lisp_Misc_Free
;
1942 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
1943 marker_free_list
= &mblk
->markers
[i
];
1950 XUNMARK (*markword
);
1953 lim
= MARKER_BLOCK_SIZE
;
1956 total_markers
= num_used
;
1957 total_free_markers
= num_free
;
1960 /* Free all unmarked buffers */
1962 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1965 if (!XMARKBIT (buffer
->name
))
1968 prev
->next
= buffer
->next
;
1970 all_buffers
= buffer
->next
;
1971 next
= buffer
->next
;
1977 XUNMARK (buffer
->name
);
1978 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
1981 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1982 for purposes of marking and relocation.
1983 Turn them back into C pointers now. */
1984 buffer
->upcase_table
1985 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
1986 buffer
->downcase_table
1987 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
1989 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
1990 buffer
->folding_sort_table
1991 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
1994 prev
= buffer
, buffer
= buffer
->next
;
1998 #endif /* standalone */
2000 /* Free all unmarked vectors */
2002 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2003 total_vector_size
= 0;
2006 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2009 prev
->next
= vector
->next
;
2011 all_vectors
= vector
->next
;
2012 next
= vector
->next
;
2018 vector
->size
&= ~ARRAY_MARK_FLAG
;
2019 total_vector_size
+= vector
->size
;
2020 prev
= vector
, vector
= vector
->next
;
2024 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2026 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2027 struct Lisp_String
*s
;
2031 s
= (struct Lisp_String
*) &sb
->chars
[0];
2032 if (s
->size
& ARRAY_MARK_FLAG
)
2034 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2035 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2036 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2037 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2038 prev
= sb
, sb
= sb
->next
;
2043 prev
->next
= sb
->next
;
2045 large_string_blocks
= sb
->next
;
2054 /* Compactify strings, relocate references, and free empty string blocks. */
2059 /* String block of old strings we are scanning. */
2060 register struct string_block
*from_sb
;
2061 /* A preceding string block (or maybe the same one)
2062 where we are copying the still-live strings to. */
2063 register struct string_block
*to_sb
;
2067 to_sb
= first_string_block
;
2070 /* Scan each existing string block sequentially, string by string. */
2071 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2074 /* POS is the index of the next string in the block. */
2075 while (pos
< from_sb
->pos
)
2077 register struct Lisp_String
*nextstr
2078 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2080 register struct Lisp_String
*newaddr
;
2081 register EMACS_INT size
= nextstr
->size
;
2083 /* NEXTSTR is the old address of the next string.
2084 Just skip it if it isn't marked. */
2085 if ((EMACS_UINT
) size
> STRING_BLOCK_SIZE
)
2087 /* It is marked, so its size field is really a chain of refs.
2088 Find the end of the chain, where the actual size lives. */
2089 while ((EMACS_UINT
) size
> STRING_BLOCK_SIZE
)
2091 if (size
& 1) size
^= MARKBIT
| 1;
2092 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2095 total_string_size
+= size
;
2097 /* If it won't fit in TO_SB, close it out,
2098 and move to the next sb. Keep doing so until
2099 TO_SB reaches a large enough, empty enough string block.
2100 We know that TO_SB cannot advance past FROM_SB here
2101 since FROM_SB is large enough to contain this string.
2102 Any string blocks skipped here
2103 will be patched out and freed later. */
2104 while (to_pos
+ STRING_FULLSIZE (size
)
2105 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2107 to_sb
->pos
= to_pos
;
2108 to_sb
= to_sb
->next
;
2111 /* Compute new address of this string
2112 and update TO_POS for the space being used. */
2113 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2114 to_pos
+= STRING_FULLSIZE (size
);
2116 /* Copy the string itself to the new place. */
2117 if (nextstr
!= newaddr
)
2118 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2119 + INTERVAL_PTR_SIZE
);
2121 /* Go through NEXTSTR's chain of references
2122 and make each slot in the chain point to
2123 the new address of this string. */
2124 size
= newaddr
->size
;
2125 while ((EMACS_UINT
) size
> STRING_BLOCK_SIZE
)
2127 register Lisp_Object
*objptr
;
2128 if (size
& 1) size
^= MARKBIT
| 1;
2129 objptr
= (Lisp_Object
*)size
;
2131 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2132 if (XMARKBIT (*objptr
))
2134 XSETSTRING (*objptr
, newaddr
);
2138 XSETSTRING (*objptr
, newaddr
);
2140 /* Store the actual size in the size field. */
2141 newaddr
->size
= size
;
2143 #ifdef USE_TEXT_PROPERTIES
2144 /* Now that the string has been relocated, rebalance its
2145 interval tree, and update the tree's parent pointer. */
2146 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2148 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2149 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2152 #endif /* USE_TEXT_PROPERTIES */
2154 pos
+= STRING_FULLSIZE (size
);
2158 /* Close out the last string block still used and free any that follow. */
2159 to_sb
->pos
= to_pos
;
2160 current_string_block
= to_sb
;
2162 from_sb
= to_sb
->next
;
2166 to_sb
= from_sb
->next
;
2171 /* Free any empty string blocks further back in the chain.
2172 This loop will never free first_string_block, but it is very
2173 unlikely that that one will become empty, so why bother checking? */
2175 from_sb
= first_string_block
;
2176 while (to_sb
= from_sb
->next
)
2178 if (to_sb
->pos
== 0)
2180 if (from_sb
->next
= to_sb
->next
)
2181 from_sb
->next
->prev
= from_sb
;
2189 /* Debugging aids. */
2191 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2192 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2193 This may be helpful in debugging Emacs's memory usage.\n\
2194 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2199 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2205 /* Initialization */
2209 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2212 pure_size
= PURESIZE
;
2215 ignore_warnings
= 1;
2220 #ifdef LISP_FLOAT_TYPE
2222 #endif /* LISP_FLOAT_TYPE */
2225 ignore_warnings
= 0;
2228 consing_since_gc
= 0;
2229 gc_cons_threshold
= 100000;
2230 #ifdef VIRT_ADDR_VARIES
2231 malloc_sbrk_unused
= 1<<22; /* A large number */
2232 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2233 #endif /* VIRT_ADDR_VARIES */
2244 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2245 "*Number of bytes of consing between garbage collections.\n\
2246 Garbage collection can happen automatically once this many bytes have been\n\
2247 allocated since the last garbage collection. All data types count.\n\n\
2248 Garbage collection happens automatically only when `eval' is called.\n\n\
2249 By binding this temporarily to a large number, you can effectively\n\
2250 prevent garbage collection during a part of the program.");
2252 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2253 "Number of bytes of sharable Lisp data allocated so far.");
2256 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2257 "Number of bytes of unshared memory allocated in this session.");
2259 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2260 "Number of bytes of unshared memory remaining available in this session.");
2263 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2264 "Non-nil means loading Lisp code in order to dump an executable.\n\
2265 This means that certain objects should be allocated in shared (pure) space.");
2267 DEFVAR_INT ("undo-limit", &undo_limit
,
2268 "Keep no more undo information once it exceeds this size.\n\
2269 This limit is applied when garbage collection happens.\n\
2270 The size is counted as the number of bytes occupied,\n\
2271 which includes both saved text and other data.");
2274 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2275 "Don't keep more than this much size of undo information.\n\
2276 A command which pushes past this size is itself forgotten.\n\
2277 This limit is applied when garbage collection happens.\n\
2278 The size is counted as the number of bytes occupied,\n\
2279 which includes both saved text and other data.");
2280 undo_strong_limit
= 30000;
2282 /* We build this in advance because if we wait until we need it, we might
2283 not be able to allocate the memory to hold it. */
2285 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted"), Qnil
));
2286 staticpro (&memory_signal_data
);
2291 defsubr (&Smake_byte_code
);
2292 defsubr (&Smake_list
);
2293 defsubr (&Smake_vector
);
2294 defsubr (&Smake_string
);
2295 defsubr (&Smake_symbol
);
2296 defsubr (&Smake_marker
);
2297 defsubr (&Spurecopy
);
2298 defsubr (&Sgarbage_collect
);
2299 defsubr (&Smemory_limit
);