1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1992, 1993 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. */
23 #include "intervals.h"
31 #include "syssignal.h"
33 #define max(A,B) ((A) > (B) ? (A) : (B))
35 /* Macro to verify that storage intended for Lisp objects is not
36 out of range to fit in the space for a pointer.
37 ADDRESS is the start of the block, and SIZE
38 is the amount of space within which objects can start. */
39 #define VALIDATE_LISP_STORAGE(address, size) \
43 XSET (val, Lisp_Cons, (char *) address + size); \
44 if ((char *) XCONS (val) != (char *) address + size) \
51 /* Number of bytes of consing done since the last gc */
54 /* Number of bytes of consing since gc before another gc should be done. */
55 int gc_cons_threshold
;
57 /* Nonzero during gc */
60 #ifndef VIRT_ADDR_VARIES
62 #endif /* VIRT_ADDR_VARIES */
65 #ifndef VIRT_ADDR_VARIES
67 #endif /* VIRT_ADDR_VARIES */
68 int malloc_sbrk_unused
;
70 /* Two limits controlling how much undo information to keep. */
72 int undo_strong_limit
;
74 /* Non-nil means defun should do purecopy on the function definition */
75 Lisp_Object Vpurify_flag
;
78 int pure
[PURESIZE
/ sizeof (int)] = {0,}; /* Force it into data space! */
79 #define PUREBEG (char *) pure
81 #define pure PURE_SEG_BITS /* Use shared memory segment */
82 #define PUREBEG (char *)PURE_SEG_BITS
84 /* This variable is used only by the XPNTR macro when HAVE_SHM is
85 defined. If we used the PURESIZE macro directly there, that would
86 make most of emacs dependent on puresize.h, which we don't want -
87 you should be able to change that without too much recompilation.
88 So map_in_data initializes pure_size, and the dependencies work
91 #endif /* not HAVE_SHM */
93 /* Index in pure at which next pure object will be allocated. */
96 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
97 char *pending_malloc_warning
;
99 /* Maximum amount of C stack to save when a GC happens. */
101 #ifndef MAX_SAVE_STACK
102 #define MAX_SAVE_STACK 16000
105 /* Buffer in which we save a copy of the C stack at each GC. */
110 /* Non-zero means ignore malloc warnings. Set during initialization. */
113 static void mark_object (), mark_buffer ();
114 static void clear_marks (), gc_sweep ();
115 static void compact_strings ();
118 malloc_warning_1 (str
)
121 Fprinc (str
, Vstandard_output
);
122 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
123 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
124 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
128 /* malloc calls this if it finds we are near exhausting storage */
132 pending_malloc_warning
= str
;
135 display_malloc_warning ()
137 register Lisp_Object val
;
139 val
= build_string (pending_malloc_warning
);
140 pending_malloc_warning
= 0;
141 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
144 /* Called if malloc returns zero */
147 error ("Memory exhausted");
150 /* like malloc and realloc but check for no memory left */
158 val
= (long *) malloc (size
);
160 if (!val
&& size
) memory_full ();
165 xrealloc (block
, size
)
171 /* We must call malloc explicitly when BLOCK is 0, since some
172 reallocs don't do this. */
174 val
= (long *) malloc (size
);
176 val
= (long *) realloc (block
, size
);
178 if (!val
&& size
) memory_full ();
182 #ifdef USE_TEXT_PROPERTIES
183 #define INTERVAL_BLOCK_SIZE \
184 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
186 struct interval_block
188 struct interval_block
*next
;
189 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
192 struct interval_block
*interval_block
;
193 static int interval_block_index
;
195 INTERVAL interval_free_list
;
201 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
202 interval_block
->next
= 0;
203 bzero (interval_block
->intervals
, sizeof interval_block
->intervals
);
204 interval_block_index
= 0;
205 interval_free_list
= 0;
208 #define INIT_INTERVALS init_intervals ()
215 if (interval_free_list
)
217 val
= interval_free_list
;
218 interval_free_list
= interval_free_list
->parent
;
222 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
224 register struct interval_block
*newi
225 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
230 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
231 newi
->next
= interval_block
;
232 interval_block
= newi
;
233 interval_block_index
= 0;
235 val
= &interval_block
->intervals
[interval_block_index
++];
237 consing_since_gc
+= sizeof (struct interval
);
238 RESET_INTERVAL (val
);
242 static int total_free_intervals
, total_intervals
;
244 /* Mark the pointers of one interval. */
250 if (XMARKBIT (i
->plist
))
252 mark_object (&i
->plist
);
257 mark_interval_tree (tree
)
258 register INTERVAL tree
;
260 if (XMARKBIT (tree
->plist
))
263 traverse_intervals (tree
, 1, 0, &mark_interval
);
266 #define MARK_INTERVAL_TREE(i) \
267 { if (!NULL_INTERVAL_P (i)) mark_interval_tree (i); }
269 #define UNMARK_BALANCE_INTERVALS(i) \
271 if (! NULL_INTERVAL_P (i)) \
273 XUNMARK ((Lisp_Object) (i->parent)); \
274 i = balance_intervals (i); \
278 #else /* no interval use */
280 #define INIT_INTERVALS
282 #define UNMARK_BALANCE_INTERVALS(i)
283 #define MARK_INTERVAL_TREE(i)
285 #endif /* no interval use */
287 #ifdef LISP_FLOAT_TYPE
288 /* Allocation of float cells, just like conses */
289 /* We store float cells inside of float_blocks, allocating a new
290 float_block with malloc whenever necessary. Float cells reclaimed by
291 GC are put on a free list to be reallocated before allocating
292 any new float cells from the latest float_block.
294 Each float_block is just under 1020 bytes long,
295 since malloc really allocates in units of powers of two
296 and uses 4 bytes for its own overhead. */
298 #define FLOAT_BLOCK_SIZE \
299 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
303 struct float_block
*next
;
304 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
307 struct float_block
*float_block
;
308 int float_block_index
;
310 struct Lisp_Float
*float_free_list
;
315 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
316 float_block
->next
= 0;
317 bzero (float_block
->floats
, sizeof float_block
->floats
);
318 float_block_index
= 0;
322 /* Explicitly free a float cell. */
324 struct Lisp_Float
*ptr
;
326 XFASTINT (ptr
->type
) = (int) float_free_list
;
327 float_free_list
= ptr
;
331 make_float (float_value
)
334 register Lisp_Object val
;
338 XSET (val
, Lisp_Float
, float_free_list
);
339 float_free_list
= (struct Lisp_Float
*) XFASTINT (float_free_list
->type
);
343 if (float_block_index
== FLOAT_BLOCK_SIZE
)
345 register struct float_block
*new = (struct float_block
*) malloc (sizeof (struct float_block
));
346 if (!new) memory_full ();
347 VALIDATE_LISP_STORAGE (new, sizeof *new);
348 new->next
= float_block
;
350 float_block_index
= 0;
352 XSET (val
, Lisp_Float
, &float_block
->floats
[float_block_index
++]);
354 XFLOAT (val
)->data
= float_value
;
355 XFLOAT (val
)->type
= 0; /* bug chasing -wsr */
356 consing_since_gc
+= sizeof (struct Lisp_Float
);
360 #endif /* LISP_FLOAT_TYPE */
362 /* Allocation of cons cells */
363 /* We store cons cells inside of cons_blocks, allocating a new
364 cons_block with malloc whenever necessary. Cons cells reclaimed by
365 GC are put on a free list to be reallocated before allocating
366 any new cons cells from the latest cons_block.
368 Each cons_block is just under 1020 bytes long,
369 since malloc really allocates in units of powers of two
370 and uses 4 bytes for its own overhead. */
372 #define CONS_BLOCK_SIZE \
373 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
377 struct cons_block
*next
;
378 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
381 struct cons_block
*cons_block
;
382 int cons_block_index
;
384 struct Lisp_Cons
*cons_free_list
;
389 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
390 cons_block
->next
= 0;
391 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
392 cons_block_index
= 0;
396 /* Explicitly free a cons cell. */
398 struct Lisp_Cons
*ptr
;
400 XFASTINT (ptr
->car
) = (int) cons_free_list
;
401 cons_free_list
= ptr
;
404 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
405 "Create a new cons, give it CAR and CDR as components, and return it.")
407 Lisp_Object car
, cdr
;
409 register Lisp_Object val
;
413 XSET (val
, Lisp_Cons
, cons_free_list
);
414 cons_free_list
= (struct Lisp_Cons
*) XFASTINT (cons_free_list
->car
);
418 if (cons_block_index
== CONS_BLOCK_SIZE
)
420 register struct cons_block
*new = (struct cons_block
*) malloc (sizeof (struct cons_block
));
421 if (!new) memory_full ();
422 VALIDATE_LISP_STORAGE (new, sizeof *new);
423 new->next
= cons_block
;
425 cons_block_index
= 0;
427 XSET (val
, Lisp_Cons
, &cons_block
->conses
[cons_block_index
++]);
429 XCONS (val
)->car
= car
;
430 XCONS (val
)->cdr
= cdr
;
431 consing_since_gc
+= sizeof (struct Lisp_Cons
);
435 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
436 "Return a newly created list with specified arguments as elements.\n\
437 Any number of arguments, even zero arguments, are allowed.")
440 register Lisp_Object
*args
;
442 register Lisp_Object len
, val
, val_tail
;
444 XFASTINT (len
) = nargs
;
445 val
= Fmake_list (len
, Qnil
);
447 while (!NILP (val_tail
))
449 XCONS (val_tail
)->car
= *args
++;
450 val_tail
= XCONS (val_tail
)->cdr
;
455 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
456 "Return a newly created list of length LENGTH, with each element being INIT.")
458 register Lisp_Object length
, init
;
460 register Lisp_Object val
;
463 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
464 length
= wrong_type_argument (Qnatnump
, length
);
465 size
= XINT (length
);
469 val
= Fcons (init
, val
);
473 /* Allocation of vectors */
475 struct Lisp_Vector
*all_vectors
;
477 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
478 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
479 See also the function `vector'.")
481 register Lisp_Object length
, init
;
483 register int sizei
, index
;
484 register Lisp_Object vector
;
485 register struct Lisp_Vector
*p
;
487 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
488 length
= wrong_type_argument (Qnatnump
, length
);
489 sizei
= XINT (length
);
491 p
= (struct Lisp_Vector
*) malloc (sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
));
494 VALIDATE_LISP_STORAGE (p
, 0);
496 XSET (vector
, Lisp_Vector
, p
);
497 consing_since_gc
+= sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
);
500 p
->next
= all_vectors
;
503 for (index
= 0; index
< sizei
; index
++)
504 p
->contents
[index
] = init
;
509 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
510 "Return a newly created vector with specified arguments as elements.\n\
511 Any number of arguments, even zero arguments, are allowed.")
516 register Lisp_Object len
, val
;
518 register struct Lisp_Vector
*p
;
520 XFASTINT (len
) = nargs
;
521 val
= Fmake_vector (len
, Qnil
);
523 for (index
= 0; index
< nargs
; index
++)
524 p
->contents
[index
] = args
[index
];
528 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
529 "Create a byte-code object with specified arguments as elements.\n\
530 The arguments should be the arglist, bytecode-string, constant vector,\n\
531 stack size, (optional) doc string, and (optional) interactive spec.\n\
532 The first four arguments are required; at most six have any\n\
538 register Lisp_Object len
, val
;
540 register struct Lisp_Vector
*p
;
542 XFASTINT (len
) = nargs
;
543 if (!NILP (Vpurify_flag
))
544 val
= make_pure_vector (len
);
546 val
= Fmake_vector (len
, Qnil
);
548 for (index
= 0; index
< nargs
; index
++)
550 if (!NILP (Vpurify_flag
))
551 args
[index
] = Fpurecopy (args
[index
]);
552 p
->contents
[index
] = args
[index
];
554 XSETTYPE (val
, Lisp_Compiled
);
558 /* Allocation of symbols.
559 Just like allocation of conses!
561 Each symbol_block is just under 1020 bytes long,
562 since malloc really allocates in units of powers of two
563 and uses 4 bytes for its own overhead. */
565 #define SYMBOL_BLOCK_SIZE \
566 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
570 struct symbol_block
*next
;
571 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
574 struct symbol_block
*symbol_block
;
575 int symbol_block_index
;
577 struct Lisp_Symbol
*symbol_free_list
;
582 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
583 symbol_block
->next
= 0;
584 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
585 symbol_block_index
= 0;
586 symbol_free_list
= 0;
589 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
590 "Return a newly allocated uninterned symbol whose name is NAME.\n\
591 Its value and function definition are void, and its property list is nil.")
595 register Lisp_Object val
;
596 register struct Lisp_Symbol
*p
;
598 CHECK_STRING (str
, 0);
600 if (symbol_free_list
)
602 XSET (val
, Lisp_Symbol
, symbol_free_list
);
604 = (struct Lisp_Symbol
*) XFASTINT (symbol_free_list
->value
);
608 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
610 struct symbol_block
*new = (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
611 if (!new) memory_full ();
612 VALIDATE_LISP_STORAGE (new, sizeof *new);
613 new->next
= symbol_block
;
615 symbol_block_index
= 0;
617 XSET (val
, Lisp_Symbol
, &symbol_block
->symbols
[symbol_block_index
++]);
620 p
->name
= XSTRING (str
);
623 p
->function
= Qunbound
;
625 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
629 /* Allocation of markers.
630 Works like allocation of conses. */
632 #define MARKER_BLOCK_SIZE \
633 ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker))
637 struct marker_block
*next
;
638 struct Lisp_Marker markers
[MARKER_BLOCK_SIZE
];
641 struct marker_block
*marker_block
;
642 int marker_block_index
;
644 struct Lisp_Marker
*marker_free_list
;
649 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
650 marker_block
->next
= 0;
651 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
652 marker_block_index
= 0;
653 marker_free_list
= 0;
656 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
657 "Return a newly allocated marker which does not point at any place.")
660 register Lisp_Object val
;
661 register struct Lisp_Marker
*p
;
663 if (marker_free_list
)
665 XSET (val
, Lisp_Marker
, marker_free_list
);
667 = (struct Lisp_Marker
*) XFASTINT (marker_free_list
->chain
);
671 if (marker_block_index
== MARKER_BLOCK_SIZE
)
673 struct marker_block
*new = (struct marker_block
*) malloc (sizeof (struct marker_block
));
674 if (!new) memory_full ();
675 VALIDATE_LISP_STORAGE (new, sizeof *new);
676 new->next
= marker_block
;
678 marker_block_index
= 0;
680 XSET (val
, Lisp_Marker
, &marker_block
->markers
[marker_block_index
++]);
686 consing_since_gc
+= sizeof (struct Lisp_Marker
);
690 /* Allocation of strings */
692 /* Strings reside inside of string_blocks. The entire data of the string,
693 both the size and the contents, live in part of the `chars' component of a string_block.
694 The `pos' component is the index within `chars' of the first free byte.
696 first_string_block points to the first string_block ever allocated.
697 Each block points to the next one with its `next' field.
698 The `prev' fields chain in reverse order.
699 The last one allocated is the one currently being filled.
700 current_string_block points to it.
702 The string_blocks that hold individual large strings
703 go in a separate chain, started by large_string_blocks. */
706 /* String blocks contain this many useful bytes.
707 8188 is power of 2, minus 4 for malloc overhead. */
708 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
710 /* A string bigger than this gets its own specially-made string block
711 if it doesn't fit in the current one. */
712 #define STRING_BLOCK_OUTSIZE 1024
714 struct string_block_head
716 struct string_block
*next
, *prev
;
722 struct string_block
*next
, *prev
;
724 char chars
[STRING_BLOCK_SIZE
];
727 /* This points to the string block we are now allocating strings. */
729 struct string_block
*current_string_block
;
731 /* This points to the oldest string block, the one that starts the chain. */
733 struct string_block
*first_string_block
;
735 /* Last string block in chain of those made for individual large strings. */
737 struct string_block
*large_string_blocks
;
739 /* If SIZE is the length of a string, this returns how many bytes
740 the string occupies in a string_block (including padding). */
742 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
744 #define PAD (sizeof (int))
747 #define STRING_FULLSIZE(SIZE) \
748 (((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1))
754 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
755 first_string_block
= current_string_block
;
756 consing_since_gc
+= sizeof (struct string_block
);
757 current_string_block
->next
= 0;
758 current_string_block
->prev
= 0;
759 current_string_block
->pos
= 0;
760 large_string_blocks
= 0;
763 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
764 "Return a newly created string of length LENGTH, with each element being INIT.\n\
765 Both LENGTH and INIT must be numbers.")
767 Lisp_Object length
, init
;
769 register Lisp_Object val
;
770 register unsigned char *p
, *end
, c
;
772 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
773 length
= wrong_type_argument (Qnatnump
, length
);
774 CHECK_NUMBER (init
, 1);
775 val
= make_uninit_string (XINT (length
));
777 p
= XSTRING (val
)->data
;
778 end
= p
+ XSTRING (val
)->size
;
786 make_string (contents
, length
)
790 register Lisp_Object val
;
791 val
= make_uninit_string (length
);
792 bcopy (contents
, XSTRING (val
)->data
, length
);
800 return make_string (str
, strlen (str
));
804 make_uninit_string (length
)
807 register Lisp_Object val
;
808 register int fullsize
= STRING_FULLSIZE (length
);
810 if (length
< 0) abort ();
812 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
813 /* This string can fit in the current string block */
815 XSET (val
, Lisp_String
,
816 (struct Lisp_String
*) (current_string_block
->chars
+ current_string_block
->pos
));
817 current_string_block
->pos
+= fullsize
;
819 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
820 /* This string gets its own string block */
822 register struct string_block
*new
823 = (struct string_block
*) malloc (sizeof (struct string_block_head
) + fullsize
);
824 VALIDATE_LISP_STORAGE (new, 0);
825 if (!new) memory_full ();
826 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
828 new->next
= large_string_blocks
;
829 large_string_blocks
= new;
830 XSET (val
, Lisp_String
,
831 (struct Lisp_String
*) ((struct string_block_head
*)new + 1));
834 /* Make a new current string block and start it off with this string */
836 register struct string_block
*new
837 = (struct string_block
*) malloc (sizeof (struct string_block
));
838 if (!new) memory_full ();
839 VALIDATE_LISP_STORAGE (new, sizeof *new);
840 consing_since_gc
+= sizeof (struct string_block
);
841 current_string_block
->next
= new;
842 new->prev
= current_string_block
;
844 current_string_block
= new;
846 XSET (val
, Lisp_String
,
847 (struct Lisp_String
*) current_string_block
->chars
);
850 XSTRING (val
)->size
= length
;
851 XSTRING (val
)->data
[length
] = 0;
852 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
857 /* Return a newly created vector or string with specified arguments as
858 elements. If all the arguments are characters, make a string;
859 otherwise, make a vector. Any number of arguments, even zero
860 arguments, are allowed. */
863 make_array (nargs
, args
)
869 for (i
= 0; i
< nargs
; i
++)
870 if (XTYPE (args
[i
]) != Lisp_Int
871 || (unsigned) XINT (args
[i
]) >= 0400)
872 return Fvector (nargs
, args
);
874 /* Since the loop exited, we know that all the things in it are
875 characters, so we can make a string. */
877 Lisp_Object result
= Fmake_string (nargs
, make_number (0));
879 for (i
= 0; i
< nargs
; i
++)
880 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
886 /* Note: the user cannot manipulate ropes portably by referring
887 to the chars of the string, because combining two chars to make a GLYPH
888 depends on endianness. */
890 DEFUN ("make-rope", Fmake_rope
, Smake_rope
, 0, MANY
, 0,
891 "Return a newly created rope containing the arguments of this function.\n\
892 A rope is a string, except that its contents will be treated as an\n\
893 array of glyphs, where a glyph is an integer type that may be larger\n\
894 than a character. Emacs is normally configured to use 8-bit glyphs,\n\
895 so ropes are normally no different from strings. But Emacs may be\n\
896 configured to use 16-bit glyphs, to allow the use of larger fonts.\n\
898 Each argument (which must be an integer) specifies one glyph, whatever\n\
899 size glyphs may be.\n\
901 See variable `buffer-display-table' for the uses of ropes.")
907 register Lisp_Object val
;
910 val
= make_uninit_string (nargs
* sizeof (GLYPH
));
912 p
= (GLYPH
*) XSTRING (val
)->data
;
913 for (i
= 0; i
< nargs
; i
++)
915 CHECK_NUMBER (args
[i
], i
);
916 p
[i
] = XFASTINT (args
[i
]);
921 DEFUN ("rope-elt", Frope_elt
, Srope_elt
, 2, 2, 0,
922 "Return an element of rope R at index N.\n\
923 A rope is a string in which each pair of bytes is considered an element.\n\
924 See variable `buffer-display-table' for the uses of ropes.")
930 if ((XSTRING (r
)->size
/ sizeof (GLYPH
)) <= XINT (n
) || XINT (n
) < 0)
931 args_out_of_range (r
, n
);
932 return ((GLYPH
*) XSTRING (r
)->data
)[XFASTINT (n
)];
935 /* Must get an error if pure storage is full,
936 since if it cannot hold a large string
937 it may be able to hold conses that point to that string;
938 then the string is not protected from gc. */
941 make_pure_string (data
, length
)
945 register Lisp_Object
new;
946 register int size
= sizeof (int) + INTERVAL_PTR_SIZE
+ length
+ 1;
948 if (pureptr
+ size
> PURESIZE
)
949 error ("Pure Lisp storage exhausted");
950 XSET (new, Lisp_String
, PUREBEG
+ pureptr
);
951 XSTRING (new)->size
= length
;
952 bcopy (data
, XSTRING (new)->data
, length
);
953 XSTRING (new)->data
[length
] = 0;
954 pureptr
+= (size
+ sizeof (int) - 1)
955 / sizeof (int) * sizeof (int);
961 Lisp_Object car
, cdr
;
963 register Lisp_Object
new;
965 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
966 error ("Pure Lisp storage exhausted");
967 XSET (new, Lisp_Cons
, PUREBEG
+ pureptr
);
968 pureptr
+= sizeof (struct Lisp_Cons
);
969 XCONS (new)->car
= Fpurecopy (car
);
970 XCONS (new)->cdr
= Fpurecopy (cdr
);
974 #ifdef LISP_FLOAT_TYPE
977 make_pure_float (num
)
980 register Lisp_Object
new;
982 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
983 error ("Pure Lisp storage exhausted");
984 XSET (new, Lisp_Float
, PUREBEG
+ pureptr
);
985 pureptr
+= sizeof (struct Lisp_Float
);
986 XFLOAT (new)->data
= num
;
987 XFLOAT (new)->type
= 0; /* bug chasing -wsr */
991 #endif /* LISP_FLOAT_TYPE */
994 make_pure_vector (len
)
997 register Lisp_Object
new;
998 register int size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1000 if (pureptr
+ size
> PURESIZE
)
1001 error ("Pure Lisp storage exhausted");
1003 XSET (new, Lisp_Vector
, PUREBEG
+ pureptr
);
1005 XVECTOR (new)->size
= len
;
1009 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1010 "Make a copy of OBJECT in pure storage.\n\
1011 Recursively copies contents of vectors and cons cells.\n\
1012 Does not copy symbols.")
1014 register Lisp_Object obj
;
1016 register Lisp_Object
new, tem
;
1019 if (NILP (Vpurify_flag
))
1022 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1023 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1026 #ifdef SWITCH_ENUM_BUG
1027 switch ((int) XTYPE (obj
))
1029 switch (XTYPE (obj
))
1033 error ("Attempt to copy a marker to pure storage");
1036 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1038 #ifdef LISP_FLOAT_TYPE
1040 return make_pure_float (XFLOAT (obj
)->data
);
1041 #endif /* LISP_FLOAT_TYPE */
1044 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1048 new = make_pure_vector (XVECTOR (obj
)->size
);
1049 for (i
= 0; i
< XVECTOR (obj
)->size
; i
++)
1051 tem
= XVECTOR (obj
)->contents
[i
];
1052 XVECTOR (new)->contents
[i
] = Fpurecopy (tem
);
1054 XSETTYPE (new, XTYPE (obj
));
1062 /* Recording what needs to be marked for gc. */
1064 struct gcpro
*gcprolist
;
1066 #define NSTATICS 512
1068 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1072 /* Put an entry in staticvec, pointing at the variable whose address is given */
1075 staticpro (varaddress
)
1076 Lisp_Object
*varaddress
;
1078 staticvec
[staticidx
++] = varaddress
;
1079 if (staticidx
>= NSTATICS
)
1087 struct catchtag
*next
;
1088 /* jmp_buf jmp; /* We don't need this for GC purposes */
1093 struct backtrace
*next
;
1094 Lisp_Object
*function
;
1095 Lisp_Object
*args
; /* Points to vector of args. */
1096 int nargs
; /* length of vector */
1097 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1101 /* Two flags that are set during GC in the `size' component
1102 of a string or vector. On some machines, these flags
1103 are defined by the m- file to be different bits. */
1105 /* On vector, means it has been marked.
1106 On string size field or a reference to a string,
1107 means not the last reference in the chain. */
1109 #ifndef ARRAY_MARK_FLAG
1110 #define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
1111 #endif /* no ARRAY_MARK_FLAG */
1113 /* Any slot that is a Lisp_Object can point to a string
1114 and thus can be put on a string's reference-chain
1115 and thus may need to have its ARRAY_MARK_FLAG set.
1116 This includes the slots whose markbits are used to mark
1117 the containing objects. */
1119 #if ARRAY_MARK_FLAG == MARKBIT
1123 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1124 int total_free_conses
, total_free_markers
, total_free_symbols
;
1125 #ifdef LISP_FLOAT_TYPE
1126 int total_free_floats
, total_floats
;
1127 #endif /* LISP_FLOAT_TYPE */
1129 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1130 "Reclaim storage for Lisp objects no longer needed.\n\
1131 Returns info on amount of space in use:\n\
1132 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1133 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1134 (USED-FLOATS . FREE-FLOATS))\n\
1135 Garbage collection happens automatically if you cons more than\n\
1136 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1139 register struct gcpro
*tail
;
1140 register struct specbinding
*bind
;
1141 struct catchtag
*catch;
1142 struct handler
*handler
;
1143 register struct backtrace
*backlist
;
1144 register Lisp_Object tem
;
1145 char *omessage
= echo_area_glyphs
;
1146 char stack_top_variable
;
1149 /* Save a copy of the contents of the stack, for debugging. */
1150 #if MAX_SAVE_STACK > 0
1151 if (NILP (Vpurify_flag
))
1153 i
= &stack_top_variable
- stack_bottom
;
1155 if (i
< MAX_SAVE_STACK
)
1157 if (stack_copy
== 0)
1158 stack_copy
= (char *) malloc (stack_copy_size
= i
);
1159 else if (stack_copy_size
< i
)
1160 stack_copy
= (char *) realloc (stack_copy
, (stack_copy_size
= i
));
1163 if ((int) (&stack_top_variable
- stack_bottom
) > 0)
1164 bcopy (stack_bottom
, stack_copy
, i
);
1166 bcopy (&stack_top_variable
, stack_copy
, i
);
1170 #endif /* MAX_SAVE_STACK > 0 */
1172 if (!noninteractive
)
1173 message1 ("Garbage collecting...");
1175 /* Don't keep command history around forever */
1176 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1178 XCONS (tem
)->cdr
= Qnil
;
1180 /* Likewise for undo information. */
1182 register struct buffer
*nextb
= all_buffers
;
1186 /* If a buffer's undo list is Qt, that means that undo is
1187 turned off in that buffer. Calling truncate_undo_list on
1188 Qt tends to return NULL, which effectively turns undo back on.
1189 So don't call truncate_undo_list if undo_list is Qt. */
1190 if (! EQ (nextb
->undo_list
, Qt
))
1192 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1194 nextb
= nextb
->next
;
1200 /* clear_marks (); */
1202 /* In each "large string", set the MARKBIT of the size field.
1203 That enables mark_object to recognize them. */
1205 register struct string_block
*b
;
1206 for (b
= large_string_blocks
; b
; b
= b
->next
)
1207 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1210 /* Mark all the special slots that serve as the roots of accessibility.
1212 Usually the special slots to mark are contained in particular structures.
1213 Then we know no slot is marked twice because the structures don't overlap.
1214 In some cases, the structures point to the slots to be marked.
1215 For these, we use MARKBIT to avoid double marking of the slot. */
1217 for (i
= 0; i
< staticidx
; i
++)
1218 mark_object (staticvec
[i
]);
1219 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1220 for (i
= 0; i
< tail
->nvars
; i
++)
1221 if (!XMARKBIT (tail
->var
[i
]))
1223 mark_object (&tail
->var
[i
]);
1224 XMARK (tail
->var
[i
]);
1226 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1228 mark_object (&bind
->symbol
);
1229 mark_object (&bind
->old_value
);
1231 for (catch = catchlist
; catch; catch = catch->next
)
1233 mark_object (&catch->tag
);
1234 mark_object (&catch->val
);
1236 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1238 mark_object (&handler
->handler
);
1239 mark_object (&handler
->var
);
1241 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1243 if (!XMARKBIT (*backlist
->function
))
1245 mark_object (backlist
->function
);
1246 XMARK (*backlist
->function
);
1248 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1251 i
= backlist
->nargs
- 1;
1253 if (!XMARKBIT (backlist
->args
[i
]))
1255 mark_object (&backlist
->args
[i
]);
1256 XMARK (backlist
->args
[i
]);
1262 /* Clear the mark bits that we set in certain root slots. */
1264 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1265 for (i
= 0; i
< tail
->nvars
; i
++)
1266 XUNMARK (tail
->var
[i
]);
1267 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1269 XUNMARK (*backlist
->function
);
1270 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1273 i
= backlist
->nargs
- 1;
1275 XUNMARK (backlist
->args
[i
]);
1277 XUNMARK (buffer_defaults
.name
);
1278 XUNMARK (buffer_local_symbols
.name
);
1280 /* clear_marks (); */
1283 consing_since_gc
= 0;
1284 if (gc_cons_threshold
< 10000)
1285 gc_cons_threshold
= 10000;
1288 message1 (omessage
);
1289 else if (!noninteractive
)
1290 message1 ("Garbage collecting...done");
1292 return Fcons (Fcons (make_number (total_conses
),
1293 make_number (total_free_conses
)),
1294 Fcons (Fcons (make_number (total_symbols
),
1295 make_number (total_free_symbols
)),
1296 Fcons (Fcons (make_number (total_markers
),
1297 make_number (total_free_markers
)),
1298 Fcons (make_number (total_string_size
),
1299 Fcons (make_number (total_vector_size
),
1301 #ifdef LISP_FLOAT_TYPE
1302 Fcons (Fcons (make_number (total_floats
),
1303 make_number (total_free_floats
)),
1305 #else /* not LISP_FLOAT_TYPE */
1307 #endif /* not LISP_FLOAT_TYPE */
1315 /* Clear marks on all conses */
1317 register struct cons_block
*cblk
;
1318 register int lim
= cons_block_index
;
1320 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1323 for (i
= 0; i
< lim
; i
++)
1324 XUNMARK (cblk
->conses
[i
].car
);
1325 lim
= CONS_BLOCK_SIZE
;
1328 /* Clear marks on all symbols */
1330 register struct symbol_block
*sblk
;
1331 register int lim
= symbol_block_index
;
1333 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1336 for (i
= 0; i
< lim
; i
++)
1338 XUNMARK (sblk
->symbols
[i
].plist
);
1340 lim
= SYMBOL_BLOCK_SIZE
;
1343 /* Clear marks on all markers */
1345 register struct marker_block
*sblk
;
1346 register int lim
= marker_block_index
;
1348 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1351 for (i
= 0; i
< lim
; i
++)
1352 XUNMARK (sblk
->markers
[i
].chain
);
1353 lim
= MARKER_BLOCK_SIZE
;
1356 /* Clear mark bits on all buffers */
1358 register struct buffer
*nextb
= all_buffers
;
1362 XUNMARK (nextb
->name
);
1363 nextb
= nextb
->next
;
1369 /* Mark reference to a Lisp_Object. If the object referred to
1370 has not been seen yet, recursively mark all the references contained in it.
1372 If the object referenced is a short string, the referrencing slot
1373 is threaded into a chain of such slots, pointed to from
1374 the `size' field of the string. The actual string size
1375 lives in the last slot in the chain. We recognize the end
1376 because it is < (unsigned) STRING_BLOCK_SIZE. */
1378 #define LAST_MARKED_SIZE 500
1379 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1380 int last_marked_index
;
1383 mark_object (objptr
)
1384 Lisp_Object
*objptr
;
1386 register Lisp_Object obj
;
1393 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1394 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1397 last_marked
[last_marked_index
++] = objptr
;
1398 if (last_marked_index
== LAST_MARKED_SIZE
)
1399 last_marked_index
= 0;
1401 #ifdef SWITCH_ENUM_BUG
1402 switch ((int) XGCTYPE (obj
))
1404 switch (XGCTYPE (obj
))
1409 register struct Lisp_String
*ptr
= XSTRING (obj
);
1411 MARK_INTERVAL_TREE (ptr
->intervals
);
1412 if (ptr
->size
& MARKBIT
)
1413 /* A large string. Just set ARRAY_MARK_FLAG. */
1414 ptr
->size
|= ARRAY_MARK_FLAG
;
1417 /* A small string. Put this reference
1418 into the chain of references to it.
1419 The address OBJPTR is even, so if the address
1420 includes MARKBIT, put it in the low bit
1421 when we store OBJPTR into the size field. */
1423 if (XMARKBIT (*objptr
))
1425 XFASTINT (*objptr
) = ptr
->size
;
1429 XFASTINT (*objptr
) = ptr
->size
;
1430 if ((int)objptr
& 1) abort ();
1431 ptr
->size
= (int) objptr
& ~MARKBIT
;
1432 if ((int) objptr
& MARKBIT
)
1441 case Lisp_Window_Configuration
:
1443 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1444 register int size
= ptr
->size
;
1445 struct Lisp_Vector
*volatile ptr1
= ptr
;
1448 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1449 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1450 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1454 mark_object (&ptr
->contents
[i
]);
1460 /* We could treat this just like a vector, but it is better
1461 to save the COMPILED_CONSTANTS element for last and avoid recursion
1464 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1465 register int size
= ptr
->size
;
1466 struct Lisp_Vector
*volatile ptr1
= ptr
;
1469 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1470 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1471 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1475 if (i
!= COMPILED_CONSTANTS
)
1476 mark_object (&ptr
->contents
[i
]);
1478 objptr
= &ptr
->contents
[COMPILED_CONSTANTS
];
1486 register struct frame
*ptr
= XFRAME (obj
);
1487 register int size
= ptr
->size
;
1490 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1491 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1493 mark_object (&ptr
->name
);
1494 mark_object (&ptr
->focus_frame
);
1495 mark_object (&ptr
->width
);
1496 mark_object (&ptr
->height
);
1497 mark_object (&ptr
->selected_window
);
1498 mark_object (&ptr
->minibuffer_window
);
1499 mark_object (&ptr
->param_alist
);
1500 mark_object (&ptr
->scrollbars
);
1501 mark_object (&ptr
->condemned_scrollbars
);
1504 #endif /* not MULTI_FRAME */
1508 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
1509 struct Lisp_Symbol
*ptrx
;
1511 if (XMARKBIT (ptr
->plist
)) break;
1513 mark_object ((Lisp_Object
*) &ptr
->value
);
1514 mark_object (&ptr
->function
);
1515 mark_object (&ptr
->plist
);
1516 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1517 mark_object (&ptr
->name
);
1521 ptrx
= ptr
; /* Use pf ptrx avoids compiler bug on Sun */
1522 XSETSYMBOL (obj
, ptrx
);
1529 XMARK (XMARKER (obj
)->chain
);
1530 /* DO NOT mark thru the marker's chain.
1531 The buffer's markers chain does not preserve markers from gc;
1532 instead, markers are removed from the chain when freed by gc. */
1536 case Lisp_Buffer_Local_Value
:
1537 case Lisp_Some_Buffer_Local_Value
:
1539 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1540 if (XMARKBIT (ptr
->car
)) break;
1542 /* If the cdr is nil, avoid recursion for the car. */
1543 if (EQ (ptr
->cdr
, Qnil
))
1550 mark_object (&ptr
->car
);
1556 #ifdef LISP_FLOAT_TYPE
1558 XMARK (XFLOAT (obj
)->type
);
1560 #endif /* LISP_FLOAT_TYPE */
1563 if (!XMARKBIT (XBUFFER (obj
)->name
))
1573 case Lisp_Buffer_Objfwd
:
1574 case Lisp_Internal_Stream
:
1575 /* Don't bother with Lisp_Buffer_Objfwd,
1576 since all markable slots in current buffer marked anyway. */
1577 /* Don't need to do Lisp_Objfwd, since the places they point
1578 are protected with staticpro. */
1586 /* Mark the pointers in a buffer structure. */
1593 register struct buffer
*buffer
= XBUFFER (buf
);
1594 register Lisp_Object
*ptr
;
1596 /* This is the buffer's markbit */
1597 mark_object (&buffer
->name
);
1598 XMARK (buffer
->name
);
1600 MARK_INTERVAL_TREE (buffer
->intervals
);
1603 mark_object (buffer
->syntax_table
);
1605 /* Mark the various string-pointers in the buffer object.
1606 Since the strings may be relocated, we must mark them
1607 in their actual slots. So gc_sweep must convert each slot
1608 back to an ordinary C pointer. */
1609 XSET (*(Lisp_Object
*)&buffer
->upcase_table
,
1610 Lisp_String
, buffer
->upcase_table
);
1611 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1612 XSET (*(Lisp_Object
*)&buffer
->downcase_table
,
1613 Lisp_String
, buffer
->downcase_table
);
1614 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1616 XSET (*(Lisp_Object
*)&buffer
->sort_table
,
1617 Lisp_String
, buffer
->sort_table
);
1618 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1619 XSET (*(Lisp_Object
*)&buffer
->folding_sort_table
,
1620 Lisp_String
, buffer
->folding_sort_table
);
1621 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1624 for (ptr
= &buffer
->name
+ 1;
1625 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1630 /* Find all structures not marked, and free them. */
1635 total_string_size
= 0;
1638 /* Put all unmarked conses on free list */
1640 register struct cons_block
*cblk
;
1641 register int lim
= cons_block_index
;
1642 register int num_free
= 0, num_used
= 0;
1646 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1649 for (i
= 0; i
< lim
; i
++)
1650 if (!XMARKBIT (cblk
->conses
[i
].car
))
1652 XFASTINT (cblk
->conses
[i
].car
) = (int) cons_free_list
;
1654 cons_free_list
= &cblk
->conses
[i
];
1659 XUNMARK (cblk
->conses
[i
].car
);
1661 lim
= CONS_BLOCK_SIZE
;
1663 total_conses
= num_used
;
1664 total_free_conses
= num_free
;
1667 #ifdef LISP_FLOAT_TYPE
1668 /* Put all unmarked floats on free list */
1670 register struct float_block
*fblk
;
1671 register int lim
= float_block_index
;
1672 register int num_free
= 0, num_used
= 0;
1674 float_free_list
= 0;
1676 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1679 for (i
= 0; i
< lim
; i
++)
1680 if (!XMARKBIT (fblk
->floats
[i
].type
))
1682 XFASTINT (fblk
->floats
[i
].type
) = (int) float_free_list
;
1684 float_free_list
= &fblk
->floats
[i
];
1689 XUNMARK (fblk
->floats
[i
].type
);
1691 lim
= FLOAT_BLOCK_SIZE
;
1693 total_floats
= num_used
;
1694 total_free_floats
= num_free
;
1696 #endif /* LISP_FLOAT_TYPE */
1698 #ifdef USE_TEXT_PROPERTIES
1699 /* Put all unmarked intervals on free list */
1701 register struct interval_block
*iblk
;
1702 register int lim
= interval_block_index
;
1703 register int num_free
= 0, num_used
= 0;
1705 interval_free_list
= 0;
1707 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1711 for (i
= 0; i
< lim
; i
++)
1713 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1715 iblk
->intervals
[i
].parent
= interval_free_list
;
1716 interval_free_list
= &iblk
->intervals
[i
];
1722 XUNMARK (iblk
->intervals
[i
].plist
);
1725 lim
= INTERVAL_BLOCK_SIZE
;
1727 total_intervals
= num_used
;
1728 total_free_intervals
= num_free
;
1730 #endif /* USE_TEXT_PROPERTIES */
1732 /* Put all unmarked symbols on free list */
1734 register struct symbol_block
*sblk
;
1735 register int lim
= symbol_block_index
;
1736 register int num_free
= 0, num_used
= 0;
1738 symbol_free_list
= 0;
1740 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1743 for (i
= 0; i
< lim
; i
++)
1744 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1746 XFASTINT (sblk
->symbols
[i
].value
) = (int) symbol_free_list
;
1747 symbol_free_list
= &sblk
->symbols
[i
];
1753 sblk
->symbols
[i
].name
1754 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1755 XUNMARK (sblk
->symbols
[i
].plist
);
1757 lim
= SYMBOL_BLOCK_SIZE
;
1759 total_symbols
= num_used
;
1760 total_free_symbols
= num_free
;
1764 /* Put all unmarked markers on free list.
1765 Dechain each one first from the buffer it points into. */
1767 register struct marker_block
*mblk
;
1768 struct Lisp_Marker
*tem1
;
1769 register int lim
= marker_block_index
;
1770 register int num_free
= 0, num_used
= 0;
1772 marker_free_list
= 0;
1774 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1777 for (i
= 0; i
< lim
; i
++)
1778 if (!XMARKBIT (mblk
->markers
[i
].chain
))
1781 tem1
= &mblk
->markers
[i
]; /* tem1 avoids Sun compiler bug */
1782 XSET (tem
, Lisp_Marker
, tem1
);
1783 unchain_marker (tem
);
1784 XFASTINT (mblk
->markers
[i
].chain
) = (int) marker_free_list
;
1785 marker_free_list
= &mblk
->markers
[i
];
1791 XUNMARK (mblk
->markers
[i
].chain
);
1793 lim
= MARKER_BLOCK_SIZE
;
1796 total_markers
= num_used
;
1797 total_free_markers
= num_free
;
1800 /* Free all unmarked buffers */
1802 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1805 if (!XMARKBIT (buffer
->name
))
1808 prev
->next
= buffer
->next
;
1810 all_buffers
= buffer
->next
;
1811 next
= buffer
->next
;
1817 XUNMARK (buffer
->name
);
1818 UNMARK_BALANCE_INTERVALS (buffer
->intervals
);
1821 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1822 for purposes of marking and relocation.
1823 Turn them back into C pointers now. */
1824 buffer
->upcase_table
1825 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
1826 buffer
->downcase_table
1827 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
1829 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
1830 buffer
->folding_sort_table
1831 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
1834 prev
= buffer
, buffer
= buffer
->next
;
1838 #endif /* standalone */
1840 /* Free all unmarked vectors */
1842 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
1843 total_vector_size
= 0;
1846 if (!(vector
->size
& ARRAY_MARK_FLAG
))
1849 prev
->next
= vector
->next
;
1851 all_vectors
= vector
->next
;
1852 next
= vector
->next
;
1858 vector
->size
&= ~ARRAY_MARK_FLAG
;
1859 total_vector_size
+= vector
->size
;
1860 prev
= vector
, vector
= vector
->next
;
1864 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
1866 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
1869 if (!(((struct Lisp_String
*)(&sb
->chars
[0]))->size
& ARRAY_MARK_FLAG
))
1872 prev
->next
= sb
->next
;
1874 large_string_blocks
= sb
->next
;
1881 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
1882 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
1883 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
1884 prev
= sb
, sb
= sb
->next
;
1889 /* Compactify strings, relocate references to them, and
1890 free any string blocks that become empty. */
1895 /* String block of old strings we are scanning. */
1896 register struct string_block
*from_sb
;
1897 /* A preceding string block (or maybe the same one)
1898 where we are copying the still-live strings to. */
1899 register struct string_block
*to_sb
;
1903 to_sb
= first_string_block
;
1906 /* Scan each existing string block sequentially, string by string. */
1907 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
1910 /* POS is the index of the next string in the block. */
1911 while (pos
< from_sb
->pos
)
1913 register struct Lisp_String
*nextstr
1914 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
1916 register struct Lisp_String
*newaddr
;
1917 register int size
= nextstr
->size
;
1919 /* NEXTSTR is the old address of the next string.
1920 Just skip it if it isn't marked. */
1921 if ((unsigned) size
> STRING_BLOCK_SIZE
)
1923 /* It is marked, so its size field is really a chain of refs.
1924 Find the end of the chain, where the actual size lives. */
1925 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1927 if (size
& 1) size
^= MARKBIT
| 1;
1928 size
= *(int *)size
& ~MARKBIT
;
1931 total_string_size
+= size
;
1933 /* If it won't fit in TO_SB, close it out,
1934 and move to the next sb. Keep doing so until
1935 TO_SB reaches a large enough, empty enough string block.
1936 We know that TO_SB cannot advance past FROM_SB here
1937 since FROM_SB is large enough to contain this string.
1938 Any string blocks skipped here
1939 will be patched out and freed later. */
1940 while (to_pos
+ STRING_FULLSIZE (size
)
1941 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
1943 to_sb
->pos
= to_pos
;
1944 to_sb
= to_sb
->next
;
1947 /* Compute new address of this string
1948 and update TO_POS for the space being used. */
1949 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
1950 to_pos
+= STRING_FULLSIZE (size
);
1952 /* Copy the string itself to the new place. */
1953 if (nextstr
!= newaddr
)
1954 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (int)
1955 + INTERVAL_PTR_SIZE
);
1957 /* Go through NEXTSTR's chain of references
1958 and make each slot in the chain point to
1959 the new address of this string. */
1960 size
= newaddr
->size
;
1961 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1963 register Lisp_Object
*objptr
;
1964 if (size
& 1) size
^= MARKBIT
| 1;
1965 objptr
= (Lisp_Object
*)size
;
1967 size
= XFASTINT (*objptr
) & ~MARKBIT
;
1968 if (XMARKBIT (*objptr
))
1970 XSET (*objptr
, Lisp_String
, newaddr
);
1974 XSET (*objptr
, Lisp_String
, newaddr
);
1976 /* Store the actual size in the size field. */
1977 newaddr
->size
= size
;
1979 pos
+= STRING_FULLSIZE (size
);
1983 /* Close out the last string block still used and free any that follow. */
1984 to_sb
->pos
= to_pos
;
1985 current_string_block
= to_sb
;
1987 from_sb
= to_sb
->next
;
1991 to_sb
= from_sb
->next
;
1996 /* Free any empty string blocks further back in the chain.
1997 This loop will never free first_string_block, but it is very
1998 unlikely that that one will become empty, so why bother checking? */
2000 from_sb
= first_string_block
;
2001 while (to_sb
= from_sb
->next
)
2003 if (to_sb
->pos
== 0)
2005 if (from_sb
->next
= to_sb
->next
)
2006 from_sb
->next
->prev
= from_sb
;
2014 /* Debugging aids. */
2016 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, "",
2017 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2018 This may be helpful in debugging Emacs's memory usage.\n\
2019 The value is divided by 1024 to make sure it will fit in a lisp integer.")
2024 XSET (end
, Lisp_Int
, (int) sbrk (0) / 1024);
2030 /* Initialization */
2034 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2037 pure_size
= PURESIZE
;
2040 ignore_warnings
= 1;
2045 #ifdef LISP_FLOAT_TYPE
2047 #endif /* LISP_FLOAT_TYPE */
2050 ignore_warnings
= 0;
2053 consing_since_gc
= 0;
2054 gc_cons_threshold
= 100000;
2055 #ifdef VIRT_ADDR_VARIES
2056 malloc_sbrk_unused
= 1<<22; /* A large number */
2057 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2058 #endif /* VIRT_ADDR_VARIES */
2069 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2070 "*Number of bytes of consing between garbage collections.\n\
2071 Garbage collection can happen automatically once this many bytes have been\n\
2072 allocated since the last garbage collection. All data types count.\n\n\
2073 Garbage collection happens automatically only when `eval' is called.\n\n\
2074 By binding this temporarily to a large number, you can effectively\n\
2075 prevent garbage collection during a part of the program.");
2077 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2078 "Number of bytes of sharable Lisp data allocated so far.");
2081 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2082 "Number of bytes of unshared memory allocated in this session.");
2084 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2085 "Number of bytes of unshared memory remaining available in this session.");
2088 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2089 "Non-nil means loading Lisp code in order to dump an executable.\n\
2090 This means that certain objects should be allocated in shared (pure) space.");
2092 DEFVAR_INT ("undo-limit", &undo_limit
,
2093 "Keep no more undo information once it exceeds this size.\n\
2094 This limit is applied when garbage collection happens.\n\
2095 The size is counted as the number of bytes occupied,\n\
2096 which includes both saved text and other data.");
2099 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2100 "Don't keep more than this much size of undo information.\n\
2101 A command which pushes past this size is itself forgotten.\n\
2102 This limit is applied when garbage collection happens.\n\
2103 The size is counted as the number of bytes occupied,\n\
2104 which includes both saved text and other data.");
2105 undo_strong_limit
= 30000;
2110 defsubr (&Smake_byte_code
);
2111 defsubr (&Smake_list
);
2112 defsubr (&Smake_vector
);
2113 defsubr (&Smake_string
);
2114 defsubr (&Smake_rope
);
2115 defsubr (&Srope_elt
);
2116 defsubr (&Smake_symbol
);
2117 defsubr (&Smake_marker
);
2118 defsubr (&Spurecopy
);
2119 defsubr (&Sgarbage_collect
);
2120 defsubr (&Smemory_limit
);