1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1992 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 1, 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"
30 #endif /* MULTI_FRAME */
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 XSET (val, Lisp_Cons, (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 int pure
[PURESIZE
/ sizeof (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 /* Maximum amount of C stack to save when a GC happens. */
103 #ifndef MAX_SAVE_STACK
104 #define MAX_SAVE_STACK 16000
107 /* Buffer in which we save a copy of the C stack at each GC. */
112 /* Non-zero means ignore malloc warnings. Set during initialization. */
115 static void mark_object (), mark_buffer ();
116 static void clear_marks (), gc_sweep ();
117 static void compact_strings ();
120 malloc_warning_1 (str
)
123 Fprinc (str
, Vstandard_output
);
124 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
125 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
126 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
130 /* malloc calls this if it finds we are near exhausting storage */
134 pending_malloc_warning
= str
;
137 display_malloc_warning ()
139 register Lisp_Object val
;
141 val
= build_string (pending_malloc_warning
);
142 pending_malloc_warning
= 0;
143 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
146 /* Called if malloc returns zero */
149 error ("Memory exhausted");
152 /* like malloc and realloc but check for no memory left */
160 val
= (long *) malloc (size
);
162 if (!val
&& size
) memory_full ();
167 xrealloc (block
, size
)
173 /* We must call malloc explicitly when BLOCK is 0, since some
174 reallocs don't do this. */
176 val
= (long *) malloc (size
);
178 val
= (long *) realloc (block
, size
);
180 if (!val
&& size
) memory_full ();
184 #ifdef USE_TEXT_PROPERTIES
185 #define INTERVAL_BLOCK_SIZE \
186 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
188 struct interval_block
190 struct interval_block
*next
;
191 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
194 struct interval_block
*interval_block
;
195 static int interval_block_index
;
197 INTERVAL interval_free_list
;
203 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
204 interval_block
->next
= 0;
205 bzero (interval_block
->intervals
, sizeof interval_block
->intervals
);
206 interval_block_index
= 0;
207 interval_free_list
= 0;
210 #define INIT_INTERVALS init_intervals ()
217 if (interval_free_list
)
219 val
= interval_free_list
;
220 interval_free_list
= interval_free_list
->parent
;
224 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
226 register struct interval_block
*newi
227 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
232 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
233 newi
->next
= interval_block
;
234 interval_block
= newi
;
235 interval_block_index
= 0;
237 val
= &interval_block
->intervals
[interval_block_index
++];
239 consing_since_gc
+= sizeof (struct interval
);
240 RESET_INTERVAL (val
);
244 static int total_free_intervals
, total_intervals
;
246 /* Mark the pointers of one interval. */
252 if (XMARKBIT (i
->plist
))
254 mark_object (&i
->plist
);
259 mark_interval_tree (tree
)
260 register INTERVAL tree
;
262 if (XMARKBIT (tree
->plist
))
265 traverse_intervals (tree
, 1, &mark_interval
);
268 #define MARK_INTERVAL_TREE(i) \
269 { if (!NULL_INTERVAL_P (i)) mark_interval_tree (i); }
271 #define UNMARK_BALANCE_INTERVALS(i) \
273 if (! NULL_INTERVAL_P (i)) \
275 XUNMARK ((Lisp_Object) (i->parent)); \
276 i = balance_intervals (i); \
280 #else /* no interval use */
282 #define INIT_INTERVALS
284 #define UNMARK_BALANCE_INTERVALS(i)
285 #define MARK_INTERVAL_TREE(i)
287 #endif /* no interval use */
289 #ifdef LISP_FLOAT_TYPE
290 /* Allocation of float cells, just like conses */
291 /* We store float cells inside of float_blocks, allocating a new
292 float_block with malloc whenever necessary. Float cells reclaimed by
293 GC are put on a free list to be reallocated before allocating
294 any new float cells from the latest float_block.
296 Each float_block is just under 1020 bytes long,
297 since malloc really allocates in units of powers of two
298 and uses 4 bytes for its own overhead. */
300 #define FLOAT_BLOCK_SIZE \
301 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
305 struct float_block
*next
;
306 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
309 struct float_block
*float_block
;
310 int float_block_index
;
312 struct Lisp_Float
*float_free_list
;
317 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
318 float_block
->next
= 0;
319 bzero (float_block
->floats
, sizeof float_block
->floats
);
320 float_block_index
= 0;
324 /* Explicitly free a float cell. */
326 struct Lisp_Float
*ptr
;
328 XFASTINT (ptr
->type
) = (int) float_free_list
;
329 float_free_list
= ptr
;
333 make_float (float_value
)
336 register Lisp_Object val
;
340 XSET (val
, Lisp_Float
, float_free_list
);
341 float_free_list
= (struct Lisp_Float
*) XFASTINT (float_free_list
->type
);
345 if (float_block_index
== FLOAT_BLOCK_SIZE
)
347 register struct float_block
*new = (struct float_block
*) malloc (sizeof (struct float_block
));
348 if (!new) memory_full ();
349 VALIDATE_LISP_STORAGE (new, sizeof *new);
350 new->next
= float_block
;
352 float_block_index
= 0;
354 XSET (val
, Lisp_Float
, &float_block
->floats
[float_block_index
++]);
356 XFLOAT (val
)->data
= float_value
;
357 XFLOAT (val
)->type
= 0; /* bug chasing -wsr */
358 consing_since_gc
+= sizeof (struct Lisp_Float
);
362 #endif /* LISP_FLOAT_TYPE */
364 /* Allocation of cons cells */
365 /* We store cons cells inside of cons_blocks, allocating a new
366 cons_block with malloc whenever necessary. Cons cells reclaimed by
367 GC are put on a free list to be reallocated before allocating
368 any new cons cells from the latest cons_block.
370 Each cons_block is just under 1020 bytes long,
371 since malloc really allocates in units of powers of two
372 and uses 4 bytes for its own overhead. */
374 #define CONS_BLOCK_SIZE \
375 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
379 struct cons_block
*next
;
380 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
383 struct cons_block
*cons_block
;
384 int cons_block_index
;
386 struct Lisp_Cons
*cons_free_list
;
391 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
392 cons_block
->next
= 0;
393 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
394 cons_block_index
= 0;
398 /* Explicitly free a cons cell. */
400 struct Lisp_Cons
*ptr
;
402 XFASTINT (ptr
->car
) = (int) cons_free_list
;
403 cons_free_list
= ptr
;
406 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
407 "Create a new cons, give it CAR and CDR as components, and return it.")
409 Lisp_Object car
, cdr
;
411 register Lisp_Object val
;
415 XSET (val
, Lisp_Cons
, cons_free_list
);
416 cons_free_list
= (struct Lisp_Cons
*) XFASTINT (cons_free_list
->car
);
420 if (cons_block_index
== CONS_BLOCK_SIZE
)
422 register struct cons_block
*new = (struct cons_block
*) malloc (sizeof (struct cons_block
));
423 if (!new) memory_full ();
424 VALIDATE_LISP_STORAGE (new, sizeof *new);
425 new->next
= cons_block
;
427 cons_block_index
= 0;
429 XSET (val
, Lisp_Cons
, &cons_block
->conses
[cons_block_index
++]);
431 XCONS (val
)->car
= car
;
432 XCONS (val
)->cdr
= cdr
;
433 consing_since_gc
+= sizeof (struct Lisp_Cons
);
437 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
438 "Return a newly created list with specified arguments as elements.\n\
439 Any number of arguments, even zero arguments, are allowed.")
442 register Lisp_Object
*args
;
444 register Lisp_Object len
, val
, val_tail
;
446 XFASTINT (len
) = nargs
;
447 val
= Fmake_list (len
, Qnil
);
449 while (!NILP (val_tail
))
451 XCONS (val_tail
)->car
= *args
++;
452 val_tail
= XCONS (val_tail
)->cdr
;
457 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
458 "Return a newly created list of length LENGTH, with each element being INIT.")
460 register Lisp_Object length
, init
;
462 register Lisp_Object val
;
465 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
466 length
= wrong_type_argument (Qnatnump
, length
);
467 size
= XINT (length
);
471 val
= Fcons (init
, val
);
475 /* Allocation of vectors */
477 struct Lisp_Vector
*all_vectors
;
479 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
480 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
481 See also the function `vector'.")
483 register Lisp_Object length
, init
;
485 register int sizei
, index
;
486 register Lisp_Object vector
;
487 register struct Lisp_Vector
*p
;
489 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
490 length
= wrong_type_argument (Qnatnump
, length
);
491 sizei
= XINT (length
);
493 p
= (struct Lisp_Vector
*) malloc (sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
));
496 VALIDATE_LISP_STORAGE (p
, 0);
498 XSET (vector
, Lisp_Vector
, p
);
499 consing_since_gc
+= sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
);
502 p
->next
= all_vectors
;
505 for (index
= 0; index
< sizei
; index
++)
506 p
->contents
[index
] = init
;
511 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
512 "Return a newly created vector with specified arguments as elements.\n\
513 Any number of arguments, even zero arguments, are allowed.")
518 register Lisp_Object len
, val
;
520 register struct Lisp_Vector
*p
;
522 XFASTINT (len
) = nargs
;
523 val
= Fmake_vector (len
, Qnil
);
525 for (index
= 0; index
< nargs
; index
++)
526 p
->contents
[index
] = args
[index
];
530 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
531 "Create a byte-code object with specified arguments as elements.\n\
532 The arguments should be the arglist, bytecode-string, constant vector,\n\
533 stack size, (optional) doc string, and (optional) interactive spec.\n\
534 The first four arguments are required; at most six have any\n\
540 register Lisp_Object len
, val
;
542 register struct Lisp_Vector
*p
;
544 XFASTINT (len
) = nargs
;
545 if (!NILP (Vpurify_flag
))
546 val
= make_pure_vector (len
);
548 val
= Fmake_vector (len
, Qnil
);
550 for (index
= 0; index
< nargs
; index
++)
552 if (!NILP (Vpurify_flag
))
553 args
[index
] = Fpurecopy (args
[index
]);
554 p
->contents
[index
] = args
[index
];
556 XSETTYPE (val
, Lisp_Compiled
);
560 /* Allocation of symbols.
561 Just like allocation of conses!
563 Each symbol_block is just under 1020 bytes long,
564 since malloc really allocates in units of powers of two
565 and uses 4 bytes for its own overhead. */
567 #define SYMBOL_BLOCK_SIZE \
568 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
572 struct symbol_block
*next
;
573 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
576 struct symbol_block
*symbol_block
;
577 int symbol_block_index
;
579 struct Lisp_Symbol
*symbol_free_list
;
584 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
585 symbol_block
->next
= 0;
586 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
587 symbol_block_index
= 0;
588 symbol_free_list
= 0;
591 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
592 "Return a newly allocated uninterned symbol whose name is NAME.\n\
593 Its value and function definition are void, and its property list is nil.")
597 register Lisp_Object val
;
598 register struct Lisp_Symbol
*p
;
600 CHECK_STRING (str
, 0);
602 if (symbol_free_list
)
604 XSET (val
, Lisp_Symbol
, symbol_free_list
);
606 = (struct Lisp_Symbol
*) XFASTINT (symbol_free_list
->value
);
610 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
612 struct symbol_block
*new = (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
613 if (!new) memory_full ();
614 VALIDATE_LISP_STORAGE (new, sizeof *new);
615 new->next
= symbol_block
;
617 symbol_block_index
= 0;
619 XSET (val
, Lisp_Symbol
, &symbol_block
->symbols
[symbol_block_index
++]);
622 p
->name
= XSTRING (str
);
625 p
->function
= Qunbound
;
627 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
631 /* Allocation of markers.
632 Works like allocation of conses. */
634 #define MARKER_BLOCK_SIZE \
635 ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker))
639 struct marker_block
*next
;
640 struct Lisp_Marker markers
[MARKER_BLOCK_SIZE
];
643 struct marker_block
*marker_block
;
644 int marker_block_index
;
646 struct Lisp_Marker
*marker_free_list
;
651 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
652 marker_block
->next
= 0;
653 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
654 marker_block_index
= 0;
655 marker_free_list
= 0;
658 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
659 "Return a newly allocated marker which does not point at any place.")
662 register Lisp_Object val
;
663 register struct Lisp_Marker
*p
;
665 if (marker_free_list
)
667 XSET (val
, Lisp_Marker
, marker_free_list
);
669 = (struct Lisp_Marker
*) XFASTINT (marker_free_list
->chain
);
673 if (marker_block_index
== MARKER_BLOCK_SIZE
)
675 struct marker_block
*new = (struct marker_block
*) malloc (sizeof (struct marker_block
));
676 if (!new) memory_full ();
677 VALIDATE_LISP_STORAGE (new, sizeof *new);
678 new->next
= marker_block
;
680 marker_block_index
= 0;
682 XSET (val
, Lisp_Marker
, &marker_block
->markers
[marker_block_index
++]);
688 consing_since_gc
+= sizeof (struct Lisp_Marker
);
692 /* Allocation of strings */
694 /* Strings reside inside of string_blocks. The entire data of the string,
695 both the size and the contents, live in part of the `chars' component of a string_block.
696 The `pos' component is the index within `chars' of the first free byte.
698 first_string_block points to the first string_block ever allocated.
699 Each block points to the next one with its `next' field.
700 The `prev' fields chain in reverse order.
701 The last one allocated is the one currently being filled.
702 current_string_block points to it.
704 The string_blocks that hold individual large strings
705 go in a separate chain, started by large_string_blocks. */
708 /* String blocks contain this many useful bytes.
709 8188 is power of 2, minus 4 for malloc overhead. */
710 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
712 /* A string bigger than this gets its own specially-made string block
713 if it doesn't fit in the current one. */
714 #define STRING_BLOCK_OUTSIZE 1024
716 struct string_block_head
718 struct string_block
*next
, *prev
;
724 struct string_block
*next
, *prev
;
726 char chars
[STRING_BLOCK_SIZE
];
729 /* This points to the string block we are now allocating strings. */
731 struct string_block
*current_string_block
;
733 /* This points to the oldest string block, the one that starts the chain. */
735 struct string_block
*first_string_block
;
737 /* Last string block in chain of those made for individual large strings. */
739 struct string_block
*large_string_blocks
;
741 /* If SIZE is the length of a string, this returns how many bytes
742 the string occupies in a string_block (including padding). */
744 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
746 #define PAD (sizeof (int))
749 #define STRING_FULLSIZE(SIZE) \
750 (((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1))
756 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
757 first_string_block
= current_string_block
;
758 consing_since_gc
+= sizeof (struct string_block
);
759 current_string_block
->next
= 0;
760 current_string_block
->prev
= 0;
761 current_string_block
->pos
= 0;
762 large_string_blocks
= 0;
765 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
766 "Return a newly created string of length LENGTH, with each element being INIT.\n\
767 Both LENGTH and INIT must be numbers.")
769 Lisp_Object length
, init
;
771 register Lisp_Object val
;
772 register unsigned char *p
, *end
, c
;
774 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
775 length
= wrong_type_argument (Qnatnump
, length
);
776 CHECK_NUMBER (init
, 1);
777 val
= make_uninit_string (XINT (length
));
779 p
= XSTRING (val
)->data
;
780 end
= p
+ XSTRING (val
)->size
;
788 make_string (contents
, length
)
792 register Lisp_Object val
;
793 val
= make_uninit_string (length
);
794 bcopy (contents
, XSTRING (val
)->data
, length
);
802 return make_string (str
, strlen (str
));
806 make_uninit_string (length
)
809 register Lisp_Object val
;
810 register int fullsize
= STRING_FULLSIZE (length
);
812 if (length
< 0) abort ();
814 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
815 /* This string can fit in the current string block */
817 XSET (val
, Lisp_String
,
818 (struct Lisp_String
*) (current_string_block
->chars
+ current_string_block
->pos
));
819 current_string_block
->pos
+= fullsize
;
821 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
822 /* This string gets its own string block */
824 register struct string_block
*new
825 = (struct string_block
*) malloc (sizeof (struct string_block_head
) + fullsize
);
826 VALIDATE_LISP_STORAGE (new, 0);
827 if (!new) memory_full ();
828 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
830 new->next
= large_string_blocks
;
831 large_string_blocks
= new;
832 XSET (val
, Lisp_String
,
833 (struct Lisp_String
*) ((struct string_block_head
*)new + 1));
836 /* Make a new current string block and start it off with this string */
838 register struct string_block
*new
839 = (struct string_block
*) malloc (sizeof (struct string_block
));
840 if (!new) memory_full ();
841 VALIDATE_LISP_STORAGE (new, sizeof *new);
842 consing_since_gc
+= sizeof (struct string_block
);
843 current_string_block
->next
= new;
844 new->prev
= current_string_block
;
846 current_string_block
= new;
848 XSET (val
, Lisp_String
,
849 (struct Lisp_String
*) current_string_block
->chars
);
852 XSTRING (val
)->size
= length
;
853 XSTRING (val
)->data
[length
] = 0;
854 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
859 /* Return a newly created vector or string with specified arguments as
860 elements. If all the arguments are characters, make a string;
861 otherwise, make a vector. Any number of arguments, even zero
862 arguments, are allowed. */
865 make_array (nargs
, args
)
871 for (i
= 0; i
< nargs
; i
++)
872 if (XTYPE (args
[i
]) != Lisp_Int
873 || (unsigned) XINT (args
[i
]) >= 0400)
874 return Fvector (nargs
, args
);
876 /* Since the loop exited, we know that all the things in it are
877 characters, so we can make a string. */
879 Lisp_Object result
= Fmake_string (nargs
, make_number (0));
881 for (i
= 0; i
< nargs
; i
++)
882 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
888 /* Note: the user cannot manipulate ropes portably by referring
889 to the chars of the string, because combining two chars to make a GLYPH
890 depends on endianness. */
892 DEFUN ("make-rope", Fmake_rope
, Smake_rope
, 0, MANY
, 0,
893 "Return a newly created rope containing the arguments of this function.\n\
894 A rope is a string, except that its contents will be treated as an\n\
895 array of glyphs, where a glyph is an integer type that may be larger\n\
896 than a character. Emacs is normally configured to use 8-bit glyphs,\n\
897 so ropes are normally no different from strings. But Emacs may be\n\
898 configured to use 16-bit glyphs, to allow the use of larger fonts.\n\
900 Each argument (which must be an integer) specifies one glyph, whatever\n\
901 size glyphs may be.\n\
903 See variable `buffer-display-table' for the uses of ropes.")
909 register Lisp_Object val
;
912 val
= make_uninit_string (nargs
* sizeof (GLYPH
));
914 p
= (GLYPH
*) XSTRING (val
)->data
;
915 for (i
= 0; i
< nargs
; i
++)
917 CHECK_NUMBER (args
[i
], i
);
918 p
[i
] = XFASTINT (args
[i
]);
923 DEFUN ("rope-elt", Frope_elt
, Srope_elt
, 2, 2, 0,
924 "Return an element of rope R at index N.\n\
925 A rope is a string in which each pair of bytes is considered an element.\n\
926 See variable `buffer-display-table' for the uses of ropes.")
931 if ((XSTRING (r
)->size
/ sizeof (GLYPH
)) <= XINT (n
) || XINT (n
) < 0)
932 args_out_of_range (r
, n
);
933 return ((GLYPH
*) XSTRING (r
)->data
)[XFASTINT (n
)];
936 /* Must get an error if pure storage is full,
937 since if it cannot hold a large string
938 it may be able to hold conses that point to that string;
939 then the string is not protected from gc. */
942 make_pure_string (data
, length
)
946 register Lisp_Object
new;
947 register int size
= sizeof (int) + INTERVAL_PTR_SIZE
+ length
+ 1;
949 if (pureptr
+ size
> PURESIZE
)
950 error ("Pure Lisp storage exhausted");
951 XSET (new, Lisp_String
, PUREBEG
+ pureptr
);
952 XSTRING (new)->size
= length
;
953 bcopy (data
, XSTRING (new)->data
, length
);
954 XSTRING (new)->data
[length
] = 0;
955 pureptr
+= (size
+ sizeof (int) - 1)
956 / sizeof (int) * sizeof (int);
962 Lisp_Object car
, cdr
;
964 register Lisp_Object
new;
966 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
967 error ("Pure Lisp storage exhausted");
968 XSET (new, Lisp_Cons
, PUREBEG
+ pureptr
);
969 pureptr
+= sizeof (struct Lisp_Cons
);
970 XCONS (new)->car
= Fpurecopy (car
);
971 XCONS (new)->cdr
= Fpurecopy (cdr
);
975 #ifdef LISP_FLOAT_TYPE
978 make_pure_float (num
)
981 register Lisp_Object
new;
983 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
984 error ("Pure Lisp storage exhausted");
985 XSET (new, Lisp_Float
, PUREBEG
+ pureptr
);
986 pureptr
+= sizeof (struct Lisp_Float
);
987 XFLOAT (new)->data
= num
;
988 XFLOAT (new)->type
= 0; /* bug chasing -wsr */
992 #endif /* LISP_FLOAT_TYPE */
995 make_pure_vector (len
)
998 register Lisp_Object
new;
999 register int size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1001 if (pureptr
+ size
> PURESIZE
)
1002 error ("Pure Lisp storage exhausted");
1004 XSET (new, Lisp_Vector
, PUREBEG
+ pureptr
);
1006 XVECTOR (new)->size
= len
;
1010 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1011 "Make a copy of OBJECT in pure storage.\n\
1012 Recursively copies contents of vectors and cons cells.\n\
1013 Does not copy symbols.")
1015 register Lisp_Object obj
;
1017 register Lisp_Object
new, tem
;
1020 if (NILP (Vpurify_flag
))
1023 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1024 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1027 #ifdef SWITCH_ENUM_BUG
1028 switch ((int) XTYPE (obj
))
1030 switch (XTYPE (obj
))
1034 error ("Attempt to copy a marker to pure storage");
1037 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1039 #ifdef LISP_FLOAT_TYPE
1041 return make_pure_float (XFLOAT (obj
)->data
);
1042 #endif /* LISP_FLOAT_TYPE */
1045 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1049 new = make_pure_vector (XVECTOR (obj
)->size
);
1050 for (i
= 0; i
< XVECTOR (obj
)->size
; i
++)
1052 tem
= XVECTOR (obj
)->contents
[i
];
1053 XVECTOR (new)->contents
[i
] = Fpurecopy (tem
);
1055 XSETTYPE (new, XTYPE (obj
));
1063 /* Recording what needs to be marked for gc. */
1065 struct gcpro
*gcprolist
;
1067 #define NSTATICS 512
1069 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1073 /* Put an entry in staticvec, pointing at the variable whose address is given */
1076 staticpro (varaddress
)
1077 Lisp_Object
*varaddress
;
1079 staticvec
[staticidx
++] = varaddress
;
1080 if (staticidx
>= NSTATICS
)
1088 struct catchtag
*next
;
1089 /* jmp_buf jmp; /* We don't need this for GC purposes */
1094 struct backtrace
*next
;
1095 Lisp_Object
*function
;
1096 Lisp_Object
*args
; /* Points to vector of args. */
1097 int nargs
; /* length of vector */
1098 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1102 /* Two flags that are set during GC in the `size' component
1103 of a string or vector. On some machines, these flags
1104 are defined by the m- file to be different bits. */
1106 /* On vector, means it has been marked.
1107 On string size field or a reference to a string,
1108 means not the last reference in the chain. */
1110 #ifndef ARRAY_MARK_FLAG
1111 #define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
1112 #endif /* no ARRAY_MARK_FLAG */
1114 /* Any slot that is a Lisp_Object can point to a string
1115 and thus can be put on a string's reference-chain
1116 and thus may need to have its ARRAY_MARK_FLAG set.
1117 This includes the slots whose markbits are used to mark
1118 the containing objects. */
1120 #if ARRAY_MARK_FLAG == MARKBIT
1124 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1125 int total_free_conses
, total_free_markers
, total_free_symbols
;
1126 #ifdef LISP_FLOAT_TYPE
1127 int total_free_floats
, total_floats
;
1128 #endif /* LISP_FLOAT_TYPE */
1130 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1131 "Reclaim storage for Lisp objects no longer needed.\n\
1132 Returns info on amount of space in use:\n\
1133 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1134 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1135 (USED-FLOATS . FREE-FLOATS))\n\
1136 Garbage collection happens automatically if you cons more than\n\
1137 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1140 register struct gcpro
*tail
;
1141 register struct specbinding
*bind
;
1142 struct catchtag
*catch;
1143 struct handler
*handler
;
1144 register struct backtrace
*backlist
;
1145 register Lisp_Object tem
;
1146 char *omessage
= echo_area_glyphs
;
1147 char stack_top_variable
;
1150 /* Save a copy of the contents of the stack, for debugging. */
1151 #if MAX_SAVE_STACK > 0
1152 if (NILP (Vpurify_flag
))
1154 i
= &stack_top_variable
- stack_bottom
;
1156 if (i
< MAX_SAVE_STACK
)
1158 if (stack_copy
== 0)
1159 stack_copy
= (char *) malloc (stack_copy_size
= i
);
1160 else if (stack_copy_size
< i
)
1161 stack_copy
= (char *) realloc (stack_copy
, (stack_copy_size
= i
));
1164 if ((int) (&stack_top_variable
- stack_bottom
) > 0)
1165 bcopy (stack_bottom
, stack_copy
, i
);
1167 bcopy (&stack_top_variable
, stack_copy
, i
);
1171 #endif /* MAX_SAVE_STACK > 0 */
1173 if (!noninteractive
)
1174 message1 ("Garbage collecting...");
1176 /* Don't keep command history around forever */
1177 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1179 XCONS (tem
)->cdr
= Qnil
;
1181 /* Likewise for undo information. */
1183 register struct buffer
*nextb
= all_buffers
;
1187 /* If a buffer's undo list is Qt, that means that undo is
1188 turned off in that buffer. Calling truncate_undo_list on
1189 Qt tends to return NULL, which effectively turns undo back on.
1190 So don't call truncate_undo_list if undo_list is Qt. */
1191 if (! EQ (nextb
->undo_list
, Qt
))
1193 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1195 nextb
= nextb
->next
;
1201 /* clear_marks (); */
1203 /* In each "large string", set the MARKBIT of the size field.
1204 That enables mark_object to recognize them. */
1206 register struct string_block
*b
;
1207 for (b
= large_string_blocks
; b
; b
= b
->next
)
1208 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1211 /* Mark all the special slots that serve as the roots of accessibility.
1213 Usually the special slots to mark are contained in particular structures.
1214 Then we know no slot is marked twice because the structures don't overlap.
1215 In some cases, the structures point to the slots to be marked.
1216 For these, we use MARKBIT to avoid double marking of the slot. */
1218 for (i
= 0; i
< staticidx
; i
++)
1219 mark_object (staticvec
[i
]);
1220 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1221 for (i
= 0; i
< tail
->nvars
; i
++)
1222 if (!XMARKBIT (tail
->var
[i
]))
1224 mark_object (&tail
->var
[i
]);
1225 XMARK (tail
->var
[i
]);
1227 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1229 mark_object (&bind
->symbol
);
1230 mark_object (&bind
->old_value
);
1232 for (catch = catchlist
; catch; catch = catch->next
)
1234 mark_object (&catch->tag
);
1235 mark_object (&catch->val
);
1237 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1239 mark_object (&handler
->handler
);
1240 mark_object (&handler
->var
);
1242 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1244 if (!XMARKBIT (*backlist
->function
))
1246 mark_object (backlist
->function
);
1247 XMARK (*backlist
->function
);
1249 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1252 i
= backlist
->nargs
- 1;
1254 if (!XMARKBIT (backlist
->args
[i
]))
1256 mark_object (&backlist
->args
[i
]);
1257 XMARK (backlist
->args
[i
]);
1263 /* Clear the mark bits that we set in certain root slots. */
1265 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1266 for (i
= 0; i
< tail
->nvars
; i
++)
1267 XUNMARK (tail
->var
[i
]);
1268 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1270 XUNMARK (*backlist
->function
);
1271 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1274 i
= backlist
->nargs
- 1;
1276 XUNMARK (backlist
->args
[i
]);
1278 XUNMARK (buffer_defaults
.name
);
1279 XUNMARK (buffer_local_symbols
.name
);
1281 /* clear_marks (); */
1284 consing_since_gc
= 0;
1285 if (gc_cons_threshold
< 10000)
1286 gc_cons_threshold
= 10000;
1289 message1 (omessage
);
1290 else if (!noninteractive
)
1291 message1 ("Garbage collecting...done");
1293 return Fcons (Fcons (make_number (total_conses
),
1294 make_number (total_free_conses
)),
1295 Fcons (Fcons (make_number (total_symbols
),
1296 make_number (total_free_symbols
)),
1297 Fcons (Fcons (make_number (total_markers
),
1298 make_number (total_free_markers
)),
1299 Fcons (make_number (total_string_size
),
1300 Fcons (make_number (total_vector_size
),
1302 #ifdef LISP_FLOAT_TYPE
1303 Fcons (Fcons (make_number (total_floats
),
1304 make_number (total_free_floats
)),
1306 #else /* not LISP_FLOAT_TYPE */
1308 #endif /* not LISP_FLOAT_TYPE */
1316 /* Clear marks on all conses */
1318 register struct cons_block
*cblk
;
1319 register int lim
= cons_block_index
;
1321 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1324 for (i
= 0; i
< lim
; i
++)
1325 XUNMARK (cblk
->conses
[i
].car
);
1326 lim
= CONS_BLOCK_SIZE
;
1329 /* Clear marks on all symbols */
1331 register struct symbol_block
*sblk
;
1332 register int lim
= symbol_block_index
;
1334 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1337 for (i
= 0; i
< lim
; i
++)
1339 XUNMARK (sblk
->symbols
[i
].plist
);
1341 lim
= SYMBOL_BLOCK_SIZE
;
1344 /* Clear marks on all markers */
1346 register struct marker_block
*sblk
;
1347 register int lim
= marker_block_index
;
1349 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1352 for (i
= 0; i
< lim
; i
++)
1353 XUNMARK (sblk
->markers
[i
].chain
);
1354 lim
= MARKER_BLOCK_SIZE
;
1357 /* Clear mark bits on all buffers */
1359 register struct buffer
*nextb
= all_buffers
;
1363 XUNMARK (nextb
->name
);
1364 nextb
= nextb
->next
;
1370 /* Mark reference to a Lisp_Object. If the object referred to
1371 has not been seen yet, recursively mark all the references contained in it.
1373 If the object referenced is a short string, the referrencing slot
1374 is threaded into a chain of such slots, pointed to from
1375 the `size' field of the string. The actual string size
1376 lives in the last slot in the chain. We recognize the end
1377 because it is < (unsigned) STRING_BLOCK_SIZE. */
1379 #define LAST_MARKED_SIZE 500
1380 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1381 int last_marked_index
;
1384 mark_object (objptr
)
1385 Lisp_Object
*objptr
;
1387 register Lisp_Object obj
;
1394 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1395 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1398 last_marked
[last_marked_index
++] = objptr
;
1399 if (last_marked_index
== LAST_MARKED_SIZE
)
1400 last_marked_index
= 0;
1402 #ifdef SWITCH_ENUM_BUG
1403 switch ((int) XGCTYPE (obj
))
1405 switch (XGCTYPE (obj
))
1410 register struct Lisp_String
*ptr
= XSTRING (obj
);
1412 MARK_INTERVAL_TREE (ptr
->intervals
);
1413 if (ptr
->size
& MARKBIT
)
1414 /* A large string. Just set ARRAY_MARK_FLAG. */
1415 ptr
->size
|= ARRAY_MARK_FLAG
;
1418 /* A small string. Put this reference
1419 into the chain of references to it.
1420 The address OBJPTR is even, so if the address
1421 includes MARKBIT, put it in the low bit
1422 when we store OBJPTR into the size field. */
1424 if (XMARKBIT (*objptr
))
1426 XFASTINT (*objptr
) = ptr
->size
;
1430 XFASTINT (*objptr
) = ptr
->size
;
1431 if ((int)objptr
& 1) abort ();
1432 ptr
->size
= (int) objptr
& ~MARKBIT
;
1433 if ((int) objptr
& MARKBIT
)
1442 case Lisp_Window_Configuration
:
1444 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1445 register int size
= ptr
->size
;
1446 struct Lisp_Vector
*volatile ptr1
= ptr
;
1449 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1450 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1451 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1455 mark_object (&ptr
->contents
[i
]);
1461 /* We could treat this just like a vector, but it is better
1462 to save the COMPILED_CONSTANTS element for last and avoid recursion
1465 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1466 register int size
= ptr
->size
;
1467 struct Lisp_Vector
*volatile ptr1
= ptr
;
1470 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1471 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1472 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1476 if (i
!= COMPILED_CONSTANTS
)
1477 mark_object (&ptr
->contents
[i
]);
1479 objptr
= &ptr
->contents
[COMPILED_CONSTANTS
];
1487 register struct frame
*ptr
= XFRAME (obj
);
1488 register int size
= ptr
->size
;
1491 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1492 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1494 mark_object (&ptr
->name
);
1495 mark_object (&ptr
->focus_frame
);
1496 mark_object (&ptr
->width
);
1497 mark_object (&ptr
->height
);
1498 mark_object (&ptr
->selected_window
);
1499 mark_object (&ptr
->minibuffer_window
);
1500 mark_object (&ptr
->param_alist
);
1503 #endif /* not MULTI_FRAME */
1507 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
1508 struct Lisp_Symbol
*ptrx
;
1510 if (XMARKBIT (ptr
->plist
)) break;
1512 mark_object ((Lisp_Object
*) &ptr
->value
);
1513 mark_object (&ptr
->function
);
1514 mark_object (&ptr
->plist
);
1515 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1516 mark_object (&ptr
->name
);
1520 ptrx
= ptr
; /* Use pf ptrx avoids compiler bug on Sun */
1521 XSETSYMBOL (obj
, ptrx
);
1528 XMARK (XMARKER (obj
)->chain
);
1529 /* DO NOT mark thru the marker's chain.
1530 The buffer's markers chain does not preserve markers from gc;
1531 instead, markers are removed from the chain when freed by gc. */
1535 case Lisp_Buffer_Local_Value
:
1536 case Lisp_Some_Buffer_Local_Value
:
1538 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1539 if (XMARKBIT (ptr
->car
)) break;
1541 /* If the cdr is nil, avoid recursion for the car. */
1542 if (EQ (ptr
->cdr
, Qnil
))
1549 mark_object (&ptr
->car
);
1555 #ifdef LISP_FLOAT_TYPE
1557 XMARK (XFLOAT (obj
)->type
);
1559 #endif /* LISP_FLOAT_TYPE */
1562 if (!XMARKBIT (XBUFFER (obj
)->name
))
1572 case Lisp_Buffer_Objfwd
:
1573 case Lisp_Internal_Stream
:
1574 /* Don't bother with Lisp_Buffer_Objfwd,
1575 since all markable slots in current buffer marked anyway. */
1576 /* Don't need to do Lisp_Objfwd, since the places they point
1577 are protected with staticpro. */
1585 /* Mark the pointers in a buffer structure. */
1592 register struct buffer
*buffer
= XBUFFER (buf
);
1593 register Lisp_Object
*ptr
;
1595 /* This is the buffer's markbit */
1596 mark_object (&buffer
->name
);
1597 XMARK (buffer
->name
);
1599 MARK_INTERVAL_TREE (buffer
->intervals
);
1602 mark_object (buffer
->syntax_table
);
1604 /* Mark the various string-pointers in the buffer object.
1605 Since the strings may be relocated, we must mark them
1606 in their actual slots. So gc_sweep must convert each slot
1607 back to an ordinary C pointer. */
1608 XSET (*(Lisp_Object
*)&buffer
->upcase_table
,
1609 Lisp_String
, buffer
->upcase_table
);
1610 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1611 XSET (*(Lisp_Object
*)&buffer
->downcase_table
,
1612 Lisp_String
, buffer
->downcase_table
);
1613 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1615 XSET (*(Lisp_Object
*)&buffer
->sort_table
,
1616 Lisp_String
, buffer
->sort_table
);
1617 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1618 XSET (*(Lisp_Object
*)&buffer
->folding_sort_table
,
1619 Lisp_String
, buffer
->folding_sort_table
);
1620 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1623 for (ptr
= &buffer
->name
+ 1;
1624 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1629 /* Find all structures not marked, and free them. */
1634 total_string_size
= 0;
1637 /* Put all unmarked conses on free list */
1639 register struct cons_block
*cblk
;
1640 register int lim
= cons_block_index
;
1641 register int num_free
= 0, num_used
= 0;
1645 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1648 for (i
= 0; i
< lim
; i
++)
1649 if (!XMARKBIT (cblk
->conses
[i
].car
))
1651 XFASTINT (cblk
->conses
[i
].car
) = (int) cons_free_list
;
1653 cons_free_list
= &cblk
->conses
[i
];
1658 XUNMARK (cblk
->conses
[i
].car
);
1660 lim
= CONS_BLOCK_SIZE
;
1662 total_conses
= num_used
;
1663 total_free_conses
= num_free
;
1666 #ifdef LISP_FLOAT_TYPE
1667 /* Put all unmarked floats on free list */
1669 register struct float_block
*fblk
;
1670 register int lim
= float_block_index
;
1671 register int num_free
= 0, num_used
= 0;
1673 float_free_list
= 0;
1675 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1678 for (i
= 0; i
< lim
; i
++)
1679 if (!XMARKBIT (fblk
->floats
[i
].type
))
1681 XFASTINT (fblk
->floats
[i
].type
) = (int) float_free_list
;
1683 float_free_list
= &fblk
->floats
[i
];
1688 XUNMARK (fblk
->floats
[i
].type
);
1690 lim
= FLOAT_BLOCK_SIZE
;
1692 total_floats
= num_used
;
1693 total_free_floats
= num_free
;
1695 #endif /* LISP_FLOAT_TYPE */
1697 #ifdef USE_TEXT_PROPERTIES
1698 /* Put all unmarked intervals on free list */
1700 register struct interval_block
*iblk
;
1701 register int lim
= interval_block_index
;
1702 register int num_free
= 0, num_used
= 0;
1704 interval_free_list
= 0;
1706 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1710 for (i
= 0; i
< lim
; i
++)
1712 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1714 iblk
->intervals
[i
].parent
= interval_free_list
;
1715 interval_free_list
= &iblk
->intervals
[i
];
1721 XUNMARK (iblk
->intervals
[i
].plist
);
1724 lim
= INTERVAL_BLOCK_SIZE
;
1726 total_intervals
= num_used
;
1727 total_free_intervals
= num_free
;
1729 #endif /* USE_TEXT_PROPERTIES */
1731 /* Put all unmarked symbols on free list */
1733 register struct symbol_block
*sblk
;
1734 register int lim
= symbol_block_index
;
1735 register int num_free
= 0, num_used
= 0;
1737 symbol_free_list
= 0;
1739 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1742 for (i
= 0; i
< lim
; i
++)
1743 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1745 XFASTINT (sblk
->symbols
[i
].value
) = (int) symbol_free_list
;
1746 symbol_free_list
= &sblk
->symbols
[i
];
1752 sblk
->symbols
[i
].name
1753 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1754 XUNMARK (sblk
->symbols
[i
].plist
);
1756 lim
= SYMBOL_BLOCK_SIZE
;
1758 total_symbols
= num_used
;
1759 total_free_symbols
= num_free
;
1763 /* Put all unmarked markers on free list.
1764 Dechain each one first from the buffer it points into. */
1766 register struct marker_block
*mblk
;
1767 struct Lisp_Marker
*tem1
;
1768 register int lim
= marker_block_index
;
1769 register int num_free
= 0, num_used
= 0;
1771 marker_free_list
= 0;
1773 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1776 for (i
= 0; i
< lim
; i
++)
1777 if (!XMARKBIT (mblk
->markers
[i
].chain
))
1780 tem1
= &mblk
->markers
[i
]; /* tem1 avoids Sun compiler bug */
1781 XSET (tem
, Lisp_Marker
, tem1
);
1782 unchain_marker (tem
);
1783 XFASTINT (mblk
->markers
[i
].chain
) = (int) marker_free_list
;
1784 marker_free_list
= &mblk
->markers
[i
];
1790 XUNMARK (mblk
->markers
[i
].chain
);
1792 lim
= MARKER_BLOCK_SIZE
;
1795 total_markers
= num_used
;
1796 total_free_markers
= num_free
;
1799 /* Free all unmarked buffers */
1801 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1804 if (!XMARKBIT (buffer
->name
))
1807 prev
->next
= buffer
->next
;
1809 all_buffers
= buffer
->next
;
1810 next
= buffer
->next
;
1816 XUNMARK (buffer
->name
);
1817 UNMARK_BALANCE_INTERVALS (buffer
->intervals
);
1820 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1821 for purposes of marking and relocation.
1822 Turn them back into C pointers now. */
1823 buffer
->upcase_table
1824 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
1825 buffer
->downcase_table
1826 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
1828 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
1829 buffer
->folding_sort_table
1830 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
1833 prev
= buffer
, buffer
= buffer
->next
;
1837 #endif /* standalone */
1839 /* Free all unmarked vectors */
1841 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
1842 total_vector_size
= 0;
1845 if (!(vector
->size
& ARRAY_MARK_FLAG
))
1848 prev
->next
= vector
->next
;
1850 all_vectors
= vector
->next
;
1851 next
= vector
->next
;
1857 vector
->size
&= ~ARRAY_MARK_FLAG
;
1858 total_vector_size
+= vector
->size
;
1859 prev
= vector
, vector
= vector
->next
;
1863 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
1865 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
1868 if (!(((struct Lisp_String
*)(&sb
->chars
[0]))->size
& ARRAY_MARK_FLAG
))
1871 prev
->next
= sb
->next
;
1873 large_string_blocks
= sb
->next
;
1880 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
1881 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
1882 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
1883 prev
= sb
, sb
= sb
->next
;
1888 /* Compactify strings, relocate references to them, and
1889 free any string blocks that become empty. */
1894 /* String block of old strings we are scanning. */
1895 register struct string_block
*from_sb
;
1896 /* A preceding string block (or maybe the same one)
1897 where we are copying the still-live strings to. */
1898 register struct string_block
*to_sb
;
1902 to_sb
= first_string_block
;
1905 /* Scan each existing string block sequentially, string by string. */
1906 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
1909 /* POS is the index of the next string in the block. */
1910 while (pos
< from_sb
->pos
)
1912 register struct Lisp_String
*nextstr
1913 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
1915 register struct Lisp_String
*newaddr
;
1916 register int size
= nextstr
->size
;
1918 /* NEXTSTR is the old address of the next string.
1919 Just skip it if it isn't marked. */
1920 if ((unsigned) size
> STRING_BLOCK_SIZE
)
1922 /* It is marked, so its size field is really a chain of refs.
1923 Find the end of the chain, where the actual size lives. */
1924 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1926 if (size
& 1) size
^= MARKBIT
| 1;
1927 size
= *(int *)size
& ~MARKBIT
;
1930 total_string_size
+= size
;
1932 /* If it won't fit in TO_SB, close it out,
1933 and move to the next sb. Keep doing so until
1934 TO_SB reaches a large enough, empty enough string block.
1935 We know that TO_SB cannot advance past FROM_SB here
1936 since FROM_SB is large enough to contain this string.
1937 Any string blocks skipped here
1938 will be patched out and freed later. */
1939 while (to_pos
+ STRING_FULLSIZE (size
)
1940 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
1942 to_sb
->pos
= to_pos
;
1943 to_sb
= to_sb
->next
;
1946 /* Compute new address of this string
1947 and update TO_POS for the space being used. */
1948 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
1949 to_pos
+= STRING_FULLSIZE (size
);
1951 /* Copy the string itself to the new place. */
1952 if (nextstr
!= newaddr
)
1953 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (int)
1954 + INTERVAL_PTR_SIZE
);
1956 /* Go through NEXTSTR's chain of references
1957 and make each slot in the chain point to
1958 the new address of this string. */
1959 size
= newaddr
->size
;
1960 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1962 register Lisp_Object
*objptr
;
1963 if (size
& 1) size
^= MARKBIT
| 1;
1964 objptr
= (Lisp_Object
*)size
;
1966 size
= XFASTINT (*objptr
) & ~MARKBIT
;
1967 if (XMARKBIT (*objptr
))
1969 XSET (*objptr
, Lisp_String
, newaddr
);
1973 XSET (*objptr
, Lisp_String
, newaddr
);
1975 /* Store the actual size in the size field. */
1976 newaddr
->size
= size
;
1978 pos
+= STRING_FULLSIZE (size
);
1982 /* Close out the last string block still used and free any that follow. */
1983 to_sb
->pos
= to_pos
;
1984 current_string_block
= to_sb
;
1986 from_sb
= to_sb
->next
;
1990 to_sb
= from_sb
->next
;
1995 /* Free any empty string blocks further back in the chain.
1996 This loop will never free first_string_block, but it is very
1997 unlikely that that one will become empty, so why bother checking? */
1999 from_sb
= first_string_block
;
2000 while (to_sb
= from_sb
->next
)
2002 if (to_sb
->pos
== 0)
2004 if (from_sb
->next
= to_sb
->next
)
2005 from_sb
->next
->prev
= from_sb
;
2013 /* Debugging aids. */
2015 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, "",
2016 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2017 This may be helpful in debugging Emacs's memory usage.\n\
2018 If called interactively, print the result in the minibuffer.")
2023 XSET (end
, Lisp_Int
, (int) sbrk (0));
2025 if (! NILP (Finteractive_p
))
2026 message ("Memory limit at %dk.", XINT (end
));
2032 /* Initialization */
2036 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2039 pure_size
= PURESIZE
;
2042 ignore_warnings
= 1;
2047 #ifdef LISP_FLOAT_TYPE
2049 #endif /* LISP_FLOAT_TYPE */
2052 ignore_warnings
= 0;
2055 consing_since_gc
= 0;
2056 gc_cons_threshold
= 100000;
2057 #ifdef VIRT_ADDR_VARIES
2058 malloc_sbrk_unused
= 1<<22; /* A large number */
2059 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2060 #endif /* VIRT_ADDR_VARIES */
2071 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2072 "*Number of bytes of consing between garbage collections.\n\
2073 Garbage collection can happen automatically once this many bytes have been\n\
2074 allocated since the last garbage collection. All data types count.\n\n\
2075 Garbage collection happens automatically only when `eval' is called.\n\n\
2076 By binding this temporarily to a large number, you can effectively\n\
2077 prevent garbage collection during a part of the program.");
2079 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2080 "Number of bytes of sharable Lisp data allocated so far.");
2083 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2084 "Number of bytes of unshared memory allocated in this session.");
2086 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2087 "Number of bytes of unshared memory remaining available in this session.");
2090 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2091 "Non-nil means loading Lisp code in order to dump an executable.\n\
2092 This means that certain objects should be allocated in shared (pure) space.");
2094 DEFVAR_INT ("undo-limit", &undo_limit
,
2095 "Keep no more undo information once it exceeds this size.\n\
2096 This limit is applied when garbage collection happens.\n\
2097 The size is counted as the number of bytes occupied,\n\
2098 which includes both saved text and other data.");
2101 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2102 "Don't keep more than this much size of undo information.\n\
2103 A command which pushes past this size is itself forgotten.\n\
2104 This limit is applied when garbage collection happens.\n\
2105 The size is counted as the number of bytes occupied,\n\
2106 which includes both saved text and other data.");
2107 undo_strong_limit
= 30000;
2112 defsubr (&Smake_byte_code
);
2113 defsubr (&Smake_list
);
2114 defsubr (&Smake_vector
);
2115 defsubr (&Smake_string
);
2116 defsubr (&Smake_rope
);
2117 defsubr (&Srope_elt
);
2118 defsubr (&Smake_symbol
);
2119 defsubr (&Smake_marker
);
2120 defsubr (&Spurecopy
);
2121 defsubr (&Sgarbage_collect
);
2122 defsubr (&Smemory_limit
);