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_FRAME */
32 #include "syssignal.h"
34 #define max(A,B) ((A) > (B) ? (A) : (B))
36 /* Macro to verify that storage intended for Lisp objects is not
37 out of range to fit in the space for a pointer.
38 ADDRESS is the start of the block, and SIZE
39 is the amount of space within which objects can start. */
40 #define VALIDATE_LISP_STORAGE(address, size) \
44 XSET (val, Lisp_Cons, (char *) address + size); \
45 if ((char *) XCONS (val) != (char *) address + size) \
52 /* Number of bytes of consing done since the last gc */
55 /* Number of bytes of consing since gc before another gc should be done. */
56 int gc_cons_threshold
;
58 /* Nonzero during gc */
61 #ifndef VIRT_ADDR_VARIES
63 #endif /* VIRT_ADDR_VARIES */
66 #ifndef VIRT_ADDR_VARIES
68 #endif /* VIRT_ADDR_VARIES */
69 int malloc_sbrk_unused
;
71 /* Two limits controlling how much undo information to keep. */
73 int undo_strong_limit
;
75 /* Non-nil means defun should do purecopy on the function definition */
76 Lisp_Object Vpurify_flag
;
79 int pure
[PURESIZE
/ sizeof (int)] = {0,}; /* Force it into data space! */
80 #define PUREBEG (char *) pure
82 #define pure PURE_SEG_BITS /* Use shared memory segment */
83 #define PUREBEG (char *)PURE_SEG_BITS
85 /* This variable is used only by the XPNTR macro when HAVE_SHM is
86 defined. If we used the PURESIZE macro directly there, that would
87 make most of emacs dependent on puresize.h, which we don't want -
88 you should be able to change that without too much recompilation.
89 So map_in_data initializes pure_size, and the dependencies work
92 #endif /* not HAVE_SHM */
94 /* Index in pure at which next pure object will be allocated. */
97 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
98 char *pending_malloc_warning
;
100 /* Maximum amount of C stack to save when a GC happens. */
102 #ifndef MAX_SAVE_STACK
103 #define MAX_SAVE_STACK 16000
106 /* Buffer in which we save a copy of the C stack at each GC. */
111 /* Non-zero means ignore malloc warnings. Set during initialization. */
115 malloc_warning_1 (str
)
118 Fprinc (str
, Vstandard_output
);
119 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
120 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
121 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
125 /* malloc calls this if it finds we are near exhausting storage */
129 pending_malloc_warning
= str
;
132 display_malloc_warning ()
134 register Lisp_Object val
;
136 val
= build_string (pending_malloc_warning
);
137 pending_malloc_warning
= 0;
138 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
141 /* Called if malloc returns zero */
144 error ("Memory exhausted");
147 /* like malloc and realloc but check for no memory left */
155 val
= (long *) malloc (size
);
157 if (!val
&& size
) memory_full ();
162 xrealloc (block
, size
)
168 /* We must call malloc explicitly when BLOCK is 0, since some
169 reallocs don't do this. */
171 val
= (long *) malloc (size
);
173 val
= (long *) realloc (block
, size
);
175 if (!val
&& size
) memory_full ();
179 #ifdef LISP_FLOAT_TYPE
180 /* Allocation of float cells, just like conses */
181 /* We store float cells inside of float_blocks, allocating a new
182 float_block with malloc whenever necessary. Float cells reclaimed by
183 GC are put on a free list to be reallocated before allocating
184 any new float cells from the latest float_block.
186 Each float_block is just under 1020 bytes long,
187 since malloc really allocates in units of powers of two
188 and uses 4 bytes for its own overhead. */
190 #define FLOAT_BLOCK_SIZE \
191 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
195 struct float_block
*next
;
196 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
199 struct float_block
*float_block
;
200 int float_block_index
;
202 struct Lisp_Float
*float_free_list
;
207 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
208 float_block
->next
= 0;
209 bzero (float_block
->floats
, sizeof float_block
->floats
);
210 float_block_index
= 0;
214 /* Explicitly free a float cell. */
216 struct Lisp_Float
*ptr
;
218 XFASTINT (ptr
->type
) = (int) float_free_list
;
219 float_free_list
= ptr
;
223 make_float (float_value
)
226 register Lisp_Object val
;
230 XSET (val
, Lisp_Float
, float_free_list
);
231 float_free_list
= (struct Lisp_Float
*) XFASTINT (float_free_list
->type
);
235 if (float_block_index
== FLOAT_BLOCK_SIZE
)
237 register struct float_block
*new = (struct float_block
*) malloc (sizeof (struct float_block
));
238 if (!new) memory_full ();
239 VALIDATE_LISP_STORAGE (new, sizeof *new);
240 new->next
= float_block
;
242 float_block_index
= 0;
244 XSET (val
, Lisp_Float
, &float_block
->floats
[float_block_index
++]);
246 XFLOAT (val
)->data
= float_value
;
247 XFLOAT (val
)->type
= 0; /* bug chasing -wsr */
248 consing_since_gc
+= sizeof (struct Lisp_Float
);
252 #endif /* LISP_FLOAT_TYPE */
254 /* Allocation of cons cells */
255 /* We store cons cells inside of cons_blocks, allocating a new
256 cons_block with malloc whenever necessary. Cons cells reclaimed by
257 GC are put on a free list to be reallocated before allocating
258 any new cons cells from the latest cons_block.
260 Each cons_block is just under 1020 bytes long,
261 since malloc really allocates in units of powers of two
262 and uses 4 bytes for its own overhead. */
264 #define CONS_BLOCK_SIZE \
265 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
269 struct cons_block
*next
;
270 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
273 struct cons_block
*cons_block
;
274 int cons_block_index
;
276 struct Lisp_Cons
*cons_free_list
;
281 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
282 cons_block
->next
= 0;
283 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
284 cons_block_index
= 0;
288 /* Explicitly free a cons cell. */
290 struct Lisp_Cons
*ptr
;
292 XFASTINT (ptr
->car
) = (int) cons_free_list
;
293 cons_free_list
= ptr
;
296 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
297 "Create a new cons, give it CAR and CDR as components, and return it.")
299 Lisp_Object car
, cdr
;
301 register Lisp_Object val
;
305 XSET (val
, Lisp_Cons
, cons_free_list
);
306 cons_free_list
= (struct Lisp_Cons
*) XFASTINT (cons_free_list
->car
);
310 if (cons_block_index
== CONS_BLOCK_SIZE
)
312 register struct cons_block
*new = (struct cons_block
*) malloc (sizeof (struct cons_block
));
313 if (!new) memory_full ();
314 VALIDATE_LISP_STORAGE (new, sizeof *new);
315 new->next
= cons_block
;
317 cons_block_index
= 0;
319 XSET (val
, Lisp_Cons
, &cons_block
->conses
[cons_block_index
++]);
321 XCONS (val
)->car
= car
;
322 XCONS (val
)->cdr
= cdr
;
323 consing_since_gc
+= sizeof (struct Lisp_Cons
);
327 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
328 "Return a newly created list with specified arguments as elements.\n\
329 Any number of arguments, even zero arguments, are allowed.")
332 register Lisp_Object
*args
;
334 register Lisp_Object len
, val
, val_tail
;
336 XFASTINT (len
) = nargs
;
337 val
= Fmake_list (len
, Qnil
);
339 while (!NILP (val_tail
))
341 XCONS (val_tail
)->car
= *args
++;
342 val_tail
= XCONS (val_tail
)->cdr
;
347 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
348 "Return a newly created list of length LENGTH, with each element being INIT.")
350 register Lisp_Object length
, init
;
352 register Lisp_Object val
;
355 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
356 length
= wrong_type_argument (Qnatnump
, length
);
357 size
= XINT (length
);
361 val
= Fcons (init
, val
);
365 /* Allocation of vectors */
367 struct Lisp_Vector
*all_vectors
;
369 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
370 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
371 See also the function `vector'.")
373 register Lisp_Object length
, init
;
375 register int sizei
, index
;
376 register Lisp_Object vector
;
377 register struct Lisp_Vector
*p
;
379 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
380 length
= wrong_type_argument (Qnatnump
, length
);
381 sizei
= XINT (length
);
383 p
= (struct Lisp_Vector
*) malloc (sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
));
386 VALIDATE_LISP_STORAGE (p
, 0);
388 XSET (vector
, Lisp_Vector
, p
);
389 consing_since_gc
+= sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
);
392 p
->next
= all_vectors
;
395 for (index
= 0; index
< sizei
; index
++)
396 p
->contents
[index
] = init
;
401 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
402 "Return a newly created vector with specified arguments as elements.\n\
403 Any number of arguments, even zero arguments, are allowed.")
408 register Lisp_Object len
, val
;
410 register struct Lisp_Vector
*p
;
412 XFASTINT (len
) = nargs
;
413 val
= Fmake_vector (len
, Qnil
);
415 for (index
= 0; index
< nargs
; index
++)
416 p
->contents
[index
] = args
[index
];
420 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
421 "Create a byte-code object with specified arguments as elements.\n\
422 The arguments should be the arglist, bytecode-string, constant vector,\n\
423 stack size, (optional) doc string, and (optional) interactive spec.\n\
424 The first four arguments are required; at most six have any\n\
430 register Lisp_Object len
, val
;
432 register struct Lisp_Vector
*p
;
434 XFASTINT (len
) = nargs
;
435 if (!NILP (Vpurify_flag
))
436 val
= make_pure_vector (len
);
438 val
= Fmake_vector (len
, Qnil
);
440 for (index
= 0; index
< nargs
; index
++)
442 if (!NILP (Vpurify_flag
))
443 args
[index
] = Fpurecopy (args
[index
]);
444 p
->contents
[index
] = args
[index
];
446 XSETTYPE (val
, Lisp_Compiled
);
450 /* Allocation of symbols.
451 Just like allocation of conses!
453 Each symbol_block is just under 1020 bytes long,
454 since malloc really allocates in units of powers of two
455 and uses 4 bytes for its own overhead. */
457 #define SYMBOL_BLOCK_SIZE \
458 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
462 struct symbol_block
*next
;
463 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
466 struct symbol_block
*symbol_block
;
467 int symbol_block_index
;
469 struct Lisp_Symbol
*symbol_free_list
;
474 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
475 symbol_block
->next
= 0;
476 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
477 symbol_block_index
= 0;
478 symbol_free_list
= 0;
481 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
482 "Return a newly allocated uninterned symbol whose name is NAME.\n\
483 Its value and function definition are void, and its property list is nil.")
487 register Lisp_Object val
;
488 register struct Lisp_Symbol
*p
;
490 CHECK_STRING (str
, 0);
492 if (symbol_free_list
)
494 XSET (val
, Lisp_Symbol
, symbol_free_list
);
496 = (struct Lisp_Symbol
*) XFASTINT (symbol_free_list
->value
);
500 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
502 struct symbol_block
*new = (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
503 if (!new) memory_full ();
504 VALIDATE_LISP_STORAGE (new, sizeof *new);
505 new->next
= symbol_block
;
507 symbol_block_index
= 0;
509 XSET (val
, Lisp_Symbol
, &symbol_block
->symbols
[symbol_block_index
++]);
512 p
->name
= XSTRING (str
);
515 p
->function
= Qunbound
;
517 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
521 /* Allocation of markers.
522 Works like allocation of conses. */
524 #define MARKER_BLOCK_SIZE \
525 ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker))
529 struct marker_block
*next
;
530 struct Lisp_Marker markers
[MARKER_BLOCK_SIZE
];
533 struct marker_block
*marker_block
;
534 int marker_block_index
;
536 struct Lisp_Marker
*marker_free_list
;
541 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
542 marker_block
->next
= 0;
543 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
544 marker_block_index
= 0;
545 marker_free_list
= 0;
548 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
549 "Return a newly allocated marker which does not point at any place.")
552 register Lisp_Object val
;
553 register struct Lisp_Marker
*p
;
555 if (marker_free_list
)
557 XSET (val
, Lisp_Marker
, marker_free_list
);
559 = (struct Lisp_Marker
*) XFASTINT (marker_free_list
->chain
);
563 if (marker_block_index
== MARKER_BLOCK_SIZE
)
565 struct marker_block
*new = (struct marker_block
*) malloc (sizeof (struct marker_block
));
566 if (!new) memory_full ();
567 VALIDATE_LISP_STORAGE (new, sizeof *new);
568 new->next
= marker_block
;
570 marker_block_index
= 0;
572 XSET (val
, Lisp_Marker
, &marker_block
->markers
[marker_block_index
++]);
578 consing_since_gc
+= sizeof (struct Lisp_Marker
);
582 /* Allocation of strings */
584 /* Strings reside inside of string_blocks. The entire data of the string,
585 both the size and the contents, live in part of the `chars' component of a string_block.
586 The `pos' component is the index within `chars' of the first free byte.
588 first_string_block points to the first string_block ever allocated.
589 Each block points to the next one with its `next' field.
590 The `prev' fields chain in reverse order.
591 The last one allocated is the one currently being filled.
592 current_string_block points to it.
594 The string_blocks that hold individual large strings
595 go in a separate chain, started by large_string_blocks. */
598 /* String blocks contain this many useful bytes.
599 8188 is power of 2, minus 4 for malloc overhead. */
600 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
602 /* A string bigger than this gets its own specially-made string block
603 if it doesn't fit in the current one. */
604 #define STRING_BLOCK_OUTSIZE 1024
606 struct string_block_head
608 struct string_block
*next
, *prev
;
614 struct string_block
*next
, *prev
;
616 char chars
[STRING_BLOCK_SIZE
];
619 /* This points to the string block we are now allocating strings. */
621 struct string_block
*current_string_block
;
623 /* This points to the oldest string block, the one that starts the chain. */
625 struct string_block
*first_string_block
;
627 /* Last string block in chain of those made for individual large strings. */
629 struct string_block
*large_string_blocks
;
631 /* If SIZE is the length of a string, this returns how many bytes
632 the string occupies in a string_block (including padding). */
634 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
636 #define PAD (sizeof (int))
639 #define STRING_FULLSIZE(SIZE) \
640 (((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1))
646 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
647 first_string_block
= current_string_block
;
648 consing_since_gc
+= sizeof (struct string_block
);
649 current_string_block
->next
= 0;
650 current_string_block
->prev
= 0;
651 current_string_block
->pos
= 0;
652 large_string_blocks
= 0;
655 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
656 "Return a newly created string of length LENGTH, with each element being INIT.\n\
657 Both LENGTH and INIT must be numbers.")
659 Lisp_Object length
, init
;
661 register Lisp_Object val
;
662 register unsigned char *p
, *end
, c
;
664 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
665 length
= wrong_type_argument (Qnatnump
, length
);
666 CHECK_NUMBER (init
, 1);
667 val
= make_uninit_string (XINT (length
));
669 p
= XSTRING (val
)->data
;
670 end
= p
+ XSTRING (val
)->size
;
678 make_string (contents
, length
)
682 register Lisp_Object val
;
683 val
= make_uninit_string (length
);
684 bcopy (contents
, XSTRING (val
)->data
, length
);
692 return make_string (str
, strlen (str
));
696 make_uninit_string (length
)
699 register Lisp_Object val
;
700 register int fullsize
= STRING_FULLSIZE (length
);
702 if (length
< 0) abort ();
704 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
705 /* This string can fit in the current string block */
707 XSET (val
, Lisp_String
,
708 (struct Lisp_String
*) (current_string_block
->chars
+ current_string_block
->pos
));
709 current_string_block
->pos
+= fullsize
;
711 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
712 /* This string gets its own string block */
714 register struct string_block
*new
715 = (struct string_block
*) malloc (sizeof (struct string_block_head
) + fullsize
);
716 VALIDATE_LISP_STORAGE (new, 0);
717 if (!new) memory_full ();
718 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
720 new->next
= large_string_blocks
;
721 large_string_blocks
= new;
722 XSET (val
, Lisp_String
,
723 (struct Lisp_String
*) ((struct string_block_head
*)new + 1));
726 /* Make a new current string block and start it off with this string */
728 register struct string_block
*new
729 = (struct string_block
*) malloc (sizeof (struct string_block
));
730 if (!new) memory_full ();
731 VALIDATE_LISP_STORAGE (new, sizeof *new);
732 consing_since_gc
+= sizeof (struct string_block
);
733 current_string_block
->next
= new;
734 new->prev
= current_string_block
;
736 current_string_block
= new;
738 XSET (val
, Lisp_String
,
739 (struct Lisp_String
*) current_string_block
->chars
);
742 XSTRING (val
)->size
= length
;
743 XSTRING (val
)->data
[length
] = 0;
748 /* Return a newly created vector or string with specified arguments as
749 elements. If all the arguments are characters, make a string;
750 otherwise, make a vector. Any number of arguments, even zero
751 arguments, are allowed. */
754 make_array (nargs
, args
)
760 for (i
= 0; i
< nargs
; i
++)
761 if (XTYPE (args
[i
]) != Lisp_Int
762 || (unsigned) XINT (args
[i
]) >= 0400)
763 return Fvector (nargs
, args
);
765 /* Since the loop exited, we know that all the things in it are
766 characters, so we can make a string. */
768 Lisp_Object result
= Fmake_string (nargs
, make_number (0));
770 for (i
= 0; i
< nargs
; i
++)
771 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
777 /* Note: the user cannot manipulate ropes portably by referring
778 to the chars of the string, because combining two chars to make a GLYPH
779 depends on endianness. */
781 DEFUN ("make-rope", Fmake_rope
, Smake_rope
, 0, MANY
, 0,
782 "Return a newly created rope containing the arguments of this function.\n\
783 A rope is a string, except that its contents will be treated as an\n\
784 array of glyphs, where a glyph is an integer type that may be larger\n\
785 than a character. Emacs is normally configured to use 8-bit glyphs,\n\
786 so ropes are normally no different from strings. But Emacs may be\n\
787 configured to use 16-bit glyphs, to allow the use of larger fonts.\n\
789 Each argument (which must be an integer) specifies one glyph, whatever\n\
790 size glyphs may be.\n\
792 See variable `buffer-display-table' for the uses of ropes.")
798 register Lisp_Object val
;
801 val
= make_uninit_string (nargs
* sizeof (GLYPH
));
803 p
= (GLYPH
*) XSTRING (val
)->data
;
804 for (i
= 0; i
< nargs
; i
++)
806 CHECK_NUMBER (args
[i
], i
);
807 p
[i
] = XFASTINT (args
[i
]);
812 DEFUN ("rope-elt", Frope_elt
, Srope_elt
, 2, 2, 0,
813 "Return an element of rope R at index N.\n\
814 A rope is a string in which each pair of bytes is considered an element.\n\
815 See variable `buffer-display-table' for the uses of ropes.")
820 if ((XSTRING (r
)->size
/ sizeof (GLYPH
)) <= XINT (n
) || XINT (n
) < 0)
821 args_out_of_range (r
, n
);
822 return ((GLYPH
*) XSTRING (r
)->data
)[XFASTINT (n
)];
825 /* Must get an error if pure storage is full,
826 since if it cannot hold a large string
827 it may be able to hold conses that point to that string;
828 then the string is not protected from gc. */
831 make_pure_string (data
, length
)
835 register Lisp_Object
new;
836 register int size
= sizeof (int) + length
+ 1;
838 if (pureptr
+ size
> PURESIZE
)
839 error ("Pure Lisp storage exhausted");
840 XSET (new, Lisp_String
, PUREBEG
+ pureptr
);
841 XSTRING (new)->size
= length
;
842 bcopy (data
, XSTRING (new)->data
, length
);
843 XSTRING (new)->data
[length
] = 0;
844 pureptr
+= (size
+ sizeof (int) - 1)
845 / sizeof (int) * sizeof (int);
851 Lisp_Object car
, cdr
;
853 register Lisp_Object
new;
855 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
856 error ("Pure Lisp storage exhausted");
857 XSET (new, Lisp_Cons
, PUREBEG
+ pureptr
);
858 pureptr
+= sizeof (struct Lisp_Cons
);
859 XCONS (new)->car
= Fpurecopy (car
);
860 XCONS (new)->cdr
= Fpurecopy (cdr
);
864 #ifdef LISP_FLOAT_TYPE
867 make_pure_float (num
)
870 register Lisp_Object
new;
872 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
873 error ("Pure Lisp storage exhausted");
874 XSET (new, Lisp_Float
, PUREBEG
+ pureptr
);
875 pureptr
+= sizeof (struct Lisp_Float
);
876 XFLOAT (new)->data
= num
;
877 XFLOAT (new)->type
= 0; /* bug chasing -wsr */
881 #endif /* LISP_FLOAT_TYPE */
884 make_pure_vector (len
)
887 register Lisp_Object
new;
888 register int size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
890 if (pureptr
+ size
> PURESIZE
)
891 error ("Pure Lisp storage exhausted");
893 XSET (new, Lisp_Vector
, PUREBEG
+ pureptr
);
895 XVECTOR (new)->size
= len
;
899 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
900 "Make a copy of OBJECT in pure storage.\n\
901 Recursively copies contents of vectors and cons cells.\n\
902 Does not copy symbols.")
904 register Lisp_Object obj
;
906 register Lisp_Object
new, tem
;
909 if (NILP (Vpurify_flag
))
912 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
913 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
916 #ifdef SWITCH_ENUM_BUG
917 switch ((int) XTYPE (obj
))
923 error ("Attempt to copy a marker to pure storage");
926 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
928 #ifdef LISP_FLOAT_TYPE
930 return make_pure_float (XFLOAT (obj
)->data
);
931 #endif /* LISP_FLOAT_TYPE */
934 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
938 new = make_pure_vector (XVECTOR (obj
)->size
);
939 for (i
= 0; i
< XVECTOR (obj
)->size
; i
++)
941 tem
= XVECTOR (obj
)->contents
[i
];
942 XVECTOR (new)->contents
[i
] = Fpurecopy (tem
);
944 XSETTYPE (new, XTYPE (obj
));
952 /* Recording what needs to be marked for gc. */
954 struct gcpro
*gcprolist
;
958 Lisp_Object
*staticvec
[NSTATICS
] = {0};
962 /* Put an entry in staticvec, pointing at the variable whose address is given */
965 staticpro (varaddress
)
966 Lisp_Object
*varaddress
;
968 staticvec
[staticidx
++] = varaddress
;
969 if (staticidx
>= NSTATICS
)
977 struct catchtag
*next
;
978 /* jmp_buf jmp; /* We don't need this for GC purposes */
983 struct backtrace
*next
;
984 Lisp_Object
*function
;
985 Lisp_Object
*args
; /* Points to vector of args. */
986 int nargs
; /* length of vector */
987 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
991 /* Two flags that are set during GC in the `size' component
992 of a string or vector. On some machines, these flags
993 are defined by the m- file to be different bits. */
995 /* On vector, means it has been marked.
996 On string size field or a reference to a string,
997 means not the last reference in the chain. */
999 #ifndef ARRAY_MARK_FLAG
1000 #define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
1001 #endif /* no ARRAY_MARK_FLAG */
1003 /* Any slot that is a Lisp_Object can point to a string
1004 and thus can be put on a string's reference-chain
1005 and thus may need to have its ARRAY_MARK_FLAG set.
1006 This includes the slots whose markbits are used to mark
1007 the containing objects. */
1009 #if ARRAY_MARK_FLAG == MARKBIT
1013 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1014 int total_free_conses
, total_free_markers
, total_free_symbols
;
1015 #ifdef LISP_FLOAT_TYPE
1016 int total_free_floats
, total_floats
;
1017 #endif /* LISP_FLOAT_TYPE */
1019 static void mark_object (), mark_buffer ();
1020 static void clear_marks (), gc_sweep ();
1021 static void compact_strings ();
1023 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1024 "Reclaim storage for Lisp objects no longer needed.\n\
1025 Returns info on amount of space in use:\n\
1026 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1027 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1028 (USED-FLOATS . FREE-FLOATS))\n\
1029 Garbage collection happens automatically if you cons more than\n\
1030 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1033 register struct gcpro
*tail
;
1034 register struct specbinding
*bind
;
1035 struct catchtag
*catch;
1036 struct handler
*handler
;
1037 register struct backtrace
*backlist
;
1038 register Lisp_Object tem
;
1039 char *omessage
= echo_area_glyphs
;
1040 char stack_top_variable
;
1043 /* Save a copy of the contents of the stack, for debugging. */
1044 #if MAX_SAVE_STACK > 0
1045 if (NILP (Vpurify_flag
))
1047 i
= &stack_top_variable
- stack_bottom
;
1049 if (i
< MAX_SAVE_STACK
)
1051 if (stack_copy
== 0)
1052 stack_copy
= (char *) malloc (stack_copy_size
= i
);
1053 else if (stack_copy_size
< i
)
1054 stack_copy
= (char *) realloc (stack_copy
, (stack_copy_size
= i
));
1057 if ((int) (&stack_top_variable
- stack_bottom
) > 0)
1058 bcopy (stack_bottom
, stack_copy
, i
);
1060 bcopy (&stack_top_variable
, stack_copy
, i
);
1064 #endif /* MAX_SAVE_STACK > 0 */
1066 if (!noninteractive
)
1067 message1 ("Garbage collecting...");
1069 /* Don't keep command history around forever */
1070 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1072 XCONS (tem
)->cdr
= Qnil
;
1074 /* Likewise for undo information. */
1076 register struct buffer
*nextb
= all_buffers
;
1080 /* If a buffer's undo list is Qt, that means that undo is
1081 turned off in that buffer. Calling truncate_undo_list on
1082 Qt tends to return NULL, which effectively turns undo back on.
1083 So don't call truncate_undo_list if undo_list is Qt. */
1084 if (! EQ (nextb
->undo_list
, Qt
))
1086 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1088 nextb
= nextb
->next
;
1094 /* clear_marks (); */
1096 /* In each "large string", set the MARKBIT of the size field.
1097 That enables mark_object to recognize them. */
1099 register struct string_block
*b
;
1100 for (b
= large_string_blocks
; b
; b
= b
->next
)
1101 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1104 /* Mark all the special slots that serve as the roots of accessibility.
1106 Usually the special slots to mark are contained in particular structures.
1107 Then we know no slot is marked twice because the structures don't overlap.
1108 In some cases, the structures point to the slots to be marked.
1109 For these, we use MARKBIT to avoid double marking of the slot. */
1111 for (i
= 0; i
< staticidx
; i
++)
1112 mark_object (staticvec
[i
]);
1113 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1114 for (i
= 0; i
< tail
->nvars
; i
++)
1115 if (!XMARKBIT (tail
->var
[i
]))
1117 mark_object (&tail
->var
[i
]);
1118 XMARK (tail
->var
[i
]);
1120 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1122 mark_object (&bind
->symbol
);
1123 mark_object (&bind
->old_value
);
1125 for (catch = catchlist
; catch; catch = catch->next
)
1127 mark_object (&catch->tag
);
1128 mark_object (&catch->val
);
1130 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1132 mark_object (&handler
->handler
);
1133 mark_object (&handler
->var
);
1135 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1137 if (!XMARKBIT (*backlist
->function
))
1139 mark_object (backlist
->function
);
1140 XMARK (*backlist
->function
);
1142 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1145 i
= backlist
->nargs
- 1;
1147 if (!XMARKBIT (backlist
->args
[i
]))
1149 mark_object (&backlist
->args
[i
]);
1150 XMARK (backlist
->args
[i
]);
1156 /* Clear the mark bits that we set in certain root slots. */
1158 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1159 for (i
= 0; i
< tail
->nvars
; i
++)
1160 XUNMARK (tail
->var
[i
]);
1161 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1163 XUNMARK (*backlist
->function
);
1164 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1167 i
= backlist
->nargs
- 1;
1169 XUNMARK (backlist
->args
[i
]);
1171 XUNMARK (buffer_defaults
.name
);
1172 XUNMARK (buffer_local_symbols
.name
);
1174 /* clear_marks (); */
1177 consing_since_gc
= 0;
1178 if (gc_cons_threshold
< 10000)
1179 gc_cons_threshold
= 10000;
1182 message1 (omessage
);
1183 else if (!noninteractive
)
1184 message1 ("Garbage collecting...done");
1186 return Fcons (Fcons (make_number (total_conses
),
1187 make_number (total_free_conses
)),
1188 Fcons (Fcons (make_number (total_symbols
),
1189 make_number (total_free_symbols
)),
1190 Fcons (Fcons (make_number (total_markers
),
1191 make_number (total_free_markers
)),
1192 Fcons (make_number (total_string_size
),
1193 Fcons (make_number (total_vector_size
),
1195 #ifdef LISP_FLOAT_TYPE
1196 Fcons (Fcons (make_number (total_floats
),
1197 make_number (total_free_floats
)),
1199 #else /* not LISP_FLOAT_TYPE */
1201 #endif /* not LISP_FLOAT_TYPE */
1209 /* Clear marks on all conses */
1211 register struct cons_block
*cblk
;
1212 register int lim
= cons_block_index
;
1214 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1217 for (i
= 0; i
< lim
; i
++)
1218 XUNMARK (cblk
->conses
[i
].car
);
1219 lim
= CONS_BLOCK_SIZE
;
1222 /* Clear marks on all symbols */
1224 register struct symbol_block
*sblk
;
1225 register int lim
= symbol_block_index
;
1227 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1230 for (i
= 0; i
< lim
; i
++)
1232 XUNMARK (sblk
->symbols
[i
].plist
);
1234 lim
= SYMBOL_BLOCK_SIZE
;
1237 /* Clear marks on all markers */
1239 register struct marker_block
*sblk
;
1240 register int lim
= marker_block_index
;
1242 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1245 for (i
= 0; i
< lim
; i
++)
1246 XUNMARK (sblk
->markers
[i
].chain
);
1247 lim
= MARKER_BLOCK_SIZE
;
1250 /* Clear mark bits on all buffers */
1252 register struct buffer
*nextb
= all_buffers
;
1256 XUNMARK (nextb
->name
);
1257 nextb
= nextb
->next
;
1263 /* Mark reference to a Lisp_Object. If the object referred to
1264 has not been seen yet, recursively mark all the references contained in it.
1266 If the object referenced is a short string, the referrencing slot
1267 is threaded into a chain of such slots, pointed to from
1268 the `size' field of the string. The actual string size
1269 lives in the last slot in the chain. We recognize the end
1270 because it is < (unsigned) STRING_BLOCK_SIZE. */
1273 mark_object (objptr
)
1274 Lisp_Object
*objptr
;
1276 register Lisp_Object obj
;
1283 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1284 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1287 #ifdef SWITCH_ENUM_BUG
1288 switch ((int) XGCTYPE (obj
))
1290 switch (XGCTYPE (obj
))
1295 register struct Lisp_String
*ptr
= XSTRING (obj
);
1297 if (ptr
->size
& MARKBIT
)
1298 /* A large string. Just set ARRAY_MARK_FLAG. */
1299 ptr
->size
|= ARRAY_MARK_FLAG
;
1302 /* A small string. Put this reference
1303 into the chain of references to it.
1304 The address OBJPTR is even, so if the address
1305 includes MARKBIT, put it in the low bit
1306 when we store OBJPTR into the size field. */
1308 if (XMARKBIT (*objptr
))
1310 XFASTINT (*objptr
) = ptr
->size
;
1314 XFASTINT (*objptr
) = ptr
->size
;
1315 if ((int)objptr
& 1) abort ();
1316 ptr
->size
= (int) objptr
& ~MARKBIT
;
1317 if ((int) objptr
& MARKBIT
)
1326 case Lisp_Window_Configuration
:
1329 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1330 register int size
= ptr
->size
;
1333 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1334 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1335 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1336 mark_object (&ptr
->contents
[i
]);
1343 register struct frame
*ptr
= XFRAME (obj
);
1344 register int size
= ptr
->size
;
1347 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1348 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1350 mark_object (&ptr
->name
);
1351 mark_object (&ptr
->focus_frame
);
1352 mark_object (&ptr
->width
);
1353 mark_object (&ptr
->height
);
1354 mark_object (&ptr
->selected_window
);
1355 mark_object (&ptr
->minibuffer_window
);
1356 mark_object (&ptr
->param_alist
);
1359 #endif /* not MULTI_FRAME */
1362 case Lisp_Temp_Vector
:
1364 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1365 register int size
= ptr
->size
;
1368 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1369 mark_object (&ptr
->contents
[i
]);
1376 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
1377 struct Lisp_Symbol
*ptrx
;
1379 if (XMARKBIT (ptr
->plist
)) break;
1381 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1382 mark_object (&ptr
->name
);
1383 mark_object ((Lisp_Object
*) &ptr
->value
);
1384 mark_object (&ptr
->function
);
1385 mark_object (&ptr
->plist
);
1389 ptrx
= ptr
; /* Use pf ptrx avoids compiler bug on Sun */
1390 XSETSYMBOL (obj
, ptrx
);
1397 XMARK (XMARKER (obj
)->chain
);
1398 /* DO NOT mark thru the marker's chain.
1399 The buffer's markers chain does not preserve markers from gc;
1400 instead, markers are removed from the chain when they are freed by gc. */
1404 case Lisp_Buffer_Local_Value
:
1405 case Lisp_Some_Buffer_Local_Value
:
1407 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1408 if (XMARKBIT (ptr
->car
)) break;
1410 mark_object (&ptr
->car
);
1416 #ifdef LISP_FLOAT_TYPE
1418 XMARK (XFLOAT (obj
)->type
);
1420 #endif /* LISP_FLOAT_TYPE */
1423 if (!XMARKBIT (XBUFFER (obj
)->name
))
1433 case Lisp_Buffer_Objfwd
:
1434 case Lisp_Internal_Stream
:
1435 /* Don't bother with Lisp_Buffer_Objfwd,
1436 since all markable slots in current buffer marked anyway. */
1437 /* Don't need to do Lisp_Objfwd, since the places they point
1438 are protected with staticpro. */
1446 /* Mark the pointers in a buffer structure. */
1453 register struct buffer
*buffer
= XBUFFER (buf
);
1454 register Lisp_Object
*ptr
;
1456 /* This is the buffer's markbit */
1457 mark_object (&buffer
->name
);
1458 XMARK (buffer
->name
);
1461 mark_object (buffer
->syntax_table
);
1463 /* Mark the various string-pointers in the buffer object.
1464 Since the strings may be relocated, we must mark them
1465 in their actual slots. So gc_sweep must convert each slot
1466 back to an ordinary C pointer. */
1467 XSET (*(Lisp_Object
*)&buffer
->upcase_table
,
1468 Lisp_String
, buffer
->upcase_table
);
1469 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1470 XSET (*(Lisp_Object
*)&buffer
->downcase_table
,
1471 Lisp_String
, buffer
->downcase_table
);
1472 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1474 XSET (*(Lisp_Object
*)&buffer
->sort_table
,
1475 Lisp_String
, buffer
->sort_table
);
1476 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1477 XSET (*(Lisp_Object
*)&buffer
->folding_sort_table
,
1478 Lisp_String
, buffer
->folding_sort_table
);
1479 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1482 for (ptr
= &buffer
->name
+ 1;
1483 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1488 /* Find all structures not marked, and free them. */
1493 total_string_size
= 0;
1496 /* Put all unmarked conses on free list */
1498 register struct cons_block
*cblk
;
1499 register int lim
= cons_block_index
;
1500 register int num_free
= 0, num_used
= 0;
1504 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1507 for (i
= 0; i
< lim
; i
++)
1508 if (!XMARKBIT (cblk
->conses
[i
].car
))
1510 XFASTINT (cblk
->conses
[i
].car
) = (int) cons_free_list
;
1512 cons_free_list
= &cblk
->conses
[i
];
1517 XUNMARK (cblk
->conses
[i
].car
);
1519 lim
= CONS_BLOCK_SIZE
;
1521 total_conses
= num_used
;
1522 total_free_conses
= num_free
;
1525 #ifdef LISP_FLOAT_TYPE
1526 /* Put all unmarked floats on free list */
1528 register struct float_block
*fblk
;
1529 register int lim
= float_block_index
;
1530 register int num_free
= 0, num_used
= 0;
1532 float_free_list
= 0;
1534 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1537 for (i
= 0; i
< lim
; i
++)
1538 if (!XMARKBIT (fblk
->floats
[i
].type
))
1540 XFASTINT (fblk
->floats
[i
].type
) = (int) float_free_list
;
1542 float_free_list
= &fblk
->floats
[i
];
1547 XUNMARK (fblk
->floats
[i
].type
);
1549 lim
= FLOAT_BLOCK_SIZE
;
1551 total_floats
= num_used
;
1552 total_free_floats
= num_free
;
1554 #endif /* LISP_FLOAT_TYPE */
1556 /* Put all unmarked symbols on free list */
1558 register struct symbol_block
*sblk
;
1559 register int lim
= symbol_block_index
;
1560 register int num_free
= 0, num_used
= 0;
1562 symbol_free_list
= 0;
1564 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1567 for (i
= 0; i
< lim
; i
++)
1568 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1570 XFASTINT (sblk
->symbols
[i
].value
) = (int) symbol_free_list
;
1571 symbol_free_list
= &sblk
->symbols
[i
];
1577 sblk
->symbols
[i
].name
1578 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1579 XUNMARK (sblk
->symbols
[i
].plist
);
1581 lim
= SYMBOL_BLOCK_SIZE
;
1583 total_symbols
= num_used
;
1584 total_free_symbols
= num_free
;
1588 /* Put all unmarked markers on free list.
1589 Dechain each one first from the buffer it points into. */
1591 register struct marker_block
*mblk
;
1592 struct Lisp_Marker
*tem1
;
1593 register int lim
= marker_block_index
;
1594 register int num_free
= 0, num_used
= 0;
1596 marker_free_list
= 0;
1598 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1601 for (i
= 0; i
< lim
; i
++)
1602 if (!XMARKBIT (mblk
->markers
[i
].chain
))
1605 tem1
= &mblk
->markers
[i
]; /* tem1 avoids Sun compiler bug */
1606 XSET (tem
, Lisp_Marker
, tem1
);
1607 unchain_marker (tem
);
1608 XFASTINT (mblk
->markers
[i
].chain
) = (int) marker_free_list
;
1609 marker_free_list
= &mblk
->markers
[i
];
1615 XUNMARK (mblk
->markers
[i
].chain
);
1617 lim
= MARKER_BLOCK_SIZE
;
1620 total_markers
= num_used
;
1621 total_free_markers
= num_free
;
1624 /* Free all unmarked buffers */
1626 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1629 if (!XMARKBIT (buffer
->name
))
1632 prev
->next
= buffer
->next
;
1634 all_buffers
= buffer
->next
;
1635 next
= buffer
->next
;
1641 XUNMARK (buffer
->name
);
1644 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1645 for purposes of marking and relocation.
1646 Turn them back into C pointers now. */
1647 buffer
->upcase_table
1648 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
1649 buffer
->downcase_table
1650 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
1652 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
1653 buffer
->folding_sort_table
1654 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
1657 prev
= buffer
, buffer
= buffer
->next
;
1661 #endif /* standalone */
1663 /* Free all unmarked vectors */
1665 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
1666 total_vector_size
= 0;
1669 if (!(vector
->size
& ARRAY_MARK_FLAG
))
1672 prev
->next
= vector
->next
;
1674 all_vectors
= vector
->next
;
1675 next
= vector
->next
;
1681 vector
->size
&= ~ARRAY_MARK_FLAG
;
1682 total_vector_size
+= vector
->size
;
1683 prev
= vector
, vector
= vector
->next
;
1687 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
1689 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
1692 if (!(((struct Lisp_String
*)(&sb
->chars
[0]))->size
& ARRAY_MARK_FLAG
))
1695 prev
->next
= sb
->next
;
1697 large_string_blocks
= sb
->next
;
1704 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
1705 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
1706 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
1707 prev
= sb
, sb
= sb
->next
;
1712 /* Compactify strings, relocate references to them, and
1713 free any string blocks that become empty. */
1718 /* String block of old strings we are scanning. */
1719 register struct string_block
*from_sb
;
1720 /* A preceding string block (or maybe the same one)
1721 where we are copying the still-live strings to. */
1722 register struct string_block
*to_sb
;
1726 to_sb
= first_string_block
;
1729 /* Scan each existing string block sequentially, string by string. */
1730 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
1733 /* POS is the index of the next string in the block. */
1734 while (pos
< from_sb
->pos
)
1736 register struct Lisp_String
*nextstr
1737 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
1739 register struct Lisp_String
*newaddr
;
1740 register int size
= nextstr
->size
;
1742 /* NEXTSTR is the old address of the next string.
1743 Just skip it if it isn't marked. */
1744 if ((unsigned) size
> STRING_BLOCK_SIZE
)
1746 /* It is marked, so its size field is really a chain of refs.
1747 Find the end of the chain, where the actual size lives. */
1748 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1750 if (size
& 1) size
^= MARKBIT
| 1;
1751 size
= *(int *)size
& ~MARKBIT
;
1754 total_string_size
+= size
;
1756 /* If it won't fit in TO_SB, close it out,
1757 and move to the next sb. Keep doing so until
1758 TO_SB reaches a large enough, empty enough string block.
1759 We know that TO_SB cannot advance past FROM_SB here
1760 since FROM_SB is large enough to contain this string.
1761 Any string blocks skipped here
1762 will be patched out and freed later. */
1763 while (to_pos
+ STRING_FULLSIZE (size
)
1764 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
1766 to_sb
->pos
= to_pos
;
1767 to_sb
= to_sb
->next
;
1770 /* Compute new address of this string
1771 and update TO_POS for the space being used. */
1772 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
1773 to_pos
+= STRING_FULLSIZE (size
);
1775 /* Copy the string itself to the new place. */
1776 if (nextstr
!= newaddr
)
1777 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (int));
1779 /* Go through NEXTSTR's chain of references
1780 and make each slot in the chain point to
1781 the new address of this string. */
1782 size
= newaddr
->size
;
1783 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1785 register Lisp_Object
*objptr
;
1786 if (size
& 1) size
^= MARKBIT
| 1;
1787 objptr
= (Lisp_Object
*)size
;
1789 size
= XFASTINT (*objptr
) & ~MARKBIT
;
1790 if (XMARKBIT (*objptr
))
1792 XSET (*objptr
, Lisp_String
, newaddr
);
1796 XSET (*objptr
, Lisp_String
, newaddr
);
1798 /* Store the actual size in the size field. */
1799 newaddr
->size
= size
;
1801 pos
+= STRING_FULLSIZE (size
);
1805 /* Close out the last string block still used and free any that follow. */
1806 to_sb
->pos
= to_pos
;
1807 current_string_block
= to_sb
;
1809 from_sb
= to_sb
->next
;
1813 to_sb
= from_sb
->next
;
1818 /* Free any empty string blocks further back in the chain.
1819 This loop will never free first_string_block, but it is very
1820 unlikely that that one will become empty, so why bother checking? */
1822 from_sb
= first_string_block
;
1823 while (to_sb
= from_sb
->next
)
1825 if (to_sb
->pos
== 0)
1827 if (from_sb
->next
= to_sb
->next
)
1828 from_sb
->next
->prev
= from_sb
;
1836 /* Initialization */
1840 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
1843 pure_size
= PURESIZE
;
1846 ignore_warnings
= 1;
1851 #ifdef LISP_FLOAT_TYPE
1853 #endif /* LISP_FLOAT_TYPE */
1854 ignore_warnings
= 0;
1857 consing_since_gc
= 0;
1858 gc_cons_threshold
= 100000;
1859 #ifdef VIRT_ADDR_VARIES
1860 malloc_sbrk_unused
= 1<<22; /* A large number */
1861 malloc_sbrk_used
= 100000; /* as reasonable as any number */
1862 #endif /* VIRT_ADDR_VARIES */
1873 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
1874 "*Number of bytes of consing between garbage collections.\n\
1875 Garbage collection can happen automatically once this many bytes have been\n\
1876 allocated since the last garbage collection. All data types count.\n\n\
1877 Garbage collection happens automatically only when `eval' is called.\n\n\
1878 By binding this temporarily to a large number, you can effectively\n\
1879 prevent garbage collection during a part of the program.");
1881 DEFVAR_INT ("pure-bytes-used", &pureptr
,
1882 "Number of bytes of sharable Lisp data allocated so far.");
1885 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
1886 "Number of bytes of unshared memory allocated in this session.");
1888 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
1889 "Number of bytes of unshared memory remaining available in this session.");
1892 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
1893 "Non-nil means loading Lisp code in order to dump an executable.\n\
1894 This means that certain objects should be allocated in shared (pure) space.");
1896 DEFVAR_INT ("undo-limit", &undo_limit
,
1897 "Keep no more undo information once it exceeds this size.\n\
1898 This limit is applied when garbage collection happens.\n\
1899 The size is counted as the number of bytes occupied,\n\
1900 which includes both saved text and other data.");
1903 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
1904 "Don't keep more than this much size of undo information.\n\
1905 A command which pushes past this size is itself forgotten.\n\
1906 This limit is applied when garbage collection happens.\n\
1907 The size is counted as the number of bytes occupied,\n\
1908 which includes both saved text and other data.");
1909 undo_strong_limit
= 30000;
1914 defsubr (&Smake_byte_code
);
1915 defsubr (&Smake_list
);
1916 defsubr (&Smake_vector
);
1917 defsubr (&Smake_string
);
1918 defsubr (&Smake_rope
);
1919 defsubr (&Srope_elt
);
1920 defsubr (&Smake_symbol
);
1921 defsubr (&Smake_marker
);
1922 defsubr (&Spurecopy
);
1923 defsubr (&Sgarbage_collect
);