1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988 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. */
30 #endif /* MULTI_SCREEN */
31 #endif /* HAVE_X_WINDOWS */
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 thresholds controlling how much undo information to keep. */
73 int undo_high_threshold
;
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
84 #endif /* not HAVE_SHM */
86 /* Index in pure at which next pure object will be allocated. */
89 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
90 char *pending_malloc_warning
;
92 /* Maximum amount of C stack to save when a GC happens. */
94 #ifndef MAX_SAVE_STACK
95 #define MAX_SAVE_STACK 16000
98 /* Buffer in which we save a copy of the C stack at each GC. */
103 /* Non-zero means ignore malloc warnings. Set during initialization. */
107 malloc_warning_1 (str
)
110 Fprinc (str
, Vstandard_output
);
111 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
112 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
113 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
117 /* malloc calls this if it finds we are near exhausting storage */
121 pending_malloc_warning
= str
;
124 display_malloc_warning ()
126 register Lisp_Object val
;
128 val
= build_string (pending_malloc_warning
);
129 pending_malloc_warning
= 0;
130 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
133 /* Called if malloc returns zero */
136 error ("Memory exhausted");
139 /* like malloc and realloc but check for no memory left */
147 val
= (long *) malloc (size
);
149 if (!val
&& size
) memory_full ();
154 xrealloc (block
, size
)
160 val
= (long *) realloc (block
, size
);
162 if (!val
&& size
) memory_full ();
166 #ifdef LISP_FLOAT_TYPE
167 /* Allocation of float cells, just like conses */
168 /* We store float cells inside of float_blocks, allocating a new
169 float_block with malloc whenever necessary. Float cells reclaimed by
170 GC are put on a free list to be reallocated before allocating
171 any new float cells from the latest float_block.
173 Each float_block is just under 1020 bytes long,
174 since malloc really allocates in units of powers of two
175 and uses 4 bytes for its own overhead. */
177 #define FLOAT_BLOCK_SIZE \
178 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
182 struct float_block
*next
;
183 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
186 struct float_block
*float_block
;
187 int float_block_index
;
189 struct Lisp_Float
*float_free_list
;
194 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
195 float_block
->next
= 0;
196 bzero (float_block
->floats
, sizeof float_block
->floats
);
197 float_block_index
= 0;
201 /* Explicitly free a float cell. */
203 struct Lisp_Float
*ptr
;
205 XFASTINT (ptr
->type
) = (int) float_free_list
;
206 float_free_list
= ptr
;
210 make_float (float_value
)
213 register Lisp_Object val
;
217 XSET (val
, Lisp_Float
, float_free_list
);
218 float_free_list
= (struct Lisp_Float
*) XFASTINT (float_free_list
->type
);
222 if (float_block_index
== FLOAT_BLOCK_SIZE
)
224 register struct float_block
*new = (struct float_block
*) malloc (sizeof (struct float_block
));
225 if (!new) memory_full ();
226 VALIDATE_LISP_STORAGE (new, sizeof *new);
227 new->next
= float_block
;
229 float_block_index
= 0;
231 XSET (val
, Lisp_Float
, &float_block
->floats
[float_block_index
++]);
233 XFLOAT (val
)->data
= float_value
;
234 XFLOAT (val
)->type
= 0; /* bug chasing -wsr */
235 consing_since_gc
+= sizeof (struct Lisp_Float
);
239 #endif /* LISP_FLOAT_TYPE */
241 /* Allocation of cons cells */
242 /* We store cons cells inside of cons_blocks, allocating a new
243 cons_block with malloc whenever necessary. Cons cells reclaimed by
244 GC are put on a free list to be reallocated before allocating
245 any new cons cells from the latest cons_block.
247 Each cons_block is just under 1020 bytes long,
248 since malloc really allocates in units of powers of two
249 and uses 4 bytes for its own overhead. */
251 #define CONS_BLOCK_SIZE \
252 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
256 struct cons_block
*next
;
257 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
260 struct cons_block
*cons_block
;
261 int cons_block_index
;
263 struct Lisp_Cons
*cons_free_list
;
268 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
269 cons_block
->next
= 0;
270 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
271 cons_block_index
= 0;
275 /* Explicitly free a cons cell. */
277 struct Lisp_Cons
*ptr
;
279 XFASTINT (ptr
->car
) = (int) cons_free_list
;
280 cons_free_list
= ptr
;
283 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
284 "Create a new cons, give it CAR and CDR as components, and return it.")
286 Lisp_Object car
, cdr
;
288 register Lisp_Object val
;
292 XSET (val
, Lisp_Cons
, cons_free_list
);
293 cons_free_list
= (struct Lisp_Cons
*) XFASTINT (cons_free_list
->car
);
297 if (cons_block_index
== CONS_BLOCK_SIZE
)
299 register struct cons_block
*new = (struct cons_block
*) malloc (sizeof (struct cons_block
));
300 if (!new) memory_full ();
301 VALIDATE_LISP_STORAGE (new, sizeof *new);
302 new->next
= cons_block
;
304 cons_block_index
= 0;
306 XSET (val
, Lisp_Cons
, &cons_block
->conses
[cons_block_index
++]);
308 XCONS (val
)->car
= car
;
309 XCONS (val
)->cdr
= cdr
;
310 consing_since_gc
+= sizeof (struct Lisp_Cons
);
314 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
315 "Return a newly created list with specified arguments as elements.\n\
316 Any number of arguments, even zero arguments, are allowed.")
319 register Lisp_Object
*args
;
321 register Lisp_Object len
, val
, val_tail
;
323 XFASTINT (len
) = nargs
;
324 val
= Fmake_list (len
, Qnil
);
326 while (!NULL (val_tail
))
328 XCONS (val_tail
)->car
= *args
++;
329 val_tail
= XCONS (val_tail
)->cdr
;
334 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
335 "Return a newly created list of length LENGTH, with each element being INIT.")
337 register Lisp_Object length
, init
;
339 register Lisp_Object val
;
342 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
343 length
= wrong_type_argument (Qnatnump
, length
);
344 size
= XINT (length
);
348 val
= Fcons (init
, val
);
352 /* Allocation of vectors */
354 struct Lisp_Vector
*all_vectors
;
356 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
357 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
358 See also the function `vector'.")
360 register Lisp_Object length
, init
;
362 register int sizei
, index
;
363 register Lisp_Object vector
;
364 register struct Lisp_Vector
*p
;
366 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
367 length
= wrong_type_argument (Qnatnump
, length
);
368 sizei
= XINT (length
);
370 p
= (struct Lisp_Vector
*) malloc (sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
));
373 VALIDATE_LISP_STORAGE (p
, 0);
375 XSET (vector
, Lisp_Vector
, p
);
376 consing_since_gc
+= sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
);
379 p
->next
= all_vectors
;
382 for (index
= 0; index
< sizei
; index
++)
383 p
->contents
[index
] = init
;
388 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
389 "Return a newly created vector with specified arguments as elements.\n\
390 Any number of arguments, even zero arguments, are allowed.")
395 register Lisp_Object len
, val
;
397 register struct Lisp_Vector
*p
;
399 XFASTINT (len
) = nargs
;
400 val
= Fmake_vector (len
, Qnil
);
402 for (index
= 0; index
< nargs
; index
++)
403 p
->contents
[index
] = args
[index
];
407 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
408 "Create a byte-code object with specified arguments as elements.\n\
409 The arguments should be the arglist, bytecode-string, constant vector,\n\
410 stack size, (optional) doc string, and (optional) interactive spec.\n\
411 The first four arguments are required; at most six have any\n\
417 register Lisp_Object len
, val
;
419 register struct Lisp_Vector
*p
;
421 XFASTINT (len
) = nargs
;
422 if (!NULL (Vpurify_flag
))
423 val
= make_pure_vector (len
);
425 val
= Fmake_vector (len
, Qnil
);
427 for (index
= 0; index
< nargs
; index
++)
429 if (!NULL (Vpurify_flag
))
430 args
[index
] = Fpurecopy (args
[index
]);
431 p
->contents
[index
] = args
[index
];
433 XSETTYPE (val
, Lisp_Compiled
);
437 /* Allocation of symbols.
438 Just like allocation of conses!
440 Each symbol_block is just under 1020 bytes long,
441 since malloc really allocates in units of powers of two
442 and uses 4 bytes for its own overhead. */
444 #define SYMBOL_BLOCK_SIZE \
445 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
449 struct symbol_block
*next
;
450 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
453 struct symbol_block
*symbol_block
;
454 int symbol_block_index
;
456 struct Lisp_Symbol
*symbol_free_list
;
461 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
462 symbol_block
->next
= 0;
463 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
464 symbol_block_index
= 0;
465 symbol_free_list
= 0;
468 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
469 "Return a newly allocated uninterned symbol whose name is NAME.\n\
470 Its value and function definition are void, and its property list is nil.")
474 register Lisp_Object val
;
475 register struct Lisp_Symbol
*p
;
477 CHECK_STRING (str
, 0);
479 if (symbol_free_list
)
481 XSET (val
, Lisp_Symbol
, symbol_free_list
);
483 = (struct Lisp_Symbol
*) XFASTINT (symbol_free_list
->value
);
487 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
489 struct symbol_block
*new = (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
490 if (!new) memory_full ();
491 VALIDATE_LISP_STORAGE (new, sizeof *new);
492 new->next
= symbol_block
;
494 symbol_block_index
= 0;
496 XSET (val
, Lisp_Symbol
, &symbol_block
->symbols
[symbol_block_index
++]);
499 p
->name
= XSTRING (str
);
502 p
->function
= Qunbound
;
504 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
508 /* Allocation of markers.
509 Works like allocation of conses. */
511 #define MARKER_BLOCK_SIZE \
512 ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker))
516 struct marker_block
*next
;
517 struct Lisp_Marker markers
[MARKER_BLOCK_SIZE
];
520 struct marker_block
*marker_block
;
521 int marker_block_index
;
523 struct Lisp_Marker
*marker_free_list
;
528 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
529 marker_block
->next
= 0;
530 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
531 marker_block_index
= 0;
532 marker_free_list
= 0;
535 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
536 "Return a newly allocated marker which does not point at any place.")
539 register Lisp_Object val
;
540 register struct Lisp_Marker
*p
;
541 /* Detact the bug that seems to have caused this to be called from
543 int mask
= sigsetmask (-1);
548 if (marker_free_list
)
550 XSET (val
, Lisp_Marker
, marker_free_list
);
552 = (struct Lisp_Marker
*) XFASTINT (marker_free_list
->chain
);
556 if (marker_block_index
== MARKER_BLOCK_SIZE
)
558 struct marker_block
*new = (struct marker_block
*) malloc (sizeof (struct marker_block
));
559 if (!new) memory_full ();
560 VALIDATE_LISP_STORAGE (new, sizeof *new);
561 new->next
= marker_block
;
563 marker_block_index
= 0;
565 XSET (val
, Lisp_Marker
, &marker_block
->markers
[marker_block_index
++]);
571 consing_since_gc
+= sizeof (struct Lisp_Marker
);
575 /* Allocation of strings */
577 /* Strings reside inside of string_blocks. The entire data of the string,
578 both the size and the contents, live in part of the `chars' component of a string_block.
579 The `pos' component is the index within `chars' of the first free byte.
581 first_string_block points to the first string_block ever allocated.
582 Each block points to the next one with its `next' field.
583 The `prev' fields chain in reverse order.
584 The last one allocated is the one currently being filled.
585 current_string_block points to it.
587 The string_blocks that hold individual large strings
588 go in a separate chain, started by large_string_blocks. */
591 /* String blocks contain this many useful bytes.
592 8188 is power of 2, minus 4 for malloc overhead. */
593 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
595 /* A string bigger than this gets its own specially-made string block
596 if it doesn't fit in the current one. */
597 #define STRING_BLOCK_OUTSIZE 1024
599 struct string_block_head
601 struct string_block
*next
, *prev
;
607 struct string_block
*next
, *prev
;
609 char chars
[STRING_BLOCK_SIZE
];
612 /* This points to the string block we are now allocating strings. */
614 struct string_block
*current_string_block
;
616 /* This points to the oldest string block, the one that starts the chain. */
618 struct string_block
*first_string_block
;
620 /* Last string block in chain of those made for individual large strings. */
622 struct string_block
*large_string_blocks
;
624 /* If SIZE is the length of a string, this returns how many bytes
625 the string occupies in a string_block (including padding). */
627 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
629 #define PAD (sizeof (int))
632 #define STRING_FULLSIZE(SIZE) \
633 (((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1))
639 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
640 first_string_block
= current_string_block
;
641 consing_since_gc
+= sizeof (struct string_block
);
642 current_string_block
->next
= 0;
643 current_string_block
->prev
= 0;
644 current_string_block
->pos
= 0;
645 large_string_blocks
= 0;
648 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
649 "Return a newly created string of length LENGTH, with each element being INIT.\n\
650 Both LENGTH and INIT must be numbers.")
652 Lisp_Object length
, init
;
654 register Lisp_Object val
;
655 register unsigned char *p
, *end
, c
;
657 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
658 length
= wrong_type_argument (Qnatnump
, length
);
659 CHECK_NUMBER (init
, 1);
660 val
= make_uninit_string (XINT (length
));
662 p
= XSTRING (val
)->data
;
663 end
= p
+ XSTRING (val
)->size
;
671 make_string (contents
, length
)
675 register Lisp_Object val
;
676 val
= make_uninit_string (length
);
677 bcopy (contents
, XSTRING (val
)->data
, length
);
685 return make_string (str
, strlen (str
));
689 make_uninit_string (length
)
692 register Lisp_Object val
;
693 register int fullsize
= STRING_FULLSIZE (length
);
695 if (length
< 0) abort ();
697 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
698 /* This string can fit in the current string block */
700 XSET (val
, Lisp_String
,
701 (struct Lisp_String
*) (current_string_block
->chars
+ current_string_block
->pos
));
702 current_string_block
->pos
+= fullsize
;
704 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
705 /* This string gets its own string block */
707 register struct string_block
*new
708 = (struct string_block
*) malloc (sizeof (struct string_block_head
) + fullsize
);
709 VALIDATE_LISP_STORAGE (new, 0);
710 if (!new) memory_full ();
711 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
713 new->next
= large_string_blocks
;
714 large_string_blocks
= new;
715 XSET (val
, Lisp_String
,
716 (struct Lisp_String
*) ((struct string_block_head
*)new + 1));
719 /* Make a new current string block and start it off with this string */
721 register struct string_block
*new
722 = (struct string_block
*) malloc (sizeof (struct string_block
));
723 if (!new) memory_full ();
724 VALIDATE_LISP_STORAGE (new, sizeof *new);
725 consing_since_gc
+= sizeof (struct string_block
);
726 current_string_block
->next
= new;
727 new->prev
= current_string_block
;
729 current_string_block
= new;
731 XSET (val
, Lisp_String
,
732 (struct Lisp_String
*) current_string_block
->chars
);
735 XSTRING (val
)->size
= length
;
736 XSTRING (val
)->data
[length
] = 0;
741 /* Return a newly created vector or string with specified arguments as
742 elements. If all the arguments are characters, make a string;
743 otherwise, make a vector. Any number of arguments, even zero
744 arguments, are allowed. */
747 make_sequence (nargs
, args
)
753 for (i
= 0; i
< nargs
; i
++)
754 if (XTYPE (args
[i
]) != Lisp_Int
755 || (unsigned) XINT (args
[i
]) >= 0400)
756 return Fvector (nargs
, args
);
758 /* Since the loop exited, we know that all the things in it are
759 characters, so we can make a string. */
761 Lisp_Object result
= Fmake_string (nargs
, make_number (0));
763 for (i
= 0; i
< nargs
; i
++)
764 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
770 /* Note: the user cannot manipulate ropes portably by referring
771 to the chars of the string, because combining two chars to make a GLYPH
772 depends on endianness. */
774 DEFUN ("make-rope", Fmake_rope
, Smake_rope
, 0, MANY
, 0,
775 "Return a newly created rope containing the arguments of this function.
776 A rope is a string, except that its contents will be treated as an\n\
777 array of glyphs, where a glyph is an integer type that may be larger\n\
778 than a character. Emacs is normally configured to use 8-bit glyphs,\n\
779 so ropes are normally no different from strings. But Emacs may be\n\
780 configured to use 16-bit glyphs, to allow the use of larger fonts.\n\
782 Each argument (which must be an integer) specifies one glyph, whatever\n\
783 size glyphs may be.\n\
785 See variable `buffer-display-table' for the uses of ropes.")
791 register Lisp_Object val
;
794 val
= make_uninit_string (nargs
* sizeof (GLYPH
));
796 p
= (GLYPH
*) XSTRING (val
)->data
;
797 for (i
= 0; i
< nargs
; i
++)
799 CHECK_NUMBER (args
[i
], i
);
800 p
[i
] = XFASTINT (args
[i
]);
805 DEFUN ("rope-elt", Frope_elt
, Srope_elt
, 2, 2, 0,
806 "Return an element of rope R at index N.\n\
807 A rope is a string in which each pair of bytes is considered an element.\n\
808 See variable `buffer-display-table' for the uses of ropes.")
813 if ((XSTRING (r
)->size
/ sizeof (GLYPH
)) <= XINT (n
) || XINT (n
) < 0)
814 args_out_of_range (r
, n
);
815 return ((GLYPH
*) XSTRING (r
)->data
)[XFASTINT (n
)];
818 /* Must get an error if pure storage is full,
819 since if it cannot hold a large string
820 it may be able to hold conses that point to that string;
821 then the string is not protected from gc. */
824 make_pure_string (data
, length
)
828 register Lisp_Object
new;
829 register int size
= sizeof (int) + length
+ 1;
831 if (pureptr
+ size
> PURESIZE
)
832 error ("Pure Lisp storage exhausted");
833 XSET (new, Lisp_String
, PUREBEG
+ pureptr
);
834 XSTRING (new)->size
= length
;
835 bcopy (data
, XSTRING (new)->data
, length
);
836 XSTRING (new)->data
[length
] = 0;
837 pureptr
+= (size
+ sizeof (int) - 1)
838 / sizeof (int) * sizeof (int);
844 Lisp_Object car
, cdr
;
846 register Lisp_Object
new;
848 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
849 error ("Pure Lisp storage exhausted");
850 XSET (new, Lisp_Cons
, PUREBEG
+ pureptr
);
851 pureptr
+= sizeof (struct Lisp_Cons
);
852 XCONS (new)->car
= Fpurecopy (car
);
853 XCONS (new)->cdr
= Fpurecopy (cdr
);
857 #ifdef LISP_FLOAT_TYPE
860 make_pure_float (num
)
863 register Lisp_Object
new;
865 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
866 error ("Pure Lisp storage exhausted");
867 XSET (new, Lisp_Float
, PUREBEG
+ pureptr
);
868 pureptr
+= sizeof (struct Lisp_Float
);
869 XFLOAT (new)->data
= num
;
870 XFLOAT (new)->type
= 0; /* bug chasing -wsr */
874 #endif /* LISP_FLOAT_TYPE */
877 make_pure_vector (len
)
880 register Lisp_Object
new;
881 register int size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
883 if (pureptr
+ size
> PURESIZE
)
884 error ("Pure Lisp storage exhausted");
886 XSET (new, Lisp_Vector
, PUREBEG
+ pureptr
);
888 XVECTOR (new)->size
= len
;
892 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
893 "Make a copy of OBJECT in pure storage.\n\
894 Recursively copies contents of vectors and cons cells.\n\
895 Does not copy symbols.")
897 register Lisp_Object obj
;
899 register Lisp_Object
new, tem
;
902 if (NULL (Vpurify_flag
))
905 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
906 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
909 #ifdef SWITCH_ENUM_BUG
910 switch ((int) XTYPE (obj
))
916 error ("Attempt to copy a marker to pure storage");
919 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
921 #ifdef LISP_FLOAT_TYPE
923 return make_pure_float (XFLOAT (obj
)->data
);
924 #endif /* LISP_FLOAT_TYPE */
927 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
931 new = make_pure_vector (XVECTOR (obj
)->size
);
932 for (i
= 0; i
< XVECTOR (obj
)->size
; i
++)
934 tem
= XVECTOR (obj
)->contents
[i
];
935 XVECTOR (new)->contents
[i
] = Fpurecopy (tem
);
937 XSETTYPE (new, XTYPE (obj
));
945 /* Recording what needs to be marked for gc. */
947 struct gcpro
*gcprolist
;
951 Lisp_Object
*staticvec
[NSTATICS
] = {0};
955 /* Put an entry in staticvec, pointing at the variable whose address is given */
958 staticpro (varaddress
)
959 Lisp_Object
*varaddress
;
961 staticvec
[staticidx
++] = varaddress
;
962 if (staticidx
>= NSTATICS
)
970 struct catchtag
*next
;
971 /* jmp_buf jmp; /* We don't need this for GC purposes */
976 struct backtrace
*next
;
977 Lisp_Object
*function
;
978 Lisp_Object
*args
; /* Points to vector of args. */
979 int nargs
; /* length of vector */
980 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
984 /* Two flags that are set during GC in the `size' component
985 of a string or vector. On some machines, these flags
986 are defined by the m- file to be different bits. */
988 /* On vector, means it has been marked.
989 On string size field or a reference to a string,
990 means not the last reference in the chain. */
992 #ifndef ARRAY_MARK_FLAG
993 #define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
994 #endif /* no ARRAY_MARK_FLAG */
996 /* Any slot that is a Lisp_Object can point to a string
997 and thus can be put on a string's reference-chain
998 and thus may need to have its ARRAY_MARK_FLAG set.
999 This includes the slots whose markbits are used to mark
1000 the containing objects. */
1002 #if ARRAY_MARK_FLAG == MARKBIT
1006 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1007 int total_free_conses
, total_free_markers
, total_free_symbols
;
1008 #ifdef LISP_FLOAT_TYPE
1009 int total_free_floats
, total_floats
;
1010 #endif /* LISP_FLOAT_TYPE */
1012 static void mark_object (), mark_buffer ();
1013 static void clear_marks (), gc_sweep ();
1014 static void compact_strings ();
1016 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1017 "Reclaim storage for Lisp objects no longer needed.\n\
1018 Returns info on amount of space in use:\n\
1019 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1020 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1021 (USED-FLOATS . FREE-FLOATS))\n\
1022 Garbage collection happens automatically if you cons more than\n\
1023 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1026 register struct gcpro
*tail
;
1027 register struct specbinding
*bind
;
1028 struct catchtag
*catch;
1029 struct handler
*handler
;
1030 register struct backtrace
*backlist
;
1031 register Lisp_Object tem
;
1032 char *omessage
= echo_area_glyphs
;
1033 char stack_top_variable
;
1038 /* Save a copy of the contents of the stack, for debugging. */
1039 #if MAX_SAVE_STACK > 0
1040 if (NULL (Vpurify_flag
))
1042 i
= &stack_top_variable
- stack_bottom
;
1044 if (i
< MAX_SAVE_STACK
)
1046 if (stack_copy
== 0)
1047 stack_copy
= (char *) malloc (stack_copy_size
= i
);
1048 else if (stack_copy_size
< i
)
1049 stack_copy
= (char *) realloc (stack_copy
, (stack_copy_size
= i
));
1052 if ((int) (&stack_top_variable
- stack_bottom
) > 0)
1053 bcopy (stack_bottom
, stack_copy
, i
);
1055 bcopy (&stack_top_variable
, stack_copy
, i
);
1059 #endif /* MAX_SAVE_STACK > 0 */
1061 if (!noninteractive
)
1062 message1 ("Garbage collecting...");
1064 /* Don't keep command history around forever */
1065 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1067 XCONS (tem
)->cdr
= Qnil
;
1068 /* Likewise for undo information. */
1070 register struct buffer
*nextb
= all_buffers
;
1075 = truncate_undo_list (nextb
->undo_list
, undo_threshold
,
1076 undo_high_threshold
);
1077 nextb
= nextb
->next
;
1083 /* clear_marks (); */
1085 /* In each "large string", set the MARKBIT of the size field.
1086 That enables mark_object to recognize them. */
1088 register struct string_block
*b
;
1089 for (b
= large_string_blocks
; b
; b
= b
->next
)
1090 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1093 /* Mark all the special slots that serve as the roots of accessibility.
1095 Usually the special slots to mark are contained in particular structures.
1096 Then we know no slot is marked twice because the structures don't overlap.
1097 In some cases, the structures point to the slots to be marked.
1098 For these, we use MARKBIT to avoid double marking of the slot. */
1100 for (i
= 0; i
< staticidx
; i
++)
1101 mark_object (staticvec
[i
]);
1102 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1103 for (i
= 0; i
< tail
->nvars
; i
++)
1104 if (!XMARKBIT (tail
->var
[i
]))
1106 mark_object (&tail
->var
[i
]);
1107 XMARK (tail
->var
[i
]);
1109 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1111 mark_object (&bind
->symbol
);
1112 mark_object (&bind
->old_value
);
1114 for (catch = catchlist
; catch; catch = catch->next
)
1116 mark_object (&catch->tag
);
1117 mark_object (&catch->val
);
1119 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1121 mark_object (&handler
->handler
);
1122 mark_object (&handler
->var
);
1124 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1126 if (!XMARKBIT (*backlist
->function
))
1128 mark_object (backlist
->function
);
1129 XMARK (*backlist
->function
);
1131 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1134 i
= backlist
->nargs
- 1;
1136 if (!XMARKBIT (backlist
->args
[i
]))
1138 mark_object (&backlist
->args
[i
]);
1139 XMARK (backlist
->args
[i
]);
1145 /* Clear the mark bits that we set in certain root slots. */
1147 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1148 for (i
= 0; i
< tail
->nvars
; i
++)
1149 XUNMARK (tail
->var
[i
]);
1150 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1152 XUNMARK (*backlist
->function
);
1153 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1156 i
= backlist
->nargs
- 1;
1158 XUNMARK (backlist
->args
[i
]);
1160 XUNMARK (buffer_defaults
.name
);
1161 XUNMARK (buffer_local_symbols
.name
);
1163 /* clear_marks (); */
1166 consing_since_gc
= 0;
1167 if (gc_cons_threshold
< 10000)
1168 gc_cons_threshold
= 10000;
1171 message1 (omessage
);
1172 else if (!noninteractive
)
1173 message1 ("Garbage collecting...done");
1175 #ifdef HAVE_X_WINDOWS
1179 return Fcons (Fcons (make_number (total_conses
),
1180 make_number (total_free_conses
)),
1181 Fcons (Fcons (make_number (total_symbols
),
1182 make_number (total_free_symbols
)),
1183 Fcons (Fcons (make_number (total_markers
),
1184 make_number (total_free_markers
)),
1185 Fcons (make_number (total_string_size
),
1186 Fcons (make_number (total_vector_size
),
1188 #ifdef LISP_FLOAT_TYPE
1189 Fcons (Fcons (make_number (total_floats
),
1190 make_number (total_free_floats
)),
1192 #else /* not LISP_FLOAT_TYPE */
1194 #endif /* not LISP_FLOAT_TYPE */
1202 /* Clear marks on all conses */
1204 register struct cons_block
*cblk
;
1205 register int lim
= cons_block_index
;
1207 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1210 for (i
= 0; i
< lim
; i
++)
1211 XUNMARK (cblk
->conses
[i
].car
);
1212 lim
= CONS_BLOCK_SIZE
;
1215 /* Clear marks on all symbols */
1217 register struct symbol_block
*sblk
;
1218 register int lim
= symbol_block_index
;
1220 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1223 for (i
= 0; i
< lim
; i
++)
1225 XUNMARK (sblk
->symbols
[i
].plist
);
1227 lim
= SYMBOL_BLOCK_SIZE
;
1230 /* Clear marks on all markers */
1232 register struct marker_block
*sblk
;
1233 register int lim
= marker_block_index
;
1235 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1238 for (i
= 0; i
< lim
; i
++)
1239 XUNMARK (sblk
->markers
[i
].chain
);
1240 lim
= MARKER_BLOCK_SIZE
;
1243 /* Clear mark bits on all buffers */
1245 register struct buffer
*nextb
= all_buffers
;
1249 XUNMARK (nextb
->name
);
1250 nextb
= nextb
->next
;
1256 /* Mark reference to a Lisp_Object. If the object referred to
1257 has not been seen yet, recursively mark all the references contained in it.
1259 If the object referenced is a short string, the referrencing slot
1260 is threaded into a chain of such slots, pointed to from
1261 the `size' field of the string. The actual string size
1262 lives in the last slot in the chain. We recognize the end
1263 because it is < (unsigned) STRING_BLOCK_SIZE. */
1266 mark_object (objptr
)
1267 Lisp_Object
*objptr
;
1269 register Lisp_Object obj
;
1276 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1277 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1280 #ifdef SWITCH_ENUM_BUG
1281 switch ((int) XGCTYPE (obj
))
1283 switch (XGCTYPE (obj
))
1288 register struct Lisp_String
*ptr
= XSTRING (obj
);
1290 if (ptr
->size
& MARKBIT
)
1291 /* A large string. Just set ARRAY_MARK_FLAG. */
1292 ptr
->size
|= ARRAY_MARK_FLAG
;
1295 /* A small string. Put this reference
1296 into the chain of references to it.
1297 The address OBJPTR is even, so if the address
1298 includes MARKBIT, put it in the low bit
1299 when we store OBJPTR into the size field. */
1301 if (XMARKBIT (*objptr
))
1303 XFASTINT (*objptr
) = ptr
->size
;
1307 XFASTINT (*objptr
) = ptr
->size
;
1308 if ((int)objptr
& 1) abort ();
1309 ptr
->size
= (int) objptr
& ~MARKBIT
;
1310 if ((int) objptr
& MARKBIT
)
1319 case Lisp_Window_Configuration
:
1322 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1323 register int size
= ptr
->size
;
1326 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1327 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1328 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1329 mark_object (&ptr
->contents
[i
]);
1336 register struct screen
*ptr
= XSCREEN (obj
);
1337 register int size
= ptr
->size
;
1340 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1341 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1343 mark_object (&ptr
->name
);
1344 mark_object (&ptr
->width
);
1345 mark_object (&ptr
->height
);
1346 mark_object (&ptr
->selected_window
);
1347 mark_object (&ptr
->minibuffer_window
);
1348 mark_object (&ptr
->param_alist
);
1351 #endif /* MULTI_SCREEN */
1354 case Lisp_Temp_Vector
:
1356 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1357 register int size
= ptr
->size
;
1360 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1361 mark_object (&ptr
->contents
[i
]);
1368 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
1369 struct Lisp_Symbol
*ptrx
;
1371 if (XMARKBIT (ptr
->plist
)) break;
1373 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1374 mark_object (&ptr
->name
);
1375 mark_object ((Lisp_Object
*) &ptr
->value
);
1376 mark_object (&ptr
->function
);
1377 mark_object (&ptr
->plist
);
1381 ptrx
= ptr
; /* Use pf ptrx avoids compiler bug on Sun */
1382 XSETSYMBOL (obj
, ptrx
);
1389 XMARK (XMARKER (obj
)->chain
);
1390 /* DO NOT mark thru the marker's chain.
1391 The buffer's markers chain does not preserve markers from gc;
1392 instead, markers are removed from the chain when they are freed by gc. */
1396 case Lisp_Buffer_Local_Value
:
1397 case Lisp_Some_Buffer_Local_Value
:
1399 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1400 if (XMARKBIT (ptr
->car
)) break;
1402 mark_object (&ptr
->car
);
1408 #ifdef LISP_FLOAT_TYPE
1410 XMARK (XFLOAT (obj
)->type
);
1412 #endif /* LISP_FLOAT_TYPE */
1415 if (!XMARKBIT (XBUFFER (obj
)->name
))
1425 case Lisp_Buffer_Objfwd
:
1426 case Lisp_Internal_Stream
:
1427 /* Don't bother with Lisp_Buffer_Objfwd,
1428 since all markable slots in current buffer marked anyway. */
1429 /* Don't need to do Lisp_Objfwd, since the places they point
1430 are protected with staticpro. */
1438 /* Mark the pointers in a buffer structure. */
1445 register struct buffer
*buffer
= XBUFFER (buf
);
1446 register Lisp_Object
*ptr
;
1448 /* This is the buffer's markbit */
1449 mark_object (&buffer
->name
);
1450 XMARK (buffer
->name
);
1453 mark_object (buffer
->syntax_table
);
1455 /* Mark the various string-pointers in the buffer object.
1456 Since the strings may be relocated, we must mark them
1457 in their actual slots. So gc_sweep must convert each slot
1458 back to an ordinary C pointer. */
1459 XSET (*(Lisp_Object
*)&buffer
->upcase_table
,
1460 Lisp_String
, buffer
->upcase_table
);
1461 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1462 XSET (*(Lisp_Object
*)&buffer
->downcase_table
,
1463 Lisp_String
, buffer
->downcase_table
);
1464 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1466 XSET (*(Lisp_Object
*)&buffer
->sort_table
,
1467 Lisp_String
, buffer
->sort_table
);
1468 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1469 XSET (*(Lisp_Object
*)&buffer
->folding_sort_table
,
1470 Lisp_String
, buffer
->folding_sort_table
);
1471 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1474 for (ptr
= &buffer
->name
+ 1;
1475 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1480 /* Find all structures not marked, and free them. */
1485 total_string_size
= 0;
1488 /* Put all unmarked conses on free list */
1490 register struct cons_block
*cblk
;
1491 register int lim
= cons_block_index
;
1492 register int num_free
= 0, num_used
= 0;
1496 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1499 for (i
= 0; i
< lim
; i
++)
1500 if (!XMARKBIT (cblk
->conses
[i
].car
))
1502 XFASTINT (cblk
->conses
[i
].car
) = (int) cons_free_list
;
1504 cons_free_list
= &cblk
->conses
[i
];
1509 XUNMARK (cblk
->conses
[i
].car
);
1511 lim
= CONS_BLOCK_SIZE
;
1513 total_conses
= num_used
;
1514 total_free_conses
= num_free
;
1517 #ifdef LISP_FLOAT_TYPE
1518 /* Put all unmarked floats on free list */
1520 register struct float_block
*fblk
;
1521 register int lim
= float_block_index
;
1522 register int num_free
= 0, num_used
= 0;
1524 float_free_list
= 0;
1526 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1529 for (i
= 0; i
< lim
; i
++)
1530 if (!XMARKBIT (fblk
->floats
[i
].type
))
1532 XFASTINT (fblk
->floats
[i
].type
) = (int) float_free_list
;
1534 float_free_list
= &fblk
->floats
[i
];
1539 XUNMARK (fblk
->floats
[i
].type
);
1541 lim
= FLOAT_BLOCK_SIZE
;
1543 total_floats
= num_used
;
1544 total_free_floats
= num_free
;
1546 #endif /* LISP_FLOAT_TYPE */
1548 /* Put all unmarked symbols on free list */
1550 register struct symbol_block
*sblk
;
1551 register int lim
= symbol_block_index
;
1552 register int num_free
= 0, num_used
= 0;
1554 symbol_free_list
= 0;
1556 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1559 for (i
= 0; i
< lim
; i
++)
1560 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1562 XFASTINT (sblk
->symbols
[i
].value
) = (int) symbol_free_list
;
1563 symbol_free_list
= &sblk
->symbols
[i
];
1569 sblk
->symbols
[i
].name
1570 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1571 XUNMARK (sblk
->symbols
[i
].plist
);
1573 lim
= SYMBOL_BLOCK_SIZE
;
1575 total_symbols
= num_used
;
1576 total_free_symbols
= num_free
;
1580 /* Put all unmarked markers on free list.
1581 Dechain each one first from the buffer it points into. */
1583 register struct marker_block
*mblk
;
1584 struct Lisp_Marker
*tem1
;
1585 register int lim
= marker_block_index
;
1586 register int num_free
= 0, num_used
= 0;
1588 marker_free_list
= 0;
1590 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1593 for (i
= 0; i
< lim
; i
++)
1594 if (!XMARKBIT (mblk
->markers
[i
].chain
))
1597 tem1
= &mblk
->markers
[i
]; /* tem1 avoids Sun compiler bug */
1598 XSET (tem
, Lisp_Marker
, tem1
);
1599 unchain_marker (tem
);
1600 XFASTINT (mblk
->markers
[i
].chain
) = (int) marker_free_list
;
1601 marker_free_list
= &mblk
->markers
[i
];
1607 XUNMARK (mblk
->markers
[i
].chain
);
1609 lim
= MARKER_BLOCK_SIZE
;
1612 total_markers
= num_used
;
1613 total_free_markers
= num_free
;
1616 /* Free all unmarked buffers */
1618 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1621 if (!XMARKBIT (buffer
->name
))
1624 prev
->next
= buffer
->next
;
1626 all_buffers
= buffer
->next
;
1627 next
= buffer
->next
;
1633 XUNMARK (buffer
->name
);
1636 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1637 for purposes of marking and relocation.
1638 Turn them back into C pointers now. */
1639 buffer
->upcase_table
1640 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
1641 buffer
->downcase_table
1642 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
1644 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
1645 buffer
->folding_sort_table
1646 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
1649 prev
= buffer
, buffer
= buffer
->next
;
1653 #endif /* standalone */
1655 /* Free all unmarked vectors */
1657 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
1658 total_vector_size
= 0;
1661 if (!(vector
->size
& ARRAY_MARK_FLAG
))
1664 prev
->next
= vector
->next
;
1666 all_vectors
= vector
->next
;
1667 next
= vector
->next
;
1673 vector
->size
&= ~ARRAY_MARK_FLAG
;
1674 total_vector_size
+= vector
->size
;
1675 prev
= vector
, vector
= vector
->next
;
1679 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
1681 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
1684 if (!(((struct Lisp_String
*)(&sb
->chars
[0]))->size
& ARRAY_MARK_FLAG
))
1687 prev
->next
= sb
->next
;
1689 large_string_blocks
= sb
->next
;
1696 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
1697 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
1698 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
1699 prev
= sb
, sb
= sb
->next
;
1704 /* Compactify strings, relocate references to them, and
1705 free any string blocks that become empty. */
1710 /* String block of old strings we are scanning. */
1711 register struct string_block
*from_sb
;
1712 /* A preceding string block (or maybe the same one)
1713 where we are copying the still-live strings to. */
1714 register struct string_block
*to_sb
;
1718 to_sb
= first_string_block
;
1721 /* Scan each existing string block sequentially, string by string. */
1722 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
1725 /* POS is the index of the next string in the block. */
1726 while (pos
< from_sb
->pos
)
1728 register struct Lisp_String
*nextstr
1729 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
1731 register struct Lisp_String
*newaddr
;
1732 register int size
= nextstr
->size
;
1734 /* NEXTSTR is the old address of the next string.
1735 Just skip it if it isn't marked. */
1736 if ((unsigned) size
> STRING_BLOCK_SIZE
)
1738 /* It is marked, so its size field is really a chain of refs.
1739 Find the end of the chain, where the actual size lives. */
1740 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1742 if (size
& 1) size
^= MARKBIT
| 1;
1743 size
= *(int *)size
& ~MARKBIT
;
1746 total_string_size
+= size
;
1748 /* If it won't fit in TO_SB, close it out,
1749 and move to the next sb. Keep doing so until
1750 TO_SB reaches a large enough, empty enough string block.
1751 We know that TO_SB cannot advance past FROM_SB here
1752 since FROM_SB is large enough to contain this string.
1753 Any string blocks skipped here
1754 will be patched out and freed later. */
1755 while (to_pos
+ STRING_FULLSIZE (size
)
1756 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
1758 to_sb
->pos
= to_pos
;
1759 to_sb
= to_sb
->next
;
1762 /* Compute new address of this string
1763 and update TO_POS for the space being used. */
1764 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
1765 to_pos
+= STRING_FULLSIZE (size
);
1767 /* Copy the string itself to the new place. */
1768 if (nextstr
!= newaddr
)
1769 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (int));
1771 /* Go through NEXTSTR's chain of references
1772 and make each slot in the chain point to
1773 the new address of this string. */
1774 size
= newaddr
->size
;
1775 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1777 register Lisp_Object
*objptr
;
1778 if (size
& 1) size
^= MARKBIT
| 1;
1779 objptr
= (Lisp_Object
*)size
;
1781 size
= XFASTINT (*objptr
) & ~MARKBIT
;
1782 if (XMARKBIT (*objptr
))
1784 XSET (*objptr
, Lisp_String
, newaddr
);
1788 XSET (*objptr
, Lisp_String
, newaddr
);
1790 /* Store the actual size in the size field. */
1791 newaddr
->size
= size
;
1793 pos
+= STRING_FULLSIZE (size
);
1797 /* Close out the last string block still used and free any that follow. */
1798 to_sb
->pos
= to_pos
;
1799 current_string_block
= to_sb
;
1801 from_sb
= to_sb
->next
;
1805 to_sb
= from_sb
->next
;
1810 /* Free any empty string blocks further back in the chain.
1811 This loop will never free first_string_block, but it is very
1812 unlikely that that one will become empty, so why bother checking? */
1814 from_sb
= first_string_block
;
1815 while (to_sb
= from_sb
->next
)
1817 if (to_sb
->pos
== 0)
1819 if (from_sb
->next
= to_sb
->next
)
1820 from_sb
->next
->prev
= from_sb
;
1828 /* Initialization */
1832 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
1835 ignore_warnings
= 1;
1840 #ifdef LISP_FLOAT_TYPE
1842 #endif /* LISP_FLOAT_TYPE */
1843 ignore_warnings
= 0;
1846 consing_since_gc
= 0;
1847 gc_cons_threshold
= 100000;
1848 #ifdef VIRT_ADDR_VARIES
1849 malloc_sbrk_unused
= 1<<22; /* A large number */
1850 malloc_sbrk_used
= 100000; /* as reasonable as any number */
1851 #endif /* VIRT_ADDR_VARIES */
1862 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
1863 "*Number of bytes of consing between garbage collections.\n\
1864 Garbage collection can happen automatically once this many bytes have been\n\
1865 allocated since the last garbage collection. All data types count.\n\n\
1866 Garbage collection happens automatically only when `eval' is called.\n\n\
1867 By binding this temporarily to a large number, you can effectively\n\
1868 prevent garbage collection during a part of the program.");
1870 DEFVAR_INT ("pure-bytes-used", &pureptr
,
1871 "Number of bytes of sharable Lisp data allocated so far.");
1874 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
1875 "Number of bytes of unshared memory allocated in this session.");
1877 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
1878 "Number of bytes of unshared memory remaining available in this session.");
1881 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
1882 "Non-nil means loading Lisp code in order to dump an executable.\n\
1883 This means that certain objects should be allocated in shared (pure) space.");
1885 DEFVAR_INT ("undo-threshold", &undo_threshold
,
1886 "Keep no more undo information once it exceeds this size.\n\
1887 This threshold is applied when garbage collection happens.\n\
1888 The size is counted as the number of bytes occupied,\n\
1889 which includes both saved text and other data.");
1890 undo_threshold
= 20000;
1892 DEFVAR_INT ("undo-high-threshold", &undo_high_threshold
,
1893 "Don't keep more than this much size of undo information.\n\
1894 A command which pushes past this size is itself forgotten.\n\
1895 This threshold is applied when garbage collection happens.\n\
1896 The size is counted as the number of bytes occupied,\n\
1897 which includes both saved text and other data.");
1898 undo_high_threshold
= 30000;
1903 defsubr (&Smake_byte_code
);
1904 defsubr (&Smake_list
);
1905 defsubr (&Smake_vector
);
1906 defsubr (&Smake_string
);
1907 defsubr (&Smake_rope
);
1908 defsubr (&Srope_elt
);
1909 defsubr (&Smake_symbol
);
1910 defsubr (&Smake_marker
);
1911 defsubr (&Spurecopy
);
1912 defsubr (&Sgarbage_collect
);