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. */
29 #endif /* MULTI_SCREEN */
32 #define max(A,B) ((A) > (B) ? (A) : (B))
34 /* Macro to verify that storage intended for Lisp objects is not
35 out of range to fit in the space for a pointer.
36 ADDRESS is the start of the block, and SIZE
37 is the amount of space within which objects can start. */
38 #define VALIDATE_LISP_STORAGE(address, size) \
42 XSET (val, Lisp_Cons, (char *) address + size); \
43 if ((char *) XCONS (val) != (char *) address + size) \
50 /* Number of bytes of consing done since the last gc */
53 /* Number of bytes of consing since gc before another gc should be done. */
54 int gc_cons_threshold
;
56 /* Nonzero during gc */
59 #ifndef VIRT_ADDR_VARIES
61 #endif /* VIRT_ADDR_VARIES */
64 #ifndef VIRT_ADDR_VARIES
66 #endif /* VIRT_ADDR_VARIES */
67 int malloc_sbrk_unused
;
69 /* Two thresholds controlling how much undo information to keep. */
71 int undo_high_threshold
;
73 /* Non-nil means defun should do purecopy on the function definition */
74 Lisp_Object Vpurify_flag
;
77 int pure
[PURESIZE
/ sizeof (int)] = {0,}; /* Force it into data space! */
78 #define PUREBEG (char *) pure
80 #define pure PURE_SEG_BITS /* Use shared memory segment */
81 #define PUREBEG (char *)PURE_SEG_BITS
83 /* This variable is used only by the XPNTR macro when HAVE_SHM is
84 defined. If we used the PURESIZE macro directly there, that would
85 make most of emacs dependent on puresize.h, which we don't want -
86 you should be able to change that without too much recompilation.
87 So map_in_data initializes pure_size, and the dependencies work
90 #endif /* not HAVE_SHM */
92 /* Index in pure at which next pure object will be allocated. */
95 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
96 char *pending_malloc_warning
;
98 /* Maximum amount of C stack to save when a GC happens. */
100 #ifndef MAX_SAVE_STACK
101 #define MAX_SAVE_STACK 16000
104 /* Buffer in which we save a copy of the C stack at each GC. */
109 /* Non-zero means ignore malloc warnings. Set during initialization. */
113 malloc_warning_1 (str
)
116 Fprinc (str
, Vstandard_output
);
117 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
118 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
119 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
123 /* malloc calls this if it finds we are near exhausting storage */
127 pending_malloc_warning
= str
;
130 display_malloc_warning ()
132 register Lisp_Object val
;
134 val
= build_string (pending_malloc_warning
);
135 pending_malloc_warning
= 0;
136 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
139 /* Called if malloc returns zero */
142 error ("Memory exhausted");
145 /* like malloc and realloc but check for no memory left */
153 val
= (long *) malloc (size
);
155 if (!val
&& size
) memory_full ();
160 xrealloc (block
, size
)
166 /* We must call malloc explicitly when BLOCK is 0, since some
167 reallocs don't do this. */
169 val
= (long *) malloc (size
);
171 val
= (long *) realloc (block
, size
);
173 if (!val
&& size
) memory_full ();
177 #ifdef LISP_FLOAT_TYPE
178 /* Allocation of float cells, just like conses */
179 /* We store float cells inside of float_blocks, allocating a new
180 float_block with malloc whenever necessary. Float cells reclaimed by
181 GC are put on a free list to be reallocated before allocating
182 any new float cells from the latest float_block.
184 Each float_block is just under 1020 bytes long,
185 since malloc really allocates in units of powers of two
186 and uses 4 bytes for its own overhead. */
188 #define FLOAT_BLOCK_SIZE \
189 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
193 struct float_block
*next
;
194 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
197 struct float_block
*float_block
;
198 int float_block_index
;
200 struct Lisp_Float
*float_free_list
;
205 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
206 float_block
->next
= 0;
207 bzero (float_block
->floats
, sizeof float_block
->floats
);
208 float_block_index
= 0;
212 /* Explicitly free a float cell. */
214 struct Lisp_Float
*ptr
;
216 XFASTINT (ptr
->type
) = (int) float_free_list
;
217 float_free_list
= ptr
;
221 make_float (float_value
)
224 register Lisp_Object val
;
228 XSET (val
, Lisp_Float
, float_free_list
);
229 float_free_list
= (struct Lisp_Float
*) XFASTINT (float_free_list
->type
);
233 if (float_block_index
== FLOAT_BLOCK_SIZE
)
235 register struct float_block
*new = (struct float_block
*) malloc (sizeof (struct float_block
));
236 if (!new) memory_full ();
237 VALIDATE_LISP_STORAGE (new, sizeof *new);
238 new->next
= float_block
;
240 float_block_index
= 0;
242 XSET (val
, Lisp_Float
, &float_block
->floats
[float_block_index
++]);
244 XFLOAT (val
)->data
= float_value
;
245 XFLOAT (val
)->type
= 0; /* bug chasing -wsr */
246 consing_since_gc
+= sizeof (struct Lisp_Float
);
250 #endif /* LISP_FLOAT_TYPE */
252 /* Allocation of cons cells */
253 /* We store cons cells inside of cons_blocks, allocating a new
254 cons_block with malloc whenever necessary. Cons cells reclaimed by
255 GC are put on a free list to be reallocated before allocating
256 any new cons cells from the latest cons_block.
258 Each cons_block is just under 1020 bytes long,
259 since malloc really allocates in units of powers of two
260 and uses 4 bytes for its own overhead. */
262 #define CONS_BLOCK_SIZE \
263 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
267 struct cons_block
*next
;
268 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
271 struct cons_block
*cons_block
;
272 int cons_block_index
;
274 struct Lisp_Cons
*cons_free_list
;
279 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
280 cons_block
->next
= 0;
281 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
282 cons_block_index
= 0;
286 /* Explicitly free a cons cell. */
288 struct Lisp_Cons
*ptr
;
290 XFASTINT (ptr
->car
) = (int) cons_free_list
;
291 cons_free_list
= ptr
;
294 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
295 "Create a new cons, give it CAR and CDR as components, and return it.")
297 Lisp_Object car
, cdr
;
299 register Lisp_Object val
;
303 XSET (val
, Lisp_Cons
, cons_free_list
);
304 cons_free_list
= (struct Lisp_Cons
*) XFASTINT (cons_free_list
->car
);
308 if (cons_block_index
== CONS_BLOCK_SIZE
)
310 register struct cons_block
*new = (struct cons_block
*) malloc (sizeof (struct cons_block
));
311 if (!new) memory_full ();
312 VALIDATE_LISP_STORAGE (new, sizeof *new);
313 new->next
= cons_block
;
315 cons_block_index
= 0;
317 XSET (val
, Lisp_Cons
, &cons_block
->conses
[cons_block_index
++]);
319 XCONS (val
)->car
= car
;
320 XCONS (val
)->cdr
= cdr
;
321 consing_since_gc
+= sizeof (struct Lisp_Cons
);
325 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
326 "Return a newly created list with specified arguments as elements.\n\
327 Any number of arguments, even zero arguments, are allowed.")
330 register Lisp_Object
*args
;
332 register Lisp_Object len
, val
, val_tail
;
334 XFASTINT (len
) = nargs
;
335 val
= Fmake_list (len
, Qnil
);
337 while (!NILP (val_tail
))
339 XCONS (val_tail
)->car
= *args
++;
340 val_tail
= XCONS (val_tail
)->cdr
;
345 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
346 "Return a newly created list of length LENGTH, with each element being INIT.")
348 register Lisp_Object length
, init
;
350 register Lisp_Object val
;
353 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
354 length
= wrong_type_argument (Qnatnump
, length
);
355 size
= XINT (length
);
359 val
= Fcons (init
, val
);
363 /* Allocation of vectors */
365 struct Lisp_Vector
*all_vectors
;
367 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
368 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
369 See also the function `vector'.")
371 register Lisp_Object length
, init
;
373 register int sizei
, index
;
374 register Lisp_Object vector
;
375 register struct Lisp_Vector
*p
;
377 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
378 length
= wrong_type_argument (Qnatnump
, length
);
379 sizei
= XINT (length
);
381 p
= (struct Lisp_Vector
*) malloc (sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
));
384 VALIDATE_LISP_STORAGE (p
, 0);
386 XSET (vector
, Lisp_Vector
, p
);
387 consing_since_gc
+= sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
);
390 p
->next
= all_vectors
;
393 for (index
= 0; index
< sizei
; index
++)
394 p
->contents
[index
] = init
;
399 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
400 "Return a newly created vector with specified arguments as elements.\n\
401 Any number of arguments, even zero arguments, are allowed.")
406 register Lisp_Object len
, val
;
408 register struct Lisp_Vector
*p
;
410 XFASTINT (len
) = nargs
;
411 val
= Fmake_vector (len
, Qnil
);
413 for (index
= 0; index
< nargs
; index
++)
414 p
->contents
[index
] = args
[index
];
418 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
419 "Create a byte-code object with specified arguments as elements.\n\
420 The arguments should be the arglist, bytecode-string, constant vector,\n\
421 stack size, (optional) doc string, and (optional) interactive spec.\n\
422 The first four arguments are required; at most six have any\n\
428 register Lisp_Object len
, val
;
430 register struct Lisp_Vector
*p
;
432 XFASTINT (len
) = nargs
;
433 if (!NILP (Vpurify_flag
))
434 val
= make_pure_vector (len
);
436 val
= Fmake_vector (len
, Qnil
);
438 for (index
= 0; index
< nargs
; index
++)
440 if (!NILP (Vpurify_flag
))
441 args
[index
] = Fpurecopy (args
[index
]);
442 p
->contents
[index
] = args
[index
];
444 XSETTYPE (val
, Lisp_Compiled
);
448 /* Allocation of symbols.
449 Just like allocation of conses!
451 Each symbol_block is just under 1020 bytes long,
452 since malloc really allocates in units of powers of two
453 and uses 4 bytes for its own overhead. */
455 #define SYMBOL_BLOCK_SIZE \
456 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
460 struct symbol_block
*next
;
461 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
464 struct symbol_block
*symbol_block
;
465 int symbol_block_index
;
467 struct Lisp_Symbol
*symbol_free_list
;
472 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
473 symbol_block
->next
= 0;
474 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
475 symbol_block_index
= 0;
476 symbol_free_list
= 0;
479 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
480 "Return a newly allocated uninterned symbol whose name is NAME.\n\
481 Its value and function definition are void, and its property list is nil.")
485 register Lisp_Object val
;
486 register struct Lisp_Symbol
*p
;
488 CHECK_STRING (str
, 0);
490 if (symbol_free_list
)
492 XSET (val
, Lisp_Symbol
, symbol_free_list
);
494 = (struct Lisp_Symbol
*) XFASTINT (symbol_free_list
->value
);
498 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
500 struct symbol_block
*new = (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
501 if (!new) memory_full ();
502 VALIDATE_LISP_STORAGE (new, sizeof *new);
503 new->next
= symbol_block
;
505 symbol_block_index
= 0;
507 XSET (val
, Lisp_Symbol
, &symbol_block
->symbols
[symbol_block_index
++]);
510 p
->name
= XSTRING (str
);
513 p
->function
= Qunbound
;
515 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
519 /* Allocation of markers.
520 Works like allocation of conses. */
522 #define MARKER_BLOCK_SIZE \
523 ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker))
527 struct marker_block
*next
;
528 struct Lisp_Marker markers
[MARKER_BLOCK_SIZE
];
531 struct marker_block
*marker_block
;
532 int marker_block_index
;
534 struct Lisp_Marker
*marker_free_list
;
539 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
540 marker_block
->next
= 0;
541 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
542 marker_block_index
= 0;
543 marker_free_list
= 0;
546 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
547 "Return a newly allocated marker which does not point at any place.")
550 register Lisp_Object val
;
551 register struct Lisp_Marker
*p
;
552 /* Detact the bug that seems to have caused this to be called from
555 EMACS_SIGSETMASK (-1, mask
);
556 EMACS_SIGSETMASK (mask
, dummy
);
560 if (marker_free_list
)
562 XSET (val
, Lisp_Marker
, marker_free_list
);
564 = (struct Lisp_Marker
*) XFASTINT (marker_free_list
->chain
);
568 if (marker_block_index
== MARKER_BLOCK_SIZE
)
570 struct marker_block
*new = (struct marker_block
*) malloc (sizeof (struct marker_block
));
571 if (!new) memory_full ();
572 VALIDATE_LISP_STORAGE (new, sizeof *new);
573 new->next
= marker_block
;
575 marker_block_index
= 0;
577 XSET (val
, Lisp_Marker
, &marker_block
->markers
[marker_block_index
++]);
583 consing_since_gc
+= sizeof (struct Lisp_Marker
);
587 /* Allocation of strings */
589 /* Strings reside inside of string_blocks. The entire data of the string,
590 both the size and the contents, live in part of the `chars' component of a string_block.
591 The `pos' component is the index within `chars' of the first free byte.
593 first_string_block points to the first string_block ever allocated.
594 Each block points to the next one with its `next' field.
595 The `prev' fields chain in reverse order.
596 The last one allocated is the one currently being filled.
597 current_string_block points to it.
599 The string_blocks that hold individual large strings
600 go in a separate chain, started by large_string_blocks. */
603 /* String blocks contain this many useful bytes.
604 8188 is power of 2, minus 4 for malloc overhead. */
605 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
607 /* A string bigger than this gets its own specially-made string block
608 if it doesn't fit in the current one. */
609 #define STRING_BLOCK_OUTSIZE 1024
611 struct string_block_head
613 struct string_block
*next
, *prev
;
619 struct string_block
*next
, *prev
;
621 char chars
[STRING_BLOCK_SIZE
];
624 /* This points to the string block we are now allocating strings. */
626 struct string_block
*current_string_block
;
628 /* This points to the oldest string block, the one that starts the chain. */
630 struct string_block
*first_string_block
;
632 /* Last string block in chain of those made for individual large strings. */
634 struct string_block
*large_string_blocks
;
636 /* If SIZE is the length of a string, this returns how many bytes
637 the string occupies in a string_block (including padding). */
639 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
641 #define PAD (sizeof (int))
644 #define STRING_FULLSIZE(SIZE) \
645 (((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1))
651 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
652 first_string_block
= current_string_block
;
653 consing_since_gc
+= sizeof (struct string_block
);
654 current_string_block
->next
= 0;
655 current_string_block
->prev
= 0;
656 current_string_block
->pos
= 0;
657 large_string_blocks
= 0;
660 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
661 "Return a newly created string of length LENGTH, with each element being INIT.\n\
662 Both LENGTH and INIT must be numbers.")
664 Lisp_Object length
, init
;
666 register Lisp_Object val
;
667 register unsigned char *p
, *end
, c
;
669 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
670 length
= wrong_type_argument (Qnatnump
, length
);
671 CHECK_NUMBER (init
, 1);
672 val
= make_uninit_string (XINT (length
));
674 p
= XSTRING (val
)->data
;
675 end
= p
+ XSTRING (val
)->size
;
683 make_string (contents
, length
)
687 register Lisp_Object val
;
688 val
= make_uninit_string (length
);
689 bcopy (contents
, XSTRING (val
)->data
, length
);
697 return make_string (str
, strlen (str
));
701 make_uninit_string (length
)
704 register Lisp_Object val
;
705 register int fullsize
= STRING_FULLSIZE (length
);
707 if (length
< 0) abort ();
709 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
710 /* This string can fit in the current string block */
712 XSET (val
, Lisp_String
,
713 (struct Lisp_String
*) (current_string_block
->chars
+ current_string_block
->pos
));
714 current_string_block
->pos
+= fullsize
;
716 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
717 /* This string gets its own string block */
719 register struct string_block
*new
720 = (struct string_block
*) malloc (sizeof (struct string_block_head
) + fullsize
);
721 VALIDATE_LISP_STORAGE (new, 0);
722 if (!new) memory_full ();
723 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
725 new->next
= large_string_blocks
;
726 large_string_blocks
= new;
727 XSET (val
, Lisp_String
,
728 (struct Lisp_String
*) ((struct string_block_head
*)new + 1));
731 /* Make a new current string block and start it off with this string */
733 register struct string_block
*new
734 = (struct string_block
*) malloc (sizeof (struct string_block
));
735 if (!new) memory_full ();
736 VALIDATE_LISP_STORAGE (new, sizeof *new);
737 consing_since_gc
+= sizeof (struct string_block
);
738 current_string_block
->next
= new;
739 new->prev
= current_string_block
;
741 current_string_block
= new;
743 XSET (val
, Lisp_String
,
744 (struct Lisp_String
*) current_string_block
->chars
);
747 XSTRING (val
)->size
= length
;
748 XSTRING (val
)->data
[length
] = 0;
753 /* Return a newly created vector or string with specified arguments as
754 elements. If all the arguments are characters, make a string;
755 otherwise, make a vector. Any number of arguments, even zero
756 arguments, are allowed. */
759 make_array (nargs
, args
)
765 for (i
= 0; i
< nargs
; i
++)
766 if (XTYPE (args
[i
]) != Lisp_Int
767 || (unsigned) XINT (args
[i
]) >= 0400)
768 return Fvector (nargs
, args
);
770 /* Since the loop exited, we know that all the things in it are
771 characters, so we can make a string. */
773 Lisp_Object result
= Fmake_string (nargs
, make_number (0));
775 for (i
= 0; i
< nargs
; i
++)
776 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
782 /* Note: the user cannot manipulate ropes portably by referring
783 to the chars of the string, because combining two chars to make a GLYPH
784 depends on endianness. */
786 DEFUN ("make-rope", Fmake_rope
, Smake_rope
, 0, MANY
, 0,
787 "Return a newly created rope containing the arguments of this function.\n\
788 A rope is a string, except that its contents will be treated as an\n\
789 array of glyphs, where a glyph is an integer type that may be larger\n\
790 than a character. Emacs is normally configured to use 8-bit glyphs,\n\
791 so ropes are normally no different from strings. But Emacs may be\n\
792 configured to use 16-bit glyphs, to allow the use of larger fonts.\n\
794 Each argument (which must be an integer) specifies one glyph, whatever\n\
795 size glyphs may be.\n\
797 See variable `buffer-display-table' for the uses of ropes.")
803 register Lisp_Object val
;
806 val
= make_uninit_string (nargs
* sizeof (GLYPH
));
808 p
= (GLYPH
*) XSTRING (val
)->data
;
809 for (i
= 0; i
< nargs
; i
++)
811 CHECK_NUMBER (args
[i
], i
);
812 p
[i
] = XFASTINT (args
[i
]);
817 DEFUN ("rope-elt", Frope_elt
, Srope_elt
, 2, 2, 0,
818 "Return an element of rope R at index N.\n\
819 A rope is a string in which each pair of bytes is considered an element.\n\
820 See variable `buffer-display-table' for the uses of ropes.")
825 if ((XSTRING (r
)->size
/ sizeof (GLYPH
)) <= XINT (n
) || XINT (n
) < 0)
826 args_out_of_range (r
, n
);
827 return ((GLYPH
*) XSTRING (r
)->data
)[XFASTINT (n
)];
830 /* Must get an error if pure storage is full,
831 since if it cannot hold a large string
832 it may be able to hold conses that point to that string;
833 then the string is not protected from gc. */
836 make_pure_string (data
, length
)
840 register Lisp_Object
new;
841 register int size
= sizeof (int) + length
+ 1;
843 if (pureptr
+ size
> PURESIZE
)
844 error ("Pure Lisp storage exhausted");
845 XSET (new, Lisp_String
, PUREBEG
+ pureptr
);
846 XSTRING (new)->size
= length
;
847 bcopy (data
, XSTRING (new)->data
, length
);
848 XSTRING (new)->data
[length
] = 0;
849 pureptr
+= (size
+ sizeof (int) - 1)
850 / sizeof (int) * sizeof (int);
856 Lisp_Object car
, cdr
;
858 register Lisp_Object
new;
860 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
861 error ("Pure Lisp storage exhausted");
862 XSET (new, Lisp_Cons
, PUREBEG
+ pureptr
);
863 pureptr
+= sizeof (struct Lisp_Cons
);
864 XCONS (new)->car
= Fpurecopy (car
);
865 XCONS (new)->cdr
= Fpurecopy (cdr
);
869 #ifdef LISP_FLOAT_TYPE
872 make_pure_float (num
)
875 register Lisp_Object
new;
877 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
878 error ("Pure Lisp storage exhausted");
879 XSET (new, Lisp_Float
, PUREBEG
+ pureptr
);
880 pureptr
+= sizeof (struct Lisp_Float
);
881 XFLOAT (new)->data
= num
;
882 XFLOAT (new)->type
= 0; /* bug chasing -wsr */
886 #endif /* LISP_FLOAT_TYPE */
889 make_pure_vector (len
)
892 register Lisp_Object
new;
893 register int size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
895 if (pureptr
+ size
> PURESIZE
)
896 error ("Pure Lisp storage exhausted");
898 XSET (new, Lisp_Vector
, PUREBEG
+ pureptr
);
900 XVECTOR (new)->size
= len
;
904 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
905 "Make a copy of OBJECT in pure storage.\n\
906 Recursively copies contents of vectors and cons cells.\n\
907 Does not copy symbols.")
909 register Lisp_Object obj
;
911 register Lisp_Object
new, tem
;
914 if (NILP (Vpurify_flag
))
917 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
918 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
921 #ifdef SWITCH_ENUM_BUG
922 switch ((int) XTYPE (obj
))
928 error ("Attempt to copy a marker to pure storage");
931 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
933 #ifdef LISP_FLOAT_TYPE
935 return make_pure_float (XFLOAT (obj
)->data
);
936 #endif /* LISP_FLOAT_TYPE */
939 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
943 new = make_pure_vector (XVECTOR (obj
)->size
);
944 for (i
= 0; i
< XVECTOR (obj
)->size
; i
++)
946 tem
= XVECTOR (obj
)->contents
[i
];
947 XVECTOR (new)->contents
[i
] = Fpurecopy (tem
);
949 XSETTYPE (new, XTYPE (obj
));
957 /* Recording what needs to be marked for gc. */
959 struct gcpro
*gcprolist
;
963 Lisp_Object
*staticvec
[NSTATICS
] = {0};
967 /* Put an entry in staticvec, pointing at the variable whose address is given */
970 staticpro (varaddress
)
971 Lisp_Object
*varaddress
;
973 staticvec
[staticidx
++] = varaddress
;
974 if (staticidx
>= NSTATICS
)
982 struct catchtag
*next
;
983 /* jmp_buf jmp; /* We don't need this for GC purposes */
988 struct backtrace
*next
;
989 Lisp_Object
*function
;
990 Lisp_Object
*args
; /* Points to vector of args. */
991 int nargs
; /* length of vector */
992 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
996 /* Two flags that are set during GC in the `size' component
997 of a string or vector. On some machines, these flags
998 are defined by the m- file to be different bits. */
1000 /* On vector, means it has been marked.
1001 On string size field or a reference to a string,
1002 means not the last reference in the chain. */
1004 #ifndef ARRAY_MARK_FLAG
1005 #define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
1006 #endif /* no ARRAY_MARK_FLAG */
1008 /* Any slot that is a Lisp_Object can point to a string
1009 and thus can be put on a string's reference-chain
1010 and thus may need to have its ARRAY_MARK_FLAG set.
1011 This includes the slots whose markbits are used to mark
1012 the containing objects. */
1014 #if ARRAY_MARK_FLAG == MARKBIT
1018 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1019 int total_free_conses
, total_free_markers
, total_free_symbols
;
1020 #ifdef LISP_FLOAT_TYPE
1021 int total_free_floats
, total_floats
;
1022 #endif /* LISP_FLOAT_TYPE */
1024 static void mark_object (), mark_buffer ();
1025 static void clear_marks (), gc_sweep ();
1026 static void compact_strings ();
1028 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1029 "Reclaim storage for Lisp objects no longer needed.\n\
1030 Returns info on amount of space in use:\n\
1031 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1032 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1033 (USED-FLOATS . FREE-FLOATS))\n\
1034 Garbage collection happens automatically if you cons more than\n\
1035 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1038 register struct gcpro
*tail
;
1039 register struct specbinding
*bind
;
1040 struct catchtag
*catch;
1041 struct handler
*handler
;
1042 register struct backtrace
*backlist
;
1043 register Lisp_Object tem
;
1044 char *omessage
= echo_area_glyphs
;
1045 char stack_top_variable
;
1048 /* Save a copy of the contents of the stack, for debugging. */
1049 #if MAX_SAVE_STACK > 0
1050 if (NILP (Vpurify_flag
))
1052 i
= &stack_top_variable
- stack_bottom
;
1054 if (i
< MAX_SAVE_STACK
)
1056 if (stack_copy
== 0)
1057 stack_copy
= (char *) malloc (stack_copy_size
= i
);
1058 else if (stack_copy_size
< i
)
1059 stack_copy
= (char *) realloc (stack_copy
, (stack_copy_size
= i
));
1062 if ((int) (&stack_top_variable
- stack_bottom
) > 0)
1063 bcopy (stack_bottom
, stack_copy
, i
);
1065 bcopy (&stack_top_variable
, stack_copy
, i
);
1069 #endif /* MAX_SAVE_STACK > 0 */
1071 if (!noninteractive
)
1072 message1 ("Garbage collecting...");
1074 /* Don't keep command history around forever */
1075 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1077 XCONS (tem
)->cdr
= Qnil
;
1078 /* Likewise for undo information. */
1080 register struct buffer
*nextb
= all_buffers
;
1085 = truncate_undo_list (nextb
->undo_list
, undo_threshold
,
1086 undo_high_threshold
);
1087 nextb
= nextb
->next
;
1093 /* clear_marks (); */
1095 /* In each "large string", set the MARKBIT of the size field.
1096 That enables mark_object to recognize them. */
1098 register struct string_block
*b
;
1099 for (b
= large_string_blocks
; b
; b
= b
->next
)
1100 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1103 /* Mark all the special slots that serve as the roots of accessibility.
1105 Usually the special slots to mark are contained in particular structures.
1106 Then we know no slot is marked twice because the structures don't overlap.
1107 In some cases, the structures point to the slots to be marked.
1108 For these, we use MARKBIT to avoid double marking of the slot. */
1110 for (i
= 0; i
< staticidx
; i
++)
1111 mark_object (staticvec
[i
]);
1112 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1113 for (i
= 0; i
< tail
->nvars
; i
++)
1114 if (!XMARKBIT (tail
->var
[i
]))
1116 mark_object (&tail
->var
[i
]);
1117 XMARK (tail
->var
[i
]);
1119 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1121 mark_object (&bind
->symbol
);
1122 mark_object (&bind
->old_value
);
1124 for (catch = catchlist
; catch; catch = catch->next
)
1126 mark_object (&catch->tag
);
1127 mark_object (&catch->val
);
1129 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1131 mark_object (&handler
->handler
);
1132 mark_object (&handler
->var
);
1134 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1136 if (!XMARKBIT (*backlist
->function
))
1138 mark_object (backlist
->function
);
1139 XMARK (*backlist
->function
);
1141 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1144 i
= backlist
->nargs
- 1;
1146 if (!XMARKBIT (backlist
->args
[i
]))
1148 mark_object (&backlist
->args
[i
]);
1149 XMARK (backlist
->args
[i
]);
1155 /* Clear the mark bits that we set in certain root slots. */
1157 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1158 for (i
= 0; i
< tail
->nvars
; i
++)
1159 XUNMARK (tail
->var
[i
]);
1160 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1162 XUNMARK (*backlist
->function
);
1163 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1166 i
= backlist
->nargs
- 1;
1168 XUNMARK (backlist
->args
[i
]);
1170 XUNMARK (buffer_defaults
.name
);
1171 XUNMARK (buffer_local_symbols
.name
);
1173 /* clear_marks (); */
1176 consing_since_gc
= 0;
1177 if (gc_cons_threshold
< 10000)
1178 gc_cons_threshold
= 10000;
1181 message1 (omessage
);
1182 else if (!noninteractive
)
1183 message1 ("Garbage collecting...done");
1185 return Fcons (Fcons (make_number (total_conses
),
1186 make_number (total_free_conses
)),
1187 Fcons (Fcons (make_number (total_symbols
),
1188 make_number (total_free_symbols
)),
1189 Fcons (Fcons (make_number (total_markers
),
1190 make_number (total_free_markers
)),
1191 Fcons (make_number (total_string_size
),
1192 Fcons (make_number (total_vector_size
),
1194 #ifdef LISP_FLOAT_TYPE
1195 Fcons (Fcons (make_number (total_floats
),
1196 make_number (total_free_floats
)),
1198 #else /* not LISP_FLOAT_TYPE */
1200 #endif /* not LISP_FLOAT_TYPE */
1208 /* Clear marks on all conses */
1210 register struct cons_block
*cblk
;
1211 register int lim
= cons_block_index
;
1213 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1216 for (i
= 0; i
< lim
; i
++)
1217 XUNMARK (cblk
->conses
[i
].car
);
1218 lim
= CONS_BLOCK_SIZE
;
1221 /* Clear marks on all symbols */
1223 register struct symbol_block
*sblk
;
1224 register int lim
= symbol_block_index
;
1226 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1229 for (i
= 0; i
< lim
; i
++)
1231 XUNMARK (sblk
->symbols
[i
].plist
);
1233 lim
= SYMBOL_BLOCK_SIZE
;
1236 /* Clear marks on all markers */
1238 register struct marker_block
*sblk
;
1239 register int lim
= marker_block_index
;
1241 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1244 for (i
= 0; i
< lim
; i
++)
1245 XUNMARK (sblk
->markers
[i
].chain
);
1246 lim
= MARKER_BLOCK_SIZE
;
1249 /* Clear mark bits on all buffers */
1251 register struct buffer
*nextb
= all_buffers
;
1255 XUNMARK (nextb
->name
);
1256 nextb
= nextb
->next
;
1262 /* Mark reference to a Lisp_Object. If the object referred to
1263 has not been seen yet, recursively mark all the references contained in it.
1265 If the object referenced is a short string, the referrencing slot
1266 is threaded into a chain of such slots, pointed to from
1267 the `size' field of the string. The actual string size
1268 lives in the last slot in the chain. We recognize the end
1269 because it is < (unsigned) STRING_BLOCK_SIZE. */
1272 mark_object (objptr
)
1273 Lisp_Object
*objptr
;
1275 register Lisp_Object obj
;
1282 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1283 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1286 #ifdef SWITCH_ENUM_BUG
1287 switch ((int) XGCTYPE (obj
))
1289 switch (XGCTYPE (obj
))
1294 register struct Lisp_String
*ptr
= XSTRING (obj
);
1296 if (ptr
->size
& MARKBIT
)
1297 /* A large string. Just set ARRAY_MARK_FLAG. */
1298 ptr
->size
|= ARRAY_MARK_FLAG
;
1301 /* A small string. Put this reference
1302 into the chain of references to it.
1303 The address OBJPTR is even, so if the address
1304 includes MARKBIT, put it in the low bit
1305 when we store OBJPTR into the size field. */
1307 if (XMARKBIT (*objptr
))
1309 XFASTINT (*objptr
) = ptr
->size
;
1313 XFASTINT (*objptr
) = ptr
->size
;
1314 if ((int)objptr
& 1) abort ();
1315 ptr
->size
= (int) objptr
& ~MARKBIT
;
1316 if ((int) objptr
& MARKBIT
)
1325 case Lisp_Window_Configuration
:
1328 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1329 register int size
= ptr
->size
;
1332 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1333 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1334 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1335 mark_object (&ptr
->contents
[i
]);
1342 register struct screen
*ptr
= XSCREEN (obj
);
1343 register int size
= ptr
->size
;
1346 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1347 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1349 mark_object (&ptr
->name
);
1350 mark_object (&ptr
->focus_screen
);
1351 mark_object (&ptr
->width
);
1352 mark_object (&ptr
->height
);
1353 mark_object (&ptr
->selected_window
);
1354 mark_object (&ptr
->minibuffer_window
);
1355 mark_object (&ptr
->param_alist
);
1358 #endif /* MULTI_SCREEN */
1361 case Lisp_Temp_Vector
:
1363 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1364 register int size
= ptr
->size
;
1367 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1368 mark_object (&ptr
->contents
[i
]);
1375 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
1376 struct Lisp_Symbol
*ptrx
;
1378 if (XMARKBIT (ptr
->plist
)) break;
1380 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1381 mark_object (&ptr
->name
);
1382 mark_object ((Lisp_Object
*) &ptr
->value
);
1383 mark_object (&ptr
->function
);
1384 mark_object (&ptr
->plist
);
1388 ptrx
= ptr
; /* Use pf ptrx avoids compiler bug on Sun */
1389 XSETSYMBOL (obj
, ptrx
);
1396 XMARK (XMARKER (obj
)->chain
);
1397 /* DO NOT mark thru the marker's chain.
1398 The buffer's markers chain does not preserve markers from gc;
1399 instead, markers are removed from the chain when they are freed by gc. */
1403 case Lisp_Buffer_Local_Value
:
1404 case Lisp_Some_Buffer_Local_Value
:
1406 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1407 if (XMARKBIT (ptr
->car
)) break;
1409 mark_object (&ptr
->car
);
1415 #ifdef LISP_FLOAT_TYPE
1417 XMARK (XFLOAT (obj
)->type
);
1419 #endif /* LISP_FLOAT_TYPE */
1422 if (!XMARKBIT (XBUFFER (obj
)->name
))
1432 case Lisp_Buffer_Objfwd
:
1433 case Lisp_Internal_Stream
:
1434 /* Don't bother with Lisp_Buffer_Objfwd,
1435 since all markable slots in current buffer marked anyway. */
1436 /* Don't need to do Lisp_Objfwd, since the places they point
1437 are protected with staticpro. */
1445 /* Mark the pointers in a buffer structure. */
1452 register struct buffer
*buffer
= XBUFFER (buf
);
1453 register Lisp_Object
*ptr
;
1455 /* This is the buffer's markbit */
1456 mark_object (&buffer
->name
);
1457 XMARK (buffer
->name
);
1460 mark_object (buffer
->syntax_table
);
1462 /* Mark the various string-pointers in the buffer object.
1463 Since the strings may be relocated, we must mark them
1464 in their actual slots. So gc_sweep must convert each slot
1465 back to an ordinary C pointer. */
1466 XSET (*(Lisp_Object
*)&buffer
->upcase_table
,
1467 Lisp_String
, buffer
->upcase_table
);
1468 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1469 XSET (*(Lisp_Object
*)&buffer
->downcase_table
,
1470 Lisp_String
, buffer
->downcase_table
);
1471 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1473 XSET (*(Lisp_Object
*)&buffer
->sort_table
,
1474 Lisp_String
, buffer
->sort_table
);
1475 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1476 XSET (*(Lisp_Object
*)&buffer
->folding_sort_table
,
1477 Lisp_String
, buffer
->folding_sort_table
);
1478 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1481 for (ptr
= &buffer
->name
+ 1;
1482 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1487 /* Find all structures not marked, and free them. */
1492 total_string_size
= 0;
1495 /* Put all unmarked conses on free list */
1497 register struct cons_block
*cblk
;
1498 register int lim
= cons_block_index
;
1499 register int num_free
= 0, num_used
= 0;
1503 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1506 for (i
= 0; i
< lim
; i
++)
1507 if (!XMARKBIT (cblk
->conses
[i
].car
))
1509 XFASTINT (cblk
->conses
[i
].car
) = (int) cons_free_list
;
1511 cons_free_list
= &cblk
->conses
[i
];
1516 XUNMARK (cblk
->conses
[i
].car
);
1518 lim
= CONS_BLOCK_SIZE
;
1520 total_conses
= num_used
;
1521 total_free_conses
= num_free
;
1524 #ifdef LISP_FLOAT_TYPE
1525 /* Put all unmarked floats on free list */
1527 register struct float_block
*fblk
;
1528 register int lim
= float_block_index
;
1529 register int num_free
= 0, num_used
= 0;
1531 float_free_list
= 0;
1533 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1536 for (i
= 0; i
< lim
; i
++)
1537 if (!XMARKBIT (fblk
->floats
[i
].type
))
1539 XFASTINT (fblk
->floats
[i
].type
) = (int) float_free_list
;
1541 float_free_list
= &fblk
->floats
[i
];
1546 XUNMARK (fblk
->floats
[i
].type
);
1548 lim
= FLOAT_BLOCK_SIZE
;
1550 total_floats
= num_used
;
1551 total_free_floats
= num_free
;
1553 #endif /* LISP_FLOAT_TYPE */
1555 /* Put all unmarked symbols on free list */
1557 register struct symbol_block
*sblk
;
1558 register int lim
= symbol_block_index
;
1559 register int num_free
= 0, num_used
= 0;
1561 symbol_free_list
= 0;
1563 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1566 for (i
= 0; i
< lim
; i
++)
1567 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1569 XFASTINT (sblk
->symbols
[i
].value
) = (int) symbol_free_list
;
1570 symbol_free_list
= &sblk
->symbols
[i
];
1576 sblk
->symbols
[i
].name
1577 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1578 XUNMARK (sblk
->symbols
[i
].plist
);
1580 lim
= SYMBOL_BLOCK_SIZE
;
1582 total_symbols
= num_used
;
1583 total_free_symbols
= num_free
;
1587 /* Put all unmarked markers on free list.
1588 Dechain each one first from the buffer it points into. */
1590 register struct marker_block
*mblk
;
1591 struct Lisp_Marker
*tem1
;
1592 register int lim
= marker_block_index
;
1593 register int num_free
= 0, num_used
= 0;
1595 marker_free_list
= 0;
1597 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1600 for (i
= 0; i
< lim
; i
++)
1601 if (!XMARKBIT (mblk
->markers
[i
].chain
))
1604 tem1
= &mblk
->markers
[i
]; /* tem1 avoids Sun compiler bug */
1605 XSET (tem
, Lisp_Marker
, tem1
);
1606 unchain_marker (tem
);
1607 XFASTINT (mblk
->markers
[i
].chain
) = (int) marker_free_list
;
1608 marker_free_list
= &mblk
->markers
[i
];
1614 XUNMARK (mblk
->markers
[i
].chain
);
1616 lim
= MARKER_BLOCK_SIZE
;
1619 total_markers
= num_used
;
1620 total_free_markers
= num_free
;
1623 /* Free all unmarked buffers */
1625 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1628 if (!XMARKBIT (buffer
->name
))
1631 prev
->next
= buffer
->next
;
1633 all_buffers
= buffer
->next
;
1634 next
= buffer
->next
;
1640 XUNMARK (buffer
->name
);
1643 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1644 for purposes of marking and relocation.
1645 Turn them back into C pointers now. */
1646 buffer
->upcase_table
1647 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
1648 buffer
->downcase_table
1649 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
1651 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
1652 buffer
->folding_sort_table
1653 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
1656 prev
= buffer
, buffer
= buffer
->next
;
1660 #endif /* standalone */
1662 /* Free all unmarked vectors */
1664 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
1665 total_vector_size
= 0;
1668 if (!(vector
->size
& ARRAY_MARK_FLAG
))
1671 prev
->next
= vector
->next
;
1673 all_vectors
= vector
->next
;
1674 next
= vector
->next
;
1680 vector
->size
&= ~ARRAY_MARK_FLAG
;
1681 total_vector_size
+= vector
->size
;
1682 prev
= vector
, vector
= vector
->next
;
1686 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
1688 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
1691 if (!(((struct Lisp_String
*)(&sb
->chars
[0]))->size
& ARRAY_MARK_FLAG
))
1694 prev
->next
= sb
->next
;
1696 large_string_blocks
= sb
->next
;
1703 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
1704 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
1705 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
1706 prev
= sb
, sb
= sb
->next
;
1711 /* Compactify strings, relocate references to them, and
1712 free any string blocks that become empty. */
1717 /* String block of old strings we are scanning. */
1718 register struct string_block
*from_sb
;
1719 /* A preceding string block (or maybe the same one)
1720 where we are copying the still-live strings to. */
1721 register struct string_block
*to_sb
;
1725 to_sb
= first_string_block
;
1728 /* Scan each existing string block sequentially, string by string. */
1729 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
1732 /* POS is the index of the next string in the block. */
1733 while (pos
< from_sb
->pos
)
1735 register struct Lisp_String
*nextstr
1736 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
1738 register struct Lisp_String
*newaddr
;
1739 register int size
= nextstr
->size
;
1741 /* NEXTSTR is the old address of the next string.
1742 Just skip it if it isn't marked. */
1743 if ((unsigned) size
> STRING_BLOCK_SIZE
)
1745 /* It is marked, so its size field is really a chain of refs.
1746 Find the end of the chain, where the actual size lives. */
1747 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1749 if (size
& 1) size
^= MARKBIT
| 1;
1750 size
= *(int *)size
& ~MARKBIT
;
1753 total_string_size
+= size
;
1755 /* If it won't fit in TO_SB, close it out,
1756 and move to the next sb. Keep doing so until
1757 TO_SB reaches a large enough, empty enough string block.
1758 We know that TO_SB cannot advance past FROM_SB here
1759 since FROM_SB is large enough to contain this string.
1760 Any string blocks skipped here
1761 will be patched out and freed later. */
1762 while (to_pos
+ STRING_FULLSIZE (size
)
1763 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
1765 to_sb
->pos
= to_pos
;
1766 to_sb
= to_sb
->next
;
1769 /* Compute new address of this string
1770 and update TO_POS for the space being used. */
1771 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
1772 to_pos
+= STRING_FULLSIZE (size
);
1774 /* Copy the string itself to the new place. */
1775 if (nextstr
!= newaddr
)
1776 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (int));
1778 /* Go through NEXTSTR's chain of references
1779 and make each slot in the chain point to
1780 the new address of this string. */
1781 size
= newaddr
->size
;
1782 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1784 register Lisp_Object
*objptr
;
1785 if (size
& 1) size
^= MARKBIT
| 1;
1786 objptr
= (Lisp_Object
*)size
;
1788 size
= XFASTINT (*objptr
) & ~MARKBIT
;
1789 if (XMARKBIT (*objptr
))
1791 XSET (*objptr
, Lisp_String
, newaddr
);
1795 XSET (*objptr
, Lisp_String
, newaddr
);
1797 /* Store the actual size in the size field. */
1798 newaddr
->size
= size
;
1800 pos
+= STRING_FULLSIZE (size
);
1804 /* Close out the last string block still used and free any that follow. */
1805 to_sb
->pos
= to_pos
;
1806 current_string_block
= to_sb
;
1808 from_sb
= to_sb
->next
;
1812 to_sb
= from_sb
->next
;
1817 /* Free any empty string blocks further back in the chain.
1818 This loop will never free first_string_block, but it is very
1819 unlikely that that one will become empty, so why bother checking? */
1821 from_sb
= first_string_block
;
1822 while (to_sb
= from_sb
->next
)
1824 if (to_sb
->pos
== 0)
1826 if (from_sb
->next
= to_sb
->next
)
1827 from_sb
->next
->prev
= from_sb
;
1835 /* Initialization */
1839 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
1842 pure_size
= PURESIZE
;
1845 ignore_warnings
= 1;
1850 #ifdef LISP_FLOAT_TYPE
1852 #endif /* LISP_FLOAT_TYPE */
1853 ignore_warnings
= 0;
1856 consing_since_gc
= 0;
1857 gc_cons_threshold
= 100000;
1858 #ifdef VIRT_ADDR_VARIES
1859 malloc_sbrk_unused
= 1<<22; /* A large number */
1860 malloc_sbrk_used
= 100000; /* as reasonable as any number */
1861 #endif /* VIRT_ADDR_VARIES */
1872 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
1873 "*Number of bytes of consing between garbage collections.\n\
1874 Garbage collection can happen automatically once this many bytes have been\n\
1875 allocated since the last garbage collection. All data types count.\n\n\
1876 Garbage collection happens automatically only when `eval' is called.\n\n\
1877 By binding this temporarily to a large number, you can effectively\n\
1878 prevent garbage collection during a part of the program.");
1880 DEFVAR_INT ("pure-bytes-used", &pureptr
,
1881 "Number of bytes of sharable Lisp data allocated so far.");
1884 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
1885 "Number of bytes of unshared memory allocated in this session.");
1887 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
1888 "Number of bytes of unshared memory remaining available in this session.");
1891 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
1892 "Non-nil means loading Lisp code in order to dump an executable.\n\
1893 This means that certain objects should be allocated in shared (pure) space.");
1895 DEFVAR_INT ("undo-threshold", &undo_threshold
,
1896 "Keep no more undo information once it exceeds this size.\n\
1897 This threshold is applied when garbage collection happens.\n\
1898 The size is counted as the number of bytes occupied,\n\
1899 which includes both saved text and other data.");
1900 undo_threshold
= 20000;
1902 DEFVAR_INT ("undo-high-threshold", &undo_high_threshold
,
1903 "Don't keep more than this much size of undo information.\n\
1904 A command which pushes past this size is itself forgotten.\n\
1905 This threshold is applied when garbage collection happens.\n\
1906 The size is counted as the number of bytes occupied,\n\
1907 which includes both saved text and other data.");
1908 undo_high_threshold
= 30000;
1913 defsubr (&Smake_byte_code
);
1914 defsubr (&Smake_list
);
1915 defsubr (&Smake_vector
);
1916 defsubr (&Smake_string
);
1917 defsubr (&Smake_rope
);
1918 defsubr (&Srope_elt
);
1919 defsubr (&Smake_symbol
);
1920 defsubr (&Smake_marker
);
1921 defsubr (&Spurecopy
);
1922 defsubr (&Sgarbage_collect
);