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
554 int mask
= sigsetmask (-1);
559 if (marker_free_list
)
561 XSET (val
, Lisp_Marker
, marker_free_list
);
563 = (struct Lisp_Marker
*) XFASTINT (marker_free_list
->chain
);
567 if (marker_block_index
== MARKER_BLOCK_SIZE
)
569 struct marker_block
*new = (struct marker_block
*) malloc (sizeof (struct marker_block
));
570 if (!new) memory_full ();
571 VALIDATE_LISP_STORAGE (new, sizeof *new);
572 new->next
= marker_block
;
574 marker_block_index
= 0;
576 XSET (val
, Lisp_Marker
, &marker_block
->markers
[marker_block_index
++]);
582 consing_since_gc
+= sizeof (struct Lisp_Marker
);
586 /* Allocation of strings */
588 /* Strings reside inside of string_blocks. The entire data of the string,
589 both the size and the contents, live in part of the `chars' component of a string_block.
590 The `pos' component is the index within `chars' of the first free byte.
592 first_string_block points to the first string_block ever allocated.
593 Each block points to the next one with its `next' field.
594 The `prev' fields chain in reverse order.
595 The last one allocated is the one currently being filled.
596 current_string_block points to it.
598 The string_blocks that hold individual large strings
599 go in a separate chain, started by large_string_blocks. */
602 /* String blocks contain this many useful bytes.
603 8188 is power of 2, minus 4 for malloc overhead. */
604 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
606 /* A string bigger than this gets its own specially-made string block
607 if it doesn't fit in the current one. */
608 #define STRING_BLOCK_OUTSIZE 1024
610 struct string_block_head
612 struct string_block
*next
, *prev
;
618 struct string_block
*next
, *prev
;
620 char chars
[STRING_BLOCK_SIZE
];
623 /* This points to the string block we are now allocating strings. */
625 struct string_block
*current_string_block
;
627 /* This points to the oldest string block, the one that starts the chain. */
629 struct string_block
*first_string_block
;
631 /* Last string block in chain of those made for individual large strings. */
633 struct string_block
*large_string_blocks
;
635 /* If SIZE is the length of a string, this returns how many bytes
636 the string occupies in a string_block (including padding). */
638 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
640 #define PAD (sizeof (int))
643 #define STRING_FULLSIZE(SIZE) \
644 (((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1))
650 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
651 first_string_block
= current_string_block
;
652 consing_since_gc
+= sizeof (struct string_block
);
653 current_string_block
->next
= 0;
654 current_string_block
->prev
= 0;
655 current_string_block
->pos
= 0;
656 large_string_blocks
= 0;
659 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
660 "Return a newly created string of length LENGTH, with each element being INIT.\n\
661 Both LENGTH and INIT must be numbers.")
663 Lisp_Object length
, init
;
665 register Lisp_Object val
;
666 register unsigned char *p
, *end
, c
;
668 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
669 length
= wrong_type_argument (Qnatnump
, length
);
670 CHECK_NUMBER (init
, 1);
671 val
= make_uninit_string (XINT (length
));
673 p
= XSTRING (val
)->data
;
674 end
= p
+ XSTRING (val
)->size
;
682 make_string (contents
, length
)
686 register Lisp_Object val
;
687 val
= make_uninit_string (length
);
688 bcopy (contents
, XSTRING (val
)->data
, length
);
696 return make_string (str
, strlen (str
));
700 make_uninit_string (length
)
703 register Lisp_Object val
;
704 register int fullsize
= STRING_FULLSIZE (length
);
706 if (length
< 0) abort ();
708 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
709 /* This string can fit in the current string block */
711 XSET (val
, Lisp_String
,
712 (struct Lisp_String
*) (current_string_block
->chars
+ current_string_block
->pos
));
713 current_string_block
->pos
+= fullsize
;
715 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
716 /* This string gets its own string block */
718 register struct string_block
*new
719 = (struct string_block
*) malloc (sizeof (struct string_block_head
) + fullsize
);
720 VALIDATE_LISP_STORAGE (new, 0);
721 if (!new) memory_full ();
722 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
724 new->next
= large_string_blocks
;
725 large_string_blocks
= new;
726 XSET (val
, Lisp_String
,
727 (struct Lisp_String
*) ((struct string_block_head
*)new + 1));
730 /* Make a new current string block and start it off with this string */
732 register struct string_block
*new
733 = (struct string_block
*) malloc (sizeof (struct string_block
));
734 if (!new) memory_full ();
735 VALIDATE_LISP_STORAGE (new, sizeof *new);
736 consing_since_gc
+= sizeof (struct string_block
);
737 current_string_block
->next
= new;
738 new->prev
= current_string_block
;
740 current_string_block
= new;
742 XSET (val
, Lisp_String
,
743 (struct Lisp_String
*) current_string_block
->chars
);
746 XSTRING (val
)->size
= length
;
747 XSTRING (val
)->data
[length
] = 0;
752 /* Return a newly created vector or string with specified arguments as
753 elements. If all the arguments are characters, make a string;
754 otherwise, make a vector. Any number of arguments, even zero
755 arguments, are allowed. */
758 make_array (nargs
, args
)
764 for (i
= 0; i
< nargs
; i
++)
765 if (XTYPE (args
[i
]) != Lisp_Int
766 || (unsigned) XINT (args
[i
]) >= 0400)
767 return Fvector (nargs
, args
);
769 /* Since the loop exited, we know that all the things in it are
770 characters, so we can make a string. */
772 Lisp_Object result
= Fmake_string (nargs
, make_number (0));
774 for (i
= 0; i
< nargs
; i
++)
775 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
781 /* Note: the user cannot manipulate ropes portably by referring
782 to the chars of the string, because combining two chars to make a GLYPH
783 depends on endianness. */
785 DEFUN ("make-rope", Fmake_rope
, Smake_rope
, 0, MANY
, 0,
786 "Return a newly created rope containing the arguments of this function.\n\
787 A rope is a string, except that its contents will be treated as an\n\
788 array of glyphs, where a glyph is an integer type that may be larger\n\
789 than a character. Emacs is normally configured to use 8-bit glyphs,\n\
790 so ropes are normally no different from strings. But Emacs may be\n\
791 configured to use 16-bit glyphs, to allow the use of larger fonts.\n\
793 Each argument (which must be an integer) specifies one glyph, whatever\n\
794 size glyphs may be.\n\
796 See variable `buffer-display-table' for the uses of ropes.")
802 register Lisp_Object val
;
805 val
= make_uninit_string (nargs
* sizeof (GLYPH
));
807 p
= (GLYPH
*) XSTRING (val
)->data
;
808 for (i
= 0; i
< nargs
; i
++)
810 CHECK_NUMBER (args
[i
], i
);
811 p
[i
] = XFASTINT (args
[i
]);
816 DEFUN ("rope-elt", Frope_elt
, Srope_elt
, 2, 2, 0,
817 "Return an element of rope R at index N.\n\
818 A rope is a string in which each pair of bytes is considered an element.\n\
819 See variable `buffer-display-table' for the uses of ropes.")
824 if ((XSTRING (r
)->size
/ sizeof (GLYPH
)) <= XINT (n
) || XINT (n
) < 0)
825 args_out_of_range (r
, n
);
826 return ((GLYPH
*) XSTRING (r
)->data
)[XFASTINT (n
)];
829 /* Must get an error if pure storage is full,
830 since if it cannot hold a large string
831 it may be able to hold conses that point to that string;
832 then the string is not protected from gc. */
835 make_pure_string (data
, length
)
839 register Lisp_Object
new;
840 register int size
= sizeof (int) + length
+ 1;
842 if (pureptr
+ size
> PURESIZE
)
843 error ("Pure Lisp storage exhausted");
844 XSET (new, Lisp_String
, PUREBEG
+ pureptr
);
845 XSTRING (new)->size
= length
;
846 bcopy (data
, XSTRING (new)->data
, length
);
847 XSTRING (new)->data
[length
] = 0;
848 pureptr
+= (size
+ sizeof (int) - 1)
849 / sizeof (int) * sizeof (int);
855 Lisp_Object car
, cdr
;
857 register Lisp_Object
new;
859 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
860 error ("Pure Lisp storage exhausted");
861 XSET (new, Lisp_Cons
, PUREBEG
+ pureptr
);
862 pureptr
+= sizeof (struct Lisp_Cons
);
863 XCONS (new)->car
= Fpurecopy (car
);
864 XCONS (new)->cdr
= Fpurecopy (cdr
);
868 #ifdef LISP_FLOAT_TYPE
871 make_pure_float (num
)
874 register Lisp_Object
new;
876 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
877 error ("Pure Lisp storage exhausted");
878 XSET (new, Lisp_Float
, PUREBEG
+ pureptr
);
879 pureptr
+= sizeof (struct Lisp_Float
);
880 XFLOAT (new)->data
= num
;
881 XFLOAT (new)->type
= 0; /* bug chasing -wsr */
885 #endif /* LISP_FLOAT_TYPE */
888 make_pure_vector (len
)
891 register Lisp_Object
new;
892 register int size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
894 if (pureptr
+ size
> PURESIZE
)
895 error ("Pure Lisp storage exhausted");
897 XSET (new, Lisp_Vector
, PUREBEG
+ pureptr
);
899 XVECTOR (new)->size
= len
;
903 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
904 "Make a copy of OBJECT in pure storage.\n\
905 Recursively copies contents of vectors and cons cells.\n\
906 Does not copy symbols.")
908 register Lisp_Object obj
;
910 register Lisp_Object
new, tem
;
913 if (NILP (Vpurify_flag
))
916 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
917 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
920 #ifdef SWITCH_ENUM_BUG
921 switch ((int) XTYPE (obj
))
927 error ("Attempt to copy a marker to pure storage");
930 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
932 #ifdef LISP_FLOAT_TYPE
934 return make_pure_float (XFLOAT (obj
)->data
);
935 #endif /* LISP_FLOAT_TYPE */
938 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
942 new = make_pure_vector (XVECTOR (obj
)->size
);
943 for (i
= 0; i
< XVECTOR (obj
)->size
; i
++)
945 tem
= XVECTOR (obj
)->contents
[i
];
946 XVECTOR (new)->contents
[i
] = Fpurecopy (tem
);
948 XSETTYPE (new, XTYPE (obj
));
956 /* Recording what needs to be marked for gc. */
958 struct gcpro
*gcprolist
;
962 Lisp_Object
*staticvec
[NSTATICS
] = {0};
966 /* Put an entry in staticvec, pointing at the variable whose address is given */
969 staticpro (varaddress
)
970 Lisp_Object
*varaddress
;
972 staticvec
[staticidx
++] = varaddress
;
973 if (staticidx
>= NSTATICS
)
981 struct catchtag
*next
;
982 /* jmp_buf jmp; /* We don't need this for GC purposes */
987 struct backtrace
*next
;
988 Lisp_Object
*function
;
989 Lisp_Object
*args
; /* Points to vector of args. */
990 int nargs
; /* length of vector */
991 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
995 /* Two flags that are set during GC in the `size' component
996 of a string or vector. On some machines, these flags
997 are defined by the m- file to be different bits. */
999 /* On vector, means it has been marked.
1000 On string size field or a reference to a string,
1001 means not the last reference in the chain. */
1003 #ifndef ARRAY_MARK_FLAG
1004 #define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
1005 #endif /* no ARRAY_MARK_FLAG */
1007 /* Any slot that is a Lisp_Object can point to a string
1008 and thus can be put on a string's reference-chain
1009 and thus may need to have its ARRAY_MARK_FLAG set.
1010 This includes the slots whose markbits are used to mark
1011 the containing objects. */
1013 #if ARRAY_MARK_FLAG == MARKBIT
1017 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1018 int total_free_conses
, total_free_markers
, total_free_symbols
;
1019 #ifdef LISP_FLOAT_TYPE
1020 int total_free_floats
, total_floats
;
1021 #endif /* LISP_FLOAT_TYPE */
1023 static void mark_object (), mark_buffer ();
1024 static void clear_marks (), gc_sweep ();
1025 static void compact_strings ();
1027 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1028 "Reclaim storage for Lisp objects no longer needed.\n\
1029 Returns info on amount of space in use:\n\
1030 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1031 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1032 (USED-FLOATS . FREE-FLOATS))\n\
1033 Garbage collection happens automatically if you cons more than\n\
1034 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1037 register struct gcpro
*tail
;
1038 register struct specbinding
*bind
;
1039 struct catchtag
*catch;
1040 struct handler
*handler
;
1041 register struct backtrace
*backlist
;
1042 register Lisp_Object tem
;
1043 char *omessage
= echo_area_glyphs
;
1044 char stack_top_variable
;
1047 /* Save a copy of the contents of the stack, for debugging. */
1048 #if MAX_SAVE_STACK > 0
1049 if (NILP (Vpurify_flag
))
1051 i
= &stack_top_variable
- stack_bottom
;
1053 if (i
< MAX_SAVE_STACK
)
1055 if (stack_copy
== 0)
1056 stack_copy
= (char *) malloc (stack_copy_size
= i
);
1057 else if (stack_copy_size
< i
)
1058 stack_copy
= (char *) realloc (stack_copy
, (stack_copy_size
= i
));
1061 if ((int) (&stack_top_variable
- stack_bottom
) > 0)
1062 bcopy (stack_bottom
, stack_copy
, i
);
1064 bcopy (&stack_top_variable
, stack_copy
, i
);
1068 #endif /* MAX_SAVE_STACK > 0 */
1070 if (!noninteractive
)
1071 message1 ("Garbage collecting...");
1073 /* Don't keep command history around forever */
1074 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1076 XCONS (tem
)->cdr
= Qnil
;
1077 /* Likewise for undo information. */
1079 register struct buffer
*nextb
= all_buffers
;
1084 = truncate_undo_list (nextb
->undo_list
, undo_threshold
,
1085 undo_high_threshold
);
1086 nextb
= nextb
->next
;
1092 /* clear_marks (); */
1094 /* In each "large string", set the MARKBIT of the size field.
1095 That enables mark_object to recognize them. */
1097 register struct string_block
*b
;
1098 for (b
= large_string_blocks
; b
; b
= b
->next
)
1099 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1102 /* Mark all the special slots that serve as the roots of accessibility.
1104 Usually the special slots to mark are contained in particular structures.
1105 Then we know no slot is marked twice because the structures don't overlap.
1106 In some cases, the structures point to the slots to be marked.
1107 For these, we use MARKBIT to avoid double marking of the slot. */
1109 for (i
= 0; i
< staticidx
; i
++)
1110 mark_object (staticvec
[i
]);
1111 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1112 for (i
= 0; i
< tail
->nvars
; i
++)
1113 if (!XMARKBIT (tail
->var
[i
]))
1115 mark_object (&tail
->var
[i
]);
1116 XMARK (tail
->var
[i
]);
1118 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1120 mark_object (&bind
->symbol
);
1121 mark_object (&bind
->old_value
);
1123 for (catch = catchlist
; catch; catch = catch->next
)
1125 mark_object (&catch->tag
);
1126 mark_object (&catch->val
);
1128 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1130 mark_object (&handler
->handler
);
1131 mark_object (&handler
->var
);
1133 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1135 if (!XMARKBIT (*backlist
->function
))
1137 mark_object (backlist
->function
);
1138 XMARK (*backlist
->function
);
1140 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1143 i
= backlist
->nargs
- 1;
1145 if (!XMARKBIT (backlist
->args
[i
]))
1147 mark_object (&backlist
->args
[i
]);
1148 XMARK (backlist
->args
[i
]);
1154 /* Clear the mark bits that we set in certain root slots. */
1156 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1157 for (i
= 0; i
< tail
->nvars
; i
++)
1158 XUNMARK (tail
->var
[i
]);
1159 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1161 XUNMARK (*backlist
->function
);
1162 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1165 i
= backlist
->nargs
- 1;
1167 XUNMARK (backlist
->args
[i
]);
1169 XUNMARK (buffer_defaults
.name
);
1170 XUNMARK (buffer_local_symbols
.name
);
1172 /* clear_marks (); */
1175 consing_since_gc
= 0;
1176 if (gc_cons_threshold
< 10000)
1177 gc_cons_threshold
= 10000;
1180 message1 (omessage
);
1181 else if (!noninteractive
)
1182 message1 ("Garbage collecting...done");
1184 return Fcons (Fcons (make_number (total_conses
),
1185 make_number (total_free_conses
)),
1186 Fcons (Fcons (make_number (total_symbols
),
1187 make_number (total_free_symbols
)),
1188 Fcons (Fcons (make_number (total_markers
),
1189 make_number (total_free_markers
)),
1190 Fcons (make_number (total_string_size
),
1191 Fcons (make_number (total_vector_size
),
1193 #ifdef LISP_FLOAT_TYPE
1194 Fcons (Fcons (make_number (total_floats
),
1195 make_number (total_free_floats
)),
1197 #else /* not LISP_FLOAT_TYPE */
1199 #endif /* not LISP_FLOAT_TYPE */
1207 /* Clear marks on all conses */
1209 register struct cons_block
*cblk
;
1210 register int lim
= cons_block_index
;
1212 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1215 for (i
= 0; i
< lim
; i
++)
1216 XUNMARK (cblk
->conses
[i
].car
);
1217 lim
= CONS_BLOCK_SIZE
;
1220 /* Clear marks on all symbols */
1222 register struct symbol_block
*sblk
;
1223 register int lim
= symbol_block_index
;
1225 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1228 for (i
= 0; i
< lim
; i
++)
1230 XUNMARK (sblk
->symbols
[i
].plist
);
1232 lim
= SYMBOL_BLOCK_SIZE
;
1235 /* Clear marks on all markers */
1237 register struct marker_block
*sblk
;
1238 register int lim
= marker_block_index
;
1240 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1243 for (i
= 0; i
< lim
; i
++)
1244 XUNMARK (sblk
->markers
[i
].chain
);
1245 lim
= MARKER_BLOCK_SIZE
;
1248 /* Clear mark bits on all buffers */
1250 register struct buffer
*nextb
= all_buffers
;
1254 XUNMARK (nextb
->name
);
1255 nextb
= nextb
->next
;
1261 /* Mark reference to a Lisp_Object. If the object referred to
1262 has not been seen yet, recursively mark all the references contained in it.
1264 If the object referenced is a short string, the referrencing slot
1265 is threaded into a chain of such slots, pointed to from
1266 the `size' field of the string. The actual string size
1267 lives in the last slot in the chain. We recognize the end
1268 because it is < (unsigned) STRING_BLOCK_SIZE. */
1271 mark_object (objptr
)
1272 Lisp_Object
*objptr
;
1274 register Lisp_Object obj
;
1281 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1282 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1285 #ifdef SWITCH_ENUM_BUG
1286 switch ((int) XGCTYPE (obj
))
1288 switch (XGCTYPE (obj
))
1293 register struct Lisp_String
*ptr
= XSTRING (obj
);
1295 if (ptr
->size
& MARKBIT
)
1296 /* A large string. Just set ARRAY_MARK_FLAG. */
1297 ptr
->size
|= ARRAY_MARK_FLAG
;
1300 /* A small string. Put this reference
1301 into the chain of references to it.
1302 The address OBJPTR is even, so if the address
1303 includes MARKBIT, put it in the low bit
1304 when we store OBJPTR into the size field. */
1306 if (XMARKBIT (*objptr
))
1308 XFASTINT (*objptr
) = ptr
->size
;
1312 XFASTINT (*objptr
) = ptr
->size
;
1313 if ((int)objptr
& 1) abort ();
1314 ptr
->size
= (int) objptr
& ~MARKBIT
;
1315 if ((int) objptr
& MARKBIT
)
1324 case Lisp_Window_Configuration
:
1327 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1328 register int size
= ptr
->size
;
1331 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1332 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1333 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1334 mark_object (&ptr
->contents
[i
]);
1341 register struct screen
*ptr
= XSCREEN (obj
);
1342 register int size
= ptr
->size
;
1345 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1346 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1348 mark_object (&ptr
->name
);
1349 mark_object (&ptr
->focus_screen
);
1350 mark_object (&ptr
->width
);
1351 mark_object (&ptr
->height
);
1352 mark_object (&ptr
->selected_window
);
1353 mark_object (&ptr
->minibuffer_window
);
1354 mark_object (&ptr
->param_alist
);
1357 #endif /* MULTI_SCREEN */
1360 case Lisp_Temp_Vector
:
1362 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1363 register int size
= ptr
->size
;
1366 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1367 mark_object (&ptr
->contents
[i
]);
1374 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
1375 struct Lisp_Symbol
*ptrx
;
1377 if (XMARKBIT (ptr
->plist
)) break;
1379 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1380 mark_object (&ptr
->name
);
1381 mark_object ((Lisp_Object
*) &ptr
->value
);
1382 mark_object (&ptr
->function
);
1383 mark_object (&ptr
->plist
);
1387 ptrx
= ptr
; /* Use pf ptrx avoids compiler bug on Sun */
1388 XSETSYMBOL (obj
, ptrx
);
1395 XMARK (XMARKER (obj
)->chain
);
1396 /* DO NOT mark thru the marker's chain.
1397 The buffer's markers chain does not preserve markers from gc;
1398 instead, markers are removed from the chain when they are freed by gc. */
1402 case Lisp_Buffer_Local_Value
:
1403 case Lisp_Some_Buffer_Local_Value
:
1405 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1406 if (XMARKBIT (ptr
->car
)) break;
1408 mark_object (&ptr
->car
);
1414 #ifdef LISP_FLOAT_TYPE
1416 XMARK (XFLOAT (obj
)->type
);
1418 #endif /* LISP_FLOAT_TYPE */
1421 if (!XMARKBIT (XBUFFER (obj
)->name
))
1431 case Lisp_Buffer_Objfwd
:
1432 case Lisp_Internal_Stream
:
1433 /* Don't bother with Lisp_Buffer_Objfwd,
1434 since all markable slots in current buffer marked anyway. */
1435 /* Don't need to do Lisp_Objfwd, since the places they point
1436 are protected with staticpro. */
1444 /* Mark the pointers in a buffer structure. */
1451 register struct buffer
*buffer
= XBUFFER (buf
);
1452 register Lisp_Object
*ptr
;
1454 /* This is the buffer's markbit */
1455 mark_object (&buffer
->name
);
1456 XMARK (buffer
->name
);
1459 mark_object (buffer
->syntax_table
);
1461 /* Mark the various string-pointers in the buffer object.
1462 Since the strings may be relocated, we must mark them
1463 in their actual slots. So gc_sweep must convert each slot
1464 back to an ordinary C pointer. */
1465 XSET (*(Lisp_Object
*)&buffer
->upcase_table
,
1466 Lisp_String
, buffer
->upcase_table
);
1467 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1468 XSET (*(Lisp_Object
*)&buffer
->downcase_table
,
1469 Lisp_String
, buffer
->downcase_table
);
1470 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1472 XSET (*(Lisp_Object
*)&buffer
->sort_table
,
1473 Lisp_String
, buffer
->sort_table
);
1474 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1475 XSET (*(Lisp_Object
*)&buffer
->folding_sort_table
,
1476 Lisp_String
, buffer
->folding_sort_table
);
1477 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1480 for (ptr
= &buffer
->name
+ 1;
1481 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1486 /* Find all structures not marked, and free them. */
1491 total_string_size
= 0;
1494 /* Put all unmarked conses on free list */
1496 register struct cons_block
*cblk
;
1497 register int lim
= cons_block_index
;
1498 register int num_free
= 0, num_used
= 0;
1502 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1505 for (i
= 0; i
< lim
; i
++)
1506 if (!XMARKBIT (cblk
->conses
[i
].car
))
1508 XFASTINT (cblk
->conses
[i
].car
) = (int) cons_free_list
;
1510 cons_free_list
= &cblk
->conses
[i
];
1515 XUNMARK (cblk
->conses
[i
].car
);
1517 lim
= CONS_BLOCK_SIZE
;
1519 total_conses
= num_used
;
1520 total_free_conses
= num_free
;
1523 #ifdef LISP_FLOAT_TYPE
1524 /* Put all unmarked floats on free list */
1526 register struct float_block
*fblk
;
1527 register int lim
= float_block_index
;
1528 register int num_free
= 0, num_used
= 0;
1530 float_free_list
= 0;
1532 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1535 for (i
= 0; i
< lim
; i
++)
1536 if (!XMARKBIT (fblk
->floats
[i
].type
))
1538 XFASTINT (fblk
->floats
[i
].type
) = (int) float_free_list
;
1540 float_free_list
= &fblk
->floats
[i
];
1545 XUNMARK (fblk
->floats
[i
].type
);
1547 lim
= FLOAT_BLOCK_SIZE
;
1549 total_floats
= num_used
;
1550 total_free_floats
= num_free
;
1552 #endif /* LISP_FLOAT_TYPE */
1554 /* Put all unmarked symbols on free list */
1556 register struct symbol_block
*sblk
;
1557 register int lim
= symbol_block_index
;
1558 register int num_free
= 0, num_used
= 0;
1560 symbol_free_list
= 0;
1562 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1565 for (i
= 0; i
< lim
; i
++)
1566 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1568 XFASTINT (sblk
->symbols
[i
].value
) = (int) symbol_free_list
;
1569 symbol_free_list
= &sblk
->symbols
[i
];
1575 sblk
->symbols
[i
].name
1576 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1577 XUNMARK (sblk
->symbols
[i
].plist
);
1579 lim
= SYMBOL_BLOCK_SIZE
;
1581 total_symbols
= num_used
;
1582 total_free_symbols
= num_free
;
1586 /* Put all unmarked markers on free list.
1587 Dechain each one first from the buffer it points into. */
1589 register struct marker_block
*mblk
;
1590 struct Lisp_Marker
*tem1
;
1591 register int lim
= marker_block_index
;
1592 register int num_free
= 0, num_used
= 0;
1594 marker_free_list
= 0;
1596 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1599 for (i
= 0; i
< lim
; i
++)
1600 if (!XMARKBIT (mblk
->markers
[i
].chain
))
1603 tem1
= &mblk
->markers
[i
]; /* tem1 avoids Sun compiler bug */
1604 XSET (tem
, Lisp_Marker
, tem1
);
1605 unchain_marker (tem
);
1606 XFASTINT (mblk
->markers
[i
].chain
) = (int) marker_free_list
;
1607 marker_free_list
= &mblk
->markers
[i
];
1613 XUNMARK (mblk
->markers
[i
].chain
);
1615 lim
= MARKER_BLOCK_SIZE
;
1618 total_markers
= num_used
;
1619 total_free_markers
= num_free
;
1622 /* Free all unmarked buffers */
1624 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1627 if (!XMARKBIT (buffer
->name
))
1630 prev
->next
= buffer
->next
;
1632 all_buffers
= buffer
->next
;
1633 next
= buffer
->next
;
1639 XUNMARK (buffer
->name
);
1642 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1643 for purposes of marking and relocation.
1644 Turn them back into C pointers now. */
1645 buffer
->upcase_table
1646 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
1647 buffer
->downcase_table
1648 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
1650 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
1651 buffer
->folding_sort_table
1652 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
1655 prev
= buffer
, buffer
= buffer
->next
;
1659 #endif /* standalone */
1661 /* Free all unmarked vectors */
1663 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
1664 total_vector_size
= 0;
1667 if (!(vector
->size
& ARRAY_MARK_FLAG
))
1670 prev
->next
= vector
->next
;
1672 all_vectors
= vector
->next
;
1673 next
= vector
->next
;
1679 vector
->size
&= ~ARRAY_MARK_FLAG
;
1680 total_vector_size
+= vector
->size
;
1681 prev
= vector
, vector
= vector
->next
;
1685 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
1687 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
1690 if (!(((struct Lisp_String
*)(&sb
->chars
[0]))->size
& ARRAY_MARK_FLAG
))
1693 prev
->next
= sb
->next
;
1695 large_string_blocks
= sb
->next
;
1702 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
1703 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
1704 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
1705 prev
= sb
, sb
= sb
->next
;
1710 /* Compactify strings, relocate references to them, and
1711 free any string blocks that become empty. */
1716 /* String block of old strings we are scanning. */
1717 register struct string_block
*from_sb
;
1718 /* A preceding string block (or maybe the same one)
1719 where we are copying the still-live strings to. */
1720 register struct string_block
*to_sb
;
1724 to_sb
= first_string_block
;
1727 /* Scan each existing string block sequentially, string by string. */
1728 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
1731 /* POS is the index of the next string in the block. */
1732 while (pos
< from_sb
->pos
)
1734 register struct Lisp_String
*nextstr
1735 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
1737 register struct Lisp_String
*newaddr
;
1738 register int size
= nextstr
->size
;
1740 /* NEXTSTR is the old address of the next string.
1741 Just skip it if it isn't marked. */
1742 if ((unsigned) size
> STRING_BLOCK_SIZE
)
1744 /* It is marked, so its size field is really a chain of refs.
1745 Find the end of the chain, where the actual size lives. */
1746 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1748 if (size
& 1) size
^= MARKBIT
| 1;
1749 size
= *(int *)size
& ~MARKBIT
;
1752 total_string_size
+= size
;
1754 /* If it won't fit in TO_SB, close it out,
1755 and move to the next sb. Keep doing so until
1756 TO_SB reaches a large enough, empty enough string block.
1757 We know that TO_SB cannot advance past FROM_SB here
1758 since FROM_SB is large enough to contain this string.
1759 Any string blocks skipped here
1760 will be patched out and freed later. */
1761 while (to_pos
+ STRING_FULLSIZE (size
)
1762 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
1764 to_sb
->pos
= to_pos
;
1765 to_sb
= to_sb
->next
;
1768 /* Compute new address of this string
1769 and update TO_POS for the space being used. */
1770 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
1771 to_pos
+= STRING_FULLSIZE (size
);
1773 /* Copy the string itself to the new place. */
1774 if (nextstr
!= newaddr
)
1775 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (int));
1777 /* Go through NEXTSTR's chain of references
1778 and make each slot in the chain point to
1779 the new address of this string. */
1780 size
= newaddr
->size
;
1781 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1783 register Lisp_Object
*objptr
;
1784 if (size
& 1) size
^= MARKBIT
| 1;
1785 objptr
= (Lisp_Object
*)size
;
1787 size
= XFASTINT (*objptr
) & ~MARKBIT
;
1788 if (XMARKBIT (*objptr
))
1790 XSET (*objptr
, Lisp_String
, newaddr
);
1794 XSET (*objptr
, Lisp_String
, newaddr
);
1796 /* Store the actual size in the size field. */
1797 newaddr
->size
= size
;
1799 pos
+= STRING_FULLSIZE (size
);
1803 /* Close out the last string block still used and free any that follow. */
1804 to_sb
->pos
= to_pos
;
1805 current_string_block
= to_sb
;
1807 from_sb
= to_sb
->next
;
1811 to_sb
= from_sb
->next
;
1816 /* Free any empty string blocks further back in the chain.
1817 This loop will never free first_string_block, but it is very
1818 unlikely that that one will become empty, so why bother checking? */
1820 from_sb
= first_string_block
;
1821 while (to_sb
= from_sb
->next
)
1823 if (to_sb
->pos
== 0)
1825 if (from_sb
->next
= to_sb
->next
)
1826 from_sb
->next
->prev
= from_sb
;
1834 /* Initialization */
1838 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
1841 pure_size
= PURESIZE
;
1844 ignore_warnings
= 1;
1849 #ifdef LISP_FLOAT_TYPE
1851 #endif /* LISP_FLOAT_TYPE */
1852 ignore_warnings
= 0;
1855 consing_since_gc
= 0;
1856 gc_cons_threshold
= 100000;
1857 #ifdef VIRT_ADDR_VARIES
1858 malloc_sbrk_unused
= 1<<22; /* A large number */
1859 malloc_sbrk_used
= 100000; /* as reasonable as any number */
1860 #endif /* VIRT_ADDR_VARIES */
1871 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
1872 "*Number of bytes of consing between garbage collections.\n\
1873 Garbage collection can happen automatically once this many bytes have been\n\
1874 allocated since the last garbage collection. All data types count.\n\n\
1875 Garbage collection happens automatically only when `eval' is called.\n\n\
1876 By binding this temporarily to a large number, you can effectively\n\
1877 prevent garbage collection during a part of the program.");
1879 DEFVAR_INT ("pure-bytes-used", &pureptr
,
1880 "Number of bytes of sharable Lisp data allocated so far.");
1883 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
1884 "Number of bytes of unshared memory allocated in this session.");
1886 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
1887 "Number of bytes of unshared memory remaining available in this session.");
1890 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
1891 "Non-nil means loading Lisp code in order to dump an executable.\n\
1892 This means that certain objects should be allocated in shared (pure) space.");
1894 DEFVAR_INT ("undo-threshold", &undo_threshold
,
1895 "Keep no more undo information once it exceeds this size.\n\
1896 This threshold is applied when garbage collection happens.\n\
1897 The size is counted as the number of bytes occupied,\n\
1898 which includes both saved text and other data.");
1899 undo_threshold
= 20000;
1901 DEFVAR_INT ("undo-high-threshold", &undo_high_threshold
,
1902 "Don't keep more than this much size of undo information.\n\
1903 A command which pushes past this size is itself forgotten.\n\
1904 This threshold is applied when garbage collection happens.\n\
1905 The size is counted as the number of bytes occupied,\n\
1906 which includes both saved text and other data.");
1907 undo_high_threshold
= 30000;
1912 defsubr (&Smake_byte_code
);
1913 defsubr (&Smake_list
);
1914 defsubr (&Smake_vector
);
1915 defsubr (&Smake_string
);
1916 defsubr (&Smake_rope
);
1917 defsubr (&Srope_elt
);
1918 defsubr (&Smake_symbol
);
1919 defsubr (&Smake_marker
);
1920 defsubr (&Spurecopy
);
1921 defsubr (&Sgarbage_collect
);