1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1992, 1993 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 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
23 #include "intervals.h"
31 #include "syssignal.h"
33 #define max(A,B) ((A) > (B) ? (A) : (B))
35 /* Macro to verify that storage intended for Lisp objects is not
36 out of range to fit in the space for a pointer.
37 ADDRESS is the start of the block, and SIZE
38 is the amount of space within which objects can start. */
39 #define VALIDATE_LISP_STORAGE(address, size) \
43 XSET (val, Lisp_Cons, (char *) address + size); \
44 if ((char *) XCONS (val) != (char *) address + size) \
51 /* Number of bytes of consing done since the last gc */
54 /* Number of bytes of consing since gc before another gc should be done. */
55 int gc_cons_threshold
;
57 /* Nonzero during gc */
60 #ifndef VIRT_ADDR_VARIES
62 #endif /* VIRT_ADDR_VARIES */
65 #ifndef VIRT_ADDR_VARIES
67 #endif /* VIRT_ADDR_VARIES */
68 int malloc_sbrk_unused
;
70 /* Two limits controlling how much undo information to keep. */
72 int undo_strong_limit
;
74 /* Non-nil means defun should do purecopy on the function definition */
75 Lisp_Object Vpurify_flag
;
78 int pure
[PURESIZE
/ sizeof (int)] = {0,}; /* Force it into data space! */
79 #define PUREBEG (char *) pure
81 #define pure PURE_SEG_BITS /* Use shared memory segment */
82 #define PUREBEG (char *)PURE_SEG_BITS
84 /* This variable is used only by the XPNTR macro when HAVE_SHM is
85 defined. If we used the PURESIZE macro directly there, that would
86 make most of emacs dependent on puresize.h, which we don't want -
87 you should be able to change that without too much recompilation.
88 So map_in_data initializes pure_size, and the dependencies work
91 #endif /* not HAVE_SHM */
93 /* Index in pure at which next pure object will be allocated. */
96 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
97 char *pending_malloc_warning
;
99 /* Maximum amount of C stack to save when a GC happens. */
101 #ifndef MAX_SAVE_STACK
102 #define MAX_SAVE_STACK 16000
105 /* Buffer in which we save a copy of the C stack at each GC. */
110 /* Non-zero means ignore malloc warnings. Set during initialization. */
113 static void mark_object (), mark_buffer ();
114 static void clear_marks (), gc_sweep ();
115 static void compact_strings ();
117 /* Versions of malloc and realloc that print warnings as memory gets full. */
120 malloc_warning_1 (str
)
123 Fprinc (str
, Vstandard_output
);
124 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
125 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
126 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
130 /* malloc calls this if it finds we are near exhausting storage */
134 pending_malloc_warning
= str
;
137 display_malloc_warning ()
139 register Lisp_Object val
;
141 val
= build_string (pending_malloc_warning
);
142 pending_malloc_warning
= 0;
143 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
146 /* Called if malloc returns zero */
149 error ("Memory exhausted");
152 /* like malloc and realloc but check for no memory left */
160 val
= (long *) malloc (size
);
162 if (!val
&& size
) memory_full ();
167 xrealloc (block
, size
)
173 /* We must call malloc explicitly when BLOCK is 0, since some
174 reallocs don't do this. */
176 val
= (long *) malloc (size
);
178 val
= (long *) realloc (block
, size
);
180 if (!val
&& size
) memory_full ();
184 /* Interval allocation. */
186 #ifdef USE_TEXT_PROPERTIES
187 #define INTERVAL_BLOCK_SIZE \
188 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
190 struct interval_block
192 struct interval_block
*next
;
193 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
196 struct interval_block
*interval_block
;
197 static int interval_block_index
;
199 INTERVAL interval_free_list
;
205 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
206 interval_block
->next
= 0;
207 bzero (interval_block
->intervals
, sizeof interval_block
->intervals
);
208 interval_block_index
= 0;
209 interval_free_list
= 0;
212 #define INIT_INTERVALS init_intervals ()
219 if (interval_free_list
)
221 val
= interval_free_list
;
222 interval_free_list
= interval_free_list
->parent
;
226 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
228 register struct interval_block
*newi
229 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
234 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
235 newi
->next
= interval_block
;
236 interval_block
= newi
;
237 interval_block_index
= 0;
239 val
= &interval_block
->intervals
[interval_block_index
++];
241 consing_since_gc
+= sizeof (struct interval
);
242 RESET_INTERVAL (val
);
246 static int total_free_intervals
, total_intervals
;
248 /* Mark the pointers of one interval. */
254 if (XMARKBIT (i
->plist
))
256 mark_object (&i
->plist
);
261 mark_interval_tree (tree
)
262 register INTERVAL tree
;
264 if (XMARKBIT (tree
->plist
))
267 traverse_intervals (tree
, 1, 0, mark_interval
);
270 #define MARK_INTERVAL_TREE(i) \
271 { if (!NULL_INTERVAL_P (i)) mark_interval_tree (i); }
273 /* The oddity in the call to XUNMARK is necessary because XUNMARK
274 expands to an assigment to its argument, and most C compilers don't
275 support casts on the left operand of `='. */
276 #define UNMARK_BALANCE_INTERVALS(i) \
278 if (! NULL_INTERVAL_P (i)) \
280 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
281 (i) = balance_intervals (i); \
285 #else /* no interval use */
287 #define INIT_INTERVALS
289 #define UNMARK_BALANCE_INTERVALS(i)
290 #define MARK_INTERVAL_TREE(i)
292 #endif /* no interval use */
294 /* Floating point allocation. */
296 #ifdef LISP_FLOAT_TYPE
297 /* Allocation of float cells, just like conses */
298 /* We store float cells inside of float_blocks, allocating a new
299 float_block with malloc whenever necessary. Float cells reclaimed by
300 GC are put on a free list to be reallocated before allocating
301 any new float cells from the latest float_block.
303 Each float_block is just under 1020 bytes long,
304 since malloc really allocates in units of powers of two
305 and uses 4 bytes for its own overhead. */
307 #define FLOAT_BLOCK_SIZE \
308 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
312 struct float_block
*next
;
313 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
316 struct float_block
*float_block
;
317 int float_block_index
;
319 struct Lisp_Float
*float_free_list
;
324 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
325 float_block
->next
= 0;
326 bzero (float_block
->floats
, sizeof float_block
->floats
);
327 float_block_index
= 0;
331 /* Explicitly free a float cell. */
333 struct Lisp_Float
*ptr
;
335 XFASTINT (ptr
->type
) = (int) float_free_list
;
336 float_free_list
= ptr
;
340 make_float (float_value
)
343 register Lisp_Object val
;
347 XSET (val
, Lisp_Float
, float_free_list
);
348 float_free_list
= (struct Lisp_Float
*) XFASTINT (float_free_list
->type
);
352 if (float_block_index
== FLOAT_BLOCK_SIZE
)
354 register struct float_block
*new = (struct float_block
*) malloc (sizeof (struct float_block
));
355 if (!new) memory_full ();
356 VALIDATE_LISP_STORAGE (new, sizeof *new);
357 new->next
= float_block
;
359 float_block_index
= 0;
361 XSET (val
, Lisp_Float
, &float_block
->floats
[float_block_index
++]);
363 XFLOAT (val
)->data
= float_value
;
364 XFLOAT (val
)->type
= 0; /* bug chasing -wsr */
365 consing_since_gc
+= sizeof (struct Lisp_Float
);
369 #endif /* LISP_FLOAT_TYPE */
371 /* Allocation of cons cells */
372 /* We store cons cells inside of cons_blocks, allocating a new
373 cons_block with malloc whenever necessary. Cons cells reclaimed by
374 GC are put on a free list to be reallocated before allocating
375 any new cons cells from the latest cons_block.
377 Each cons_block is just under 1020 bytes long,
378 since malloc really allocates in units of powers of two
379 and uses 4 bytes for its own overhead. */
381 #define CONS_BLOCK_SIZE \
382 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
386 struct cons_block
*next
;
387 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
390 struct cons_block
*cons_block
;
391 int cons_block_index
;
393 struct Lisp_Cons
*cons_free_list
;
398 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
399 cons_block
->next
= 0;
400 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
401 cons_block_index
= 0;
405 /* Explicitly free a cons cell. */
407 struct Lisp_Cons
*ptr
;
409 XFASTINT (ptr
->car
) = (int) cons_free_list
;
410 cons_free_list
= ptr
;
413 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
414 "Create a new cons, give it CAR and CDR as components, and return it.")
416 Lisp_Object car
, cdr
;
418 register Lisp_Object val
;
422 XSET (val
, Lisp_Cons
, cons_free_list
);
423 cons_free_list
= (struct Lisp_Cons
*) XFASTINT (cons_free_list
->car
);
427 if (cons_block_index
== CONS_BLOCK_SIZE
)
429 register struct cons_block
*new = (struct cons_block
*) malloc (sizeof (struct cons_block
));
430 if (!new) memory_full ();
431 VALIDATE_LISP_STORAGE (new, sizeof *new);
432 new->next
= cons_block
;
434 cons_block_index
= 0;
436 XSET (val
, Lisp_Cons
, &cons_block
->conses
[cons_block_index
++]);
438 XCONS (val
)->car
= car
;
439 XCONS (val
)->cdr
= cdr
;
440 consing_since_gc
+= sizeof (struct Lisp_Cons
);
444 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
445 "Return a newly created list with specified arguments as elements.\n\
446 Any number of arguments, even zero arguments, are allowed.")
449 register Lisp_Object
*args
;
451 register Lisp_Object len
, val
, val_tail
;
453 XFASTINT (len
) = nargs
;
454 val
= Fmake_list (len
, Qnil
);
456 while (!NILP (val_tail
))
458 XCONS (val_tail
)->car
= *args
++;
459 val_tail
= XCONS (val_tail
)->cdr
;
464 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
465 "Return a newly created list of length LENGTH, with each element being INIT.")
467 register Lisp_Object length
, init
;
469 register Lisp_Object val
;
472 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
473 length
= wrong_type_argument (Qnatnump
, length
);
474 size
= XINT (length
);
478 val
= Fcons (init
, val
);
482 /* Allocation of vectors */
484 struct Lisp_Vector
*all_vectors
;
486 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
487 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
488 See also the function `vector'.")
490 register Lisp_Object length
, init
;
492 register int sizei
, index
;
493 register Lisp_Object vector
;
494 register struct Lisp_Vector
*p
;
496 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
497 length
= wrong_type_argument (Qnatnump
, length
);
498 sizei
= XINT (length
);
500 p
= (struct Lisp_Vector
*) malloc (sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
));
503 VALIDATE_LISP_STORAGE (p
, 0);
505 XSET (vector
, Lisp_Vector
, p
);
506 consing_since_gc
+= sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
);
509 p
->next
= all_vectors
;
512 for (index
= 0; index
< sizei
; index
++)
513 p
->contents
[index
] = init
;
518 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
519 "Return a newly created vector with specified arguments as elements.\n\
520 Any number of arguments, even zero arguments, are allowed.")
525 register Lisp_Object len
, val
;
527 register struct Lisp_Vector
*p
;
529 XFASTINT (len
) = nargs
;
530 val
= Fmake_vector (len
, Qnil
);
532 for (index
= 0; index
< nargs
; index
++)
533 p
->contents
[index
] = args
[index
];
537 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
538 "Create a byte-code object with specified arguments as elements.\n\
539 The arguments should be the arglist, bytecode-string, constant vector,\n\
540 stack size, (optional) doc string, and (optional) interactive spec.\n\
541 The first four arguments are required; at most six have any\n\
547 register Lisp_Object len
, val
;
549 register struct Lisp_Vector
*p
;
551 XFASTINT (len
) = nargs
;
552 if (!NILP (Vpurify_flag
))
553 val
= make_pure_vector (len
);
555 val
= Fmake_vector (len
, Qnil
);
557 for (index
= 0; index
< nargs
; index
++)
559 if (!NILP (Vpurify_flag
))
560 args
[index
] = Fpurecopy (args
[index
]);
561 p
->contents
[index
] = args
[index
];
563 XSETTYPE (val
, Lisp_Compiled
);
567 /* Allocation of symbols.
568 Just like allocation of conses!
570 Each symbol_block is just under 1020 bytes long,
571 since malloc really allocates in units of powers of two
572 and uses 4 bytes for its own overhead. */
574 #define SYMBOL_BLOCK_SIZE \
575 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
579 struct symbol_block
*next
;
580 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
583 struct symbol_block
*symbol_block
;
584 int symbol_block_index
;
586 struct Lisp_Symbol
*symbol_free_list
;
591 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
592 symbol_block
->next
= 0;
593 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
594 symbol_block_index
= 0;
595 symbol_free_list
= 0;
598 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
599 "Return a newly allocated uninterned symbol whose name is NAME.\n\
600 Its value and function definition are void, and its property list is nil.")
604 register Lisp_Object val
;
605 register struct Lisp_Symbol
*p
;
607 CHECK_STRING (str
, 0);
609 if (symbol_free_list
)
611 XSET (val
, Lisp_Symbol
, symbol_free_list
);
613 = (struct Lisp_Symbol
*) XFASTINT (symbol_free_list
->value
);
617 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
619 struct symbol_block
*new = (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
620 if (!new) memory_full ();
621 VALIDATE_LISP_STORAGE (new, sizeof *new);
622 new->next
= symbol_block
;
624 symbol_block_index
= 0;
626 XSET (val
, Lisp_Symbol
, &symbol_block
->symbols
[symbol_block_index
++]);
629 p
->name
= XSTRING (str
);
632 p
->function
= Qunbound
;
634 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
638 /* Allocation of markers.
639 Works like allocation of conses. */
641 #define MARKER_BLOCK_SIZE \
642 ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker))
646 struct marker_block
*next
;
647 struct Lisp_Marker markers
[MARKER_BLOCK_SIZE
];
650 struct marker_block
*marker_block
;
651 int marker_block_index
;
653 struct Lisp_Marker
*marker_free_list
;
658 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
659 marker_block
->next
= 0;
660 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
661 marker_block_index
= 0;
662 marker_free_list
= 0;
665 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
666 "Return a newly allocated marker which does not point at any place.")
669 register Lisp_Object val
;
670 register struct Lisp_Marker
*p
;
672 if (marker_free_list
)
674 XSET (val
, Lisp_Marker
, marker_free_list
);
676 = (struct Lisp_Marker
*) XFASTINT (marker_free_list
->chain
);
680 if (marker_block_index
== MARKER_BLOCK_SIZE
)
682 struct marker_block
*new = (struct marker_block
*) malloc (sizeof (struct marker_block
));
683 if (!new) memory_full ();
684 VALIDATE_LISP_STORAGE (new, sizeof *new);
685 new->next
= marker_block
;
687 marker_block_index
= 0;
689 XSET (val
, Lisp_Marker
, &marker_block
->markers
[marker_block_index
++]);
695 consing_since_gc
+= sizeof (struct Lisp_Marker
);
699 /* Allocation of strings */
701 /* Strings reside inside of string_blocks. The entire data of the string,
702 both the size and the contents, live in part of the `chars' component of a string_block.
703 The `pos' component is the index within `chars' of the first free byte.
705 first_string_block points to the first string_block ever allocated.
706 Each block points to the next one with its `next' field.
707 The `prev' fields chain in reverse order.
708 The last one allocated is the one currently being filled.
709 current_string_block points to it.
711 The string_blocks that hold individual large strings
712 go in a separate chain, started by large_string_blocks. */
715 /* String blocks contain this many useful bytes.
716 8188 is power of 2, minus 4 for malloc overhead. */
717 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
719 /* A string bigger than this gets its own specially-made string block
720 if it doesn't fit in the current one. */
721 #define STRING_BLOCK_OUTSIZE 1024
723 struct string_block_head
725 struct string_block
*next
, *prev
;
731 struct string_block
*next
, *prev
;
733 char chars
[STRING_BLOCK_SIZE
];
736 /* This points to the string block we are now allocating strings. */
738 struct string_block
*current_string_block
;
740 /* This points to the oldest string block, the one that starts the chain. */
742 struct string_block
*first_string_block
;
744 /* Last string block in chain of those made for individual large strings. */
746 struct string_block
*large_string_blocks
;
748 /* If SIZE is the length of a string, this returns how many bytes
749 the string occupies in a string_block (including padding). */
751 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
753 #define PAD (sizeof (int))
756 #define STRING_FULLSIZE(SIZE) \
757 (((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1))
763 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
764 first_string_block
= current_string_block
;
765 consing_since_gc
+= sizeof (struct string_block
);
766 current_string_block
->next
= 0;
767 current_string_block
->prev
= 0;
768 current_string_block
->pos
= 0;
769 large_string_blocks
= 0;
772 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
773 "Return a newly created string of length LENGTH, with each element being INIT.\n\
774 Both LENGTH and INIT must be numbers.")
776 Lisp_Object length
, init
;
778 register Lisp_Object val
;
779 register unsigned char *p
, *end
, c
;
781 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
782 length
= wrong_type_argument (Qnatnump
, length
);
783 CHECK_NUMBER (init
, 1);
784 val
= make_uninit_string (XINT (length
));
786 p
= XSTRING (val
)->data
;
787 end
= p
+ XSTRING (val
)->size
;
795 make_string (contents
, length
)
799 register Lisp_Object val
;
800 val
= make_uninit_string (length
);
801 bcopy (contents
, XSTRING (val
)->data
, length
);
809 return make_string (str
, strlen (str
));
813 make_uninit_string (length
)
816 register Lisp_Object val
;
817 register int fullsize
= STRING_FULLSIZE (length
);
819 if (length
< 0) abort ();
821 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
822 /* This string can fit in the current string block */
824 XSET (val
, Lisp_String
,
825 (struct Lisp_String
*) (current_string_block
->chars
+ current_string_block
->pos
));
826 current_string_block
->pos
+= fullsize
;
828 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
829 /* This string gets its own string block */
831 register struct string_block
*new
832 = (struct string_block
*) malloc (sizeof (struct string_block_head
) + fullsize
);
833 VALIDATE_LISP_STORAGE (new, 0);
834 if (!new) memory_full ();
835 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
837 new->next
= large_string_blocks
;
838 large_string_blocks
= new;
839 XSET (val
, Lisp_String
,
840 (struct Lisp_String
*) ((struct string_block_head
*)new + 1));
843 /* Make a new current string block and start it off with this string */
845 register struct string_block
*new
846 = (struct string_block
*) malloc (sizeof (struct string_block
));
847 if (!new) memory_full ();
848 VALIDATE_LISP_STORAGE (new, sizeof *new);
849 consing_since_gc
+= sizeof (struct string_block
);
850 current_string_block
->next
= new;
851 new->prev
= current_string_block
;
853 current_string_block
= new;
855 XSET (val
, Lisp_String
,
856 (struct Lisp_String
*) current_string_block
->chars
);
859 XSTRING (val
)->size
= length
;
860 XSTRING (val
)->data
[length
] = 0;
861 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
866 /* Return a newly created vector or string with specified arguments as
867 elements. If all the arguments are characters, make a string;
868 otherwise, make a vector. Any number of arguments, even zero
869 arguments, are allowed. */
872 make_array (nargs
, args
)
878 for (i
= 0; i
< nargs
; i
++)
879 if (XTYPE (args
[i
]) != Lisp_Int
880 || (unsigned) XINT (args
[i
]) >= 0400)
881 return Fvector (nargs
, args
);
883 /* Since the loop exited, we know that all the things in it are
884 characters, so we can make a string. */
886 Lisp_Object result
= Fmake_string (nargs
, make_number (0));
888 for (i
= 0; i
< nargs
; i
++)
889 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
895 /* Allocation of ropes. */
897 /* Note: the user cannot manipulate ropes portably by referring
898 to the chars of the string, because combining two chars to make a GLYPH
899 depends on endianness. */
901 DEFUN ("make-rope", Fmake_rope
, Smake_rope
, 0, MANY
, 0,
902 "Return a newly created rope containing the arguments of this function.\n\
903 A rope is a string, except that its contents will be treated as an\n\
904 array of glyphs, where a glyph is an integer type that may be larger\n\
905 than a character. Emacs is normally configured to use 8-bit glyphs,\n\
906 so ropes are normally no different from strings. But Emacs may be\n\
907 configured to use 16-bit glyphs, to allow the use of larger fonts.\n\
909 Each argument (which must be an integer) specifies one glyph, whatever\n\
910 size glyphs may be.\n\
912 See variable `buffer-display-table' for the uses of ropes.")
918 register Lisp_Object val
;
921 val
= make_uninit_string (nargs
* sizeof (GLYPH
));
923 p
= (GLYPH
*) XSTRING (val
)->data
;
924 for (i
= 0; i
< nargs
; i
++)
926 CHECK_NUMBER (args
[i
], i
);
927 p
[i
] = XFASTINT (args
[i
]);
932 DEFUN ("rope-elt", Frope_elt
, Srope_elt
, 2, 2, 0,
933 "Return an element of rope R at index N.\n\
934 A rope is a string in which each pair of bytes is considered an element.\n\
935 See variable `buffer-display-table' for the uses of ropes.")
941 if ((XSTRING (r
)->size
/ sizeof (GLYPH
)) <= XINT (n
) || XINT (n
) < 0)
942 args_out_of_range (r
, n
);
943 return ((GLYPH
*) XSTRING (r
)->data
)[XFASTINT (n
)];
946 /* Pure storage management. */
948 /* Must get an error if pure storage is full,
949 since if it cannot hold a large string
950 it may be able to hold conses that point to that string;
951 then the string is not protected from gc. */
954 make_pure_string (data
, length
)
958 register Lisp_Object
new;
959 register int size
= sizeof (int) + INTERVAL_PTR_SIZE
+ length
+ 1;
961 if (pureptr
+ size
> PURESIZE
)
962 error ("Pure Lisp storage exhausted");
963 XSET (new, Lisp_String
, PUREBEG
+ pureptr
);
964 XSTRING (new)->size
= length
;
965 bcopy (data
, XSTRING (new)->data
, length
);
966 XSTRING (new)->data
[length
] = 0;
967 pureptr
+= (size
+ sizeof (int) - 1)
968 / sizeof (int) * sizeof (int);
974 Lisp_Object car
, cdr
;
976 register Lisp_Object
new;
978 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
979 error ("Pure Lisp storage exhausted");
980 XSET (new, Lisp_Cons
, PUREBEG
+ pureptr
);
981 pureptr
+= sizeof (struct Lisp_Cons
);
982 XCONS (new)->car
= Fpurecopy (car
);
983 XCONS (new)->cdr
= Fpurecopy (cdr
);
987 #ifdef LISP_FLOAT_TYPE
990 make_pure_float (num
)
993 register Lisp_Object
new;
995 /* Make sure that pureptr is aligned on at least a sizeof (double)
996 boundary. Some architectures (like the sparc) require this, and
997 I suspect that floats are rare enough that it's no tragedy for
999 pureptr
= (pureptr
+ sizeof (num
) - 1) & - sizeof (num
);
1001 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1002 error ("Pure Lisp storage exhausted");
1003 XSET (new, Lisp_Float
, PUREBEG
+ pureptr
);
1004 pureptr
+= sizeof (struct Lisp_Float
);
1005 XFLOAT (new)->data
= num
;
1006 XFLOAT (new)->type
= 0; /* bug chasing -wsr */
1010 #endif /* LISP_FLOAT_TYPE */
1013 make_pure_vector (len
)
1016 register Lisp_Object
new;
1017 register int size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1019 if (pureptr
+ size
> PURESIZE
)
1020 error ("Pure Lisp storage exhausted");
1022 XSET (new, Lisp_Vector
, PUREBEG
+ pureptr
);
1024 XVECTOR (new)->size
= len
;
1028 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1029 "Make a copy of OBJECT in pure storage.\n\
1030 Recursively copies contents of vectors and cons cells.\n\
1031 Does not copy symbols.")
1033 register Lisp_Object obj
;
1035 register Lisp_Object
new, tem
;
1038 if (NILP (Vpurify_flag
))
1041 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1042 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1045 #ifdef SWITCH_ENUM_BUG
1046 switch ((int) XTYPE (obj
))
1048 switch (XTYPE (obj
))
1052 error ("Attempt to copy a marker to pure storage");
1055 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1057 #ifdef LISP_FLOAT_TYPE
1059 return make_pure_float (XFLOAT (obj
)->data
);
1060 #endif /* LISP_FLOAT_TYPE */
1063 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1067 new = make_pure_vector (XVECTOR (obj
)->size
);
1068 for (i
= 0; i
< XVECTOR (obj
)->size
; i
++)
1070 tem
= XVECTOR (obj
)->contents
[i
];
1071 XVECTOR (new)->contents
[i
] = Fpurecopy (tem
);
1073 XSETTYPE (new, XTYPE (obj
));
1081 /* Recording what needs to be marked for gc. */
1083 struct gcpro
*gcprolist
;
1085 #define NSTATICS 512
1087 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1091 /* Put an entry in staticvec, pointing at the variable whose address is given */
1094 staticpro (varaddress
)
1095 Lisp_Object
*varaddress
;
1097 staticvec
[staticidx
++] = varaddress
;
1098 if (staticidx
>= NSTATICS
)
1106 struct catchtag
*next
;
1107 /* jmp_buf jmp; /* We don't need this for GC purposes */
1112 struct backtrace
*next
;
1113 Lisp_Object
*function
;
1114 Lisp_Object
*args
; /* Points to vector of args. */
1115 int nargs
; /* length of vector */
1116 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1120 /* Two flags that are set during GC in the `size' component
1121 of a string or vector. On some machines, these flags
1122 are defined by the m- file to be different bits. */
1124 /* On vector, means it has been marked.
1125 On string size field or a reference to a string,
1126 means not the last reference in the chain. */
1128 #ifndef ARRAY_MARK_FLAG
1129 #define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
1130 #endif /* no ARRAY_MARK_FLAG */
1132 /* Any slot that is a Lisp_Object can point to a string
1133 and thus can be put on a string's reference-chain
1134 and thus may need to have its ARRAY_MARK_FLAG set.
1135 This includes the slots whose markbits are used to mark
1136 the containing objects. */
1138 #if ARRAY_MARK_FLAG == MARKBIT
1142 /* Garbage collection! */
1144 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1145 int total_free_conses
, total_free_markers
, total_free_symbols
;
1146 #ifdef LISP_FLOAT_TYPE
1147 int total_free_floats
, total_floats
;
1148 #endif /* LISP_FLOAT_TYPE */
1150 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1151 "Reclaim storage for Lisp objects no longer needed.\n\
1152 Returns info on amount of space in use:\n\
1153 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1154 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1155 (USED-FLOATS . FREE-FLOATS))\n\
1156 Garbage collection happens automatically if you cons more than\n\
1157 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1160 register struct gcpro
*tail
;
1161 register struct specbinding
*bind
;
1162 struct catchtag
*catch;
1163 struct handler
*handler
;
1164 register struct backtrace
*backlist
;
1165 register Lisp_Object tem
;
1166 char *omessage
= echo_area_glyphs
;
1167 char stack_top_variable
;
1170 /* Save a copy of the contents of the stack, for debugging. */
1171 #if MAX_SAVE_STACK > 0
1172 if (NILP (Vpurify_flag
))
1174 i
= &stack_top_variable
- stack_bottom
;
1176 if (i
< MAX_SAVE_STACK
)
1178 if (stack_copy
== 0)
1179 stack_copy
= (char *) malloc (stack_copy_size
= i
);
1180 else if (stack_copy_size
< i
)
1181 stack_copy
= (char *) realloc (stack_copy
, (stack_copy_size
= i
));
1184 if ((int) (&stack_top_variable
- stack_bottom
) > 0)
1185 bcopy (stack_bottom
, stack_copy
, i
);
1187 bcopy (&stack_top_variable
, stack_copy
, i
);
1191 #endif /* MAX_SAVE_STACK > 0 */
1193 if (!noninteractive
)
1194 message1 ("Garbage collecting...");
1196 /* Don't keep command history around forever */
1197 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1199 XCONS (tem
)->cdr
= Qnil
;
1201 /* Likewise for undo information. */
1203 register struct buffer
*nextb
= all_buffers
;
1207 /* If a buffer's undo list is Qt, that means that undo is
1208 turned off in that buffer. Calling truncate_undo_list on
1209 Qt tends to return NULL, which effectively turns undo back on.
1210 So don't call truncate_undo_list if undo_list is Qt. */
1211 if (! EQ (nextb
->undo_list
, Qt
))
1213 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1215 nextb
= nextb
->next
;
1221 /* clear_marks (); */
1223 /* In each "large string", set the MARKBIT of the size field.
1224 That enables mark_object to recognize them. */
1226 register struct string_block
*b
;
1227 for (b
= large_string_blocks
; b
; b
= b
->next
)
1228 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1231 /* Mark all the special slots that serve as the roots of accessibility.
1233 Usually the special slots to mark are contained in particular structures.
1234 Then we know no slot is marked twice because the structures don't overlap.
1235 In some cases, the structures point to the slots to be marked.
1236 For these, we use MARKBIT to avoid double marking of the slot. */
1238 for (i
= 0; i
< staticidx
; i
++)
1239 mark_object (staticvec
[i
]);
1240 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1241 for (i
= 0; i
< tail
->nvars
; i
++)
1242 if (!XMARKBIT (tail
->var
[i
]))
1244 mark_object (&tail
->var
[i
]);
1245 XMARK (tail
->var
[i
]);
1247 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1249 mark_object (&bind
->symbol
);
1250 mark_object (&bind
->old_value
);
1252 for (catch = catchlist
; catch; catch = catch->next
)
1254 mark_object (&catch->tag
);
1255 mark_object (&catch->val
);
1257 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1259 mark_object (&handler
->handler
);
1260 mark_object (&handler
->var
);
1262 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1264 if (!XMARKBIT (*backlist
->function
))
1266 mark_object (backlist
->function
);
1267 XMARK (*backlist
->function
);
1269 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1272 i
= backlist
->nargs
- 1;
1274 if (!XMARKBIT (backlist
->args
[i
]))
1276 mark_object (&backlist
->args
[i
]);
1277 XMARK (backlist
->args
[i
]);
1283 /* Clear the mark bits that we set in certain root slots. */
1285 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1286 for (i
= 0; i
< tail
->nvars
; i
++)
1287 XUNMARK (tail
->var
[i
]);
1288 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1290 XUNMARK (*backlist
->function
);
1291 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1294 i
= backlist
->nargs
- 1;
1296 XUNMARK (backlist
->args
[i
]);
1298 XUNMARK (buffer_defaults
.name
);
1299 XUNMARK (buffer_local_symbols
.name
);
1301 /* clear_marks (); */
1304 consing_since_gc
= 0;
1305 if (gc_cons_threshold
< 10000)
1306 gc_cons_threshold
= 10000;
1309 message1 (omessage
);
1310 else if (!noninteractive
)
1311 message1 ("Garbage collecting...done");
1313 return Fcons (Fcons (make_number (total_conses
),
1314 make_number (total_free_conses
)),
1315 Fcons (Fcons (make_number (total_symbols
),
1316 make_number (total_free_symbols
)),
1317 Fcons (Fcons (make_number (total_markers
),
1318 make_number (total_free_markers
)),
1319 Fcons (make_number (total_string_size
),
1320 Fcons (make_number (total_vector_size
),
1322 #ifdef LISP_FLOAT_TYPE
1323 Fcons (Fcons (make_number (total_floats
),
1324 make_number (total_free_floats
)),
1326 #else /* not LISP_FLOAT_TYPE */
1328 #endif /* not LISP_FLOAT_TYPE */
1336 /* Clear marks on all conses */
1338 register struct cons_block
*cblk
;
1339 register int lim
= cons_block_index
;
1341 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1344 for (i
= 0; i
< lim
; i
++)
1345 XUNMARK (cblk
->conses
[i
].car
);
1346 lim
= CONS_BLOCK_SIZE
;
1349 /* Clear marks on all symbols */
1351 register struct symbol_block
*sblk
;
1352 register int lim
= symbol_block_index
;
1354 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1357 for (i
= 0; i
< lim
; i
++)
1359 XUNMARK (sblk
->symbols
[i
].plist
);
1361 lim
= SYMBOL_BLOCK_SIZE
;
1364 /* Clear marks on all markers */
1366 register struct marker_block
*sblk
;
1367 register int lim
= marker_block_index
;
1369 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1372 for (i
= 0; i
< lim
; i
++)
1373 XUNMARK (sblk
->markers
[i
].chain
);
1374 lim
= MARKER_BLOCK_SIZE
;
1377 /* Clear mark bits on all buffers */
1379 register struct buffer
*nextb
= all_buffers
;
1383 XUNMARK (nextb
->name
);
1384 nextb
= nextb
->next
;
1390 /* Mark reference to a Lisp_Object.
1391 If the object referred to has not been seen yet, recursively mark
1392 all the references contained in it.
1394 If the object referenced is a short string, the referrencing slot
1395 is threaded into a chain of such slots, pointed to from
1396 the `size' field of the string. The actual string size
1397 lives in the last slot in the chain. We recognize the end
1398 because it is < (unsigned) STRING_BLOCK_SIZE. */
1400 #define LAST_MARKED_SIZE 500
1401 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1402 int last_marked_index
;
1405 mark_object (objptr
)
1406 Lisp_Object
*objptr
;
1408 register Lisp_Object obj
;
1415 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1416 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1419 last_marked
[last_marked_index
++] = objptr
;
1420 if (last_marked_index
== LAST_MARKED_SIZE
)
1421 last_marked_index
= 0;
1423 #ifdef SWITCH_ENUM_BUG
1424 switch ((int) XGCTYPE (obj
))
1426 switch (XGCTYPE (obj
))
1431 register struct Lisp_String
*ptr
= XSTRING (obj
);
1433 MARK_INTERVAL_TREE (ptr
->intervals
);
1434 if (ptr
->size
& MARKBIT
)
1435 /* A large string. Just set ARRAY_MARK_FLAG. */
1436 ptr
->size
|= ARRAY_MARK_FLAG
;
1439 /* A small string. Put this reference
1440 into the chain of references to it.
1441 The address OBJPTR is even, so if the address
1442 includes MARKBIT, put it in the low bit
1443 when we store OBJPTR into the size field. */
1445 if (XMARKBIT (*objptr
))
1447 XFASTINT (*objptr
) = ptr
->size
;
1451 XFASTINT (*objptr
) = ptr
->size
;
1452 if ((int)objptr
& 1) abort ();
1453 ptr
->size
= (int) objptr
& ~MARKBIT
;
1454 if ((int) objptr
& MARKBIT
)
1463 case Lisp_Window_Configuration
:
1465 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1466 register int size
= ptr
->size
;
1467 struct Lisp_Vector
*volatile ptr1
= ptr
;
1470 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1471 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1472 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1476 mark_object (&ptr
->contents
[i
]);
1482 /* We could treat this just like a vector, but it is better
1483 to save the COMPILED_CONSTANTS element for last and avoid recursion
1486 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1487 register int size
= ptr
->size
;
1488 struct Lisp_Vector
*volatile ptr1
= ptr
;
1491 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1492 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1493 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1497 if (i
!= COMPILED_CONSTANTS
)
1498 mark_object (&ptr
->contents
[i
]);
1500 objptr
= &ptr
->contents
[COMPILED_CONSTANTS
];
1508 register struct frame
*ptr
= XFRAME (obj
);
1509 register int size
= ptr
->size
;
1511 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1512 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1514 mark_object (&ptr
->name
);
1515 mark_object (&ptr
->focus_frame
);
1516 mark_object (&ptr
->width
);
1517 mark_object (&ptr
->height
);
1518 mark_object (&ptr
->selected_window
);
1519 mark_object (&ptr
->minibuffer_window
);
1520 mark_object (&ptr
->param_alist
);
1521 mark_object (&ptr
->scrollbars
);
1522 mark_object (&ptr
->condemned_scrollbars
);
1525 #endif /* not MULTI_FRAME */
1529 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
1530 struct Lisp_Symbol
*ptrx
;
1532 if (XMARKBIT (ptr
->plist
)) break;
1534 mark_object ((Lisp_Object
*) &ptr
->value
);
1535 mark_object (&ptr
->function
);
1536 mark_object (&ptr
->plist
);
1537 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1538 mark_object (&ptr
->name
);
1542 ptrx
= ptr
; /* Use pf ptrx avoids compiler bug on Sun */
1543 XSETSYMBOL (obj
, ptrx
);
1550 XMARK (XMARKER (obj
)->chain
);
1551 /* DO NOT mark thru the marker's chain.
1552 The buffer's markers chain does not preserve markers from gc;
1553 instead, markers are removed from the chain when freed by gc. */
1557 case Lisp_Buffer_Local_Value
:
1558 case Lisp_Some_Buffer_Local_Value
:
1560 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1561 if (XMARKBIT (ptr
->car
)) break;
1563 /* If the cdr is nil, avoid recursion for the car. */
1564 if (EQ (ptr
->cdr
, Qnil
))
1571 mark_object (&ptr
->car
);
1577 #ifdef LISP_FLOAT_TYPE
1579 XMARK (XFLOAT (obj
)->type
);
1581 #endif /* LISP_FLOAT_TYPE */
1584 if (!XMARKBIT (XBUFFER (obj
)->name
))
1594 case Lisp_Buffer_Objfwd
:
1595 case Lisp_Internal_Stream
:
1596 /* Don't bother with Lisp_Buffer_Objfwd,
1597 since all markable slots in current buffer marked anyway. */
1598 /* Don't need to do Lisp_Objfwd, since the places they point
1599 are protected with staticpro. */
1607 /* Mark the pointers in a buffer structure. */
1613 register struct buffer
*buffer
= XBUFFER (buf
);
1614 register Lisp_Object
*ptr
;
1616 /* This is the buffer's markbit */
1617 mark_object (&buffer
->name
);
1618 XMARK (buffer
->name
);
1620 MARK_INTERVAL_TREE (buffer
->intervals
);
1623 mark_object (buffer
->syntax_table
);
1625 /* Mark the various string-pointers in the buffer object.
1626 Since the strings may be relocated, we must mark them
1627 in their actual slots. So gc_sweep must convert each slot
1628 back to an ordinary C pointer. */
1629 XSET (*(Lisp_Object
*)&buffer
->upcase_table
,
1630 Lisp_String
, buffer
->upcase_table
);
1631 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1632 XSET (*(Lisp_Object
*)&buffer
->downcase_table
,
1633 Lisp_String
, buffer
->downcase_table
);
1634 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1636 XSET (*(Lisp_Object
*)&buffer
->sort_table
,
1637 Lisp_String
, buffer
->sort_table
);
1638 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1639 XSET (*(Lisp_Object
*)&buffer
->folding_sort_table
,
1640 Lisp_String
, buffer
->folding_sort_table
);
1641 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1644 for (ptr
= &buffer
->name
+ 1;
1645 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1650 /* Sweep: find all structures not marked, and free them. */
1655 total_string_size
= 0;
1658 /* Put all unmarked conses on free list */
1660 register struct cons_block
*cblk
;
1661 register int lim
= cons_block_index
;
1662 register int num_free
= 0, num_used
= 0;
1666 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1669 for (i
= 0; i
< lim
; i
++)
1670 if (!XMARKBIT (cblk
->conses
[i
].car
))
1672 XFASTINT (cblk
->conses
[i
].car
) = (int) cons_free_list
;
1674 cons_free_list
= &cblk
->conses
[i
];
1679 XUNMARK (cblk
->conses
[i
].car
);
1681 lim
= CONS_BLOCK_SIZE
;
1683 total_conses
= num_used
;
1684 total_free_conses
= num_free
;
1687 #ifdef LISP_FLOAT_TYPE
1688 /* Put all unmarked floats on free list */
1690 register struct float_block
*fblk
;
1691 register int lim
= float_block_index
;
1692 register int num_free
= 0, num_used
= 0;
1694 float_free_list
= 0;
1696 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1699 for (i
= 0; i
< lim
; i
++)
1700 if (!XMARKBIT (fblk
->floats
[i
].type
))
1702 XFASTINT (fblk
->floats
[i
].type
) = (int) float_free_list
;
1704 float_free_list
= &fblk
->floats
[i
];
1709 XUNMARK (fblk
->floats
[i
].type
);
1711 lim
= FLOAT_BLOCK_SIZE
;
1713 total_floats
= num_used
;
1714 total_free_floats
= num_free
;
1716 #endif /* LISP_FLOAT_TYPE */
1718 #ifdef USE_TEXT_PROPERTIES
1719 /* Put all unmarked intervals on free list */
1721 register struct interval_block
*iblk
;
1722 register int lim
= interval_block_index
;
1723 register int num_free
= 0, num_used
= 0;
1725 interval_free_list
= 0;
1727 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1731 for (i
= 0; i
< lim
; i
++)
1733 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1735 iblk
->intervals
[i
].parent
= interval_free_list
;
1736 interval_free_list
= &iblk
->intervals
[i
];
1742 XUNMARK (iblk
->intervals
[i
].plist
);
1745 lim
= INTERVAL_BLOCK_SIZE
;
1747 total_intervals
= num_used
;
1748 total_free_intervals
= num_free
;
1750 #endif /* USE_TEXT_PROPERTIES */
1752 /* Put all unmarked symbols on free list */
1754 register struct symbol_block
*sblk
;
1755 register int lim
= symbol_block_index
;
1756 register int num_free
= 0, num_used
= 0;
1758 symbol_free_list
= 0;
1760 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1763 for (i
= 0; i
< lim
; i
++)
1764 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1766 XFASTINT (sblk
->symbols
[i
].value
) = (int) symbol_free_list
;
1767 symbol_free_list
= &sblk
->symbols
[i
];
1773 sblk
->symbols
[i
].name
1774 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1775 XUNMARK (sblk
->symbols
[i
].plist
);
1777 lim
= SYMBOL_BLOCK_SIZE
;
1779 total_symbols
= num_used
;
1780 total_free_symbols
= num_free
;
1784 /* Put all unmarked markers on free list.
1785 Dechain each one first from the buffer it points into. */
1787 register struct marker_block
*mblk
;
1788 struct Lisp_Marker
*tem1
;
1789 register int lim
= marker_block_index
;
1790 register int num_free
= 0, num_used
= 0;
1792 marker_free_list
= 0;
1794 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1797 for (i
= 0; i
< lim
; i
++)
1798 if (!XMARKBIT (mblk
->markers
[i
].chain
))
1801 tem1
= &mblk
->markers
[i
]; /* tem1 avoids Sun compiler bug */
1802 XSET (tem
, Lisp_Marker
, tem1
);
1803 unchain_marker (tem
);
1804 XFASTINT (mblk
->markers
[i
].chain
) = (int) marker_free_list
;
1805 marker_free_list
= &mblk
->markers
[i
];
1811 XUNMARK (mblk
->markers
[i
].chain
);
1813 lim
= MARKER_BLOCK_SIZE
;
1816 total_markers
= num_used
;
1817 total_free_markers
= num_free
;
1820 /* Free all unmarked buffers */
1822 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1825 if (!XMARKBIT (buffer
->name
))
1828 prev
->next
= buffer
->next
;
1830 all_buffers
= buffer
->next
;
1831 next
= buffer
->next
;
1837 XUNMARK (buffer
->name
);
1838 UNMARK_BALANCE_INTERVALS (buffer
->intervals
);
1841 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1842 for purposes of marking and relocation.
1843 Turn them back into C pointers now. */
1844 buffer
->upcase_table
1845 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
1846 buffer
->downcase_table
1847 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
1849 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
1850 buffer
->folding_sort_table
1851 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
1854 prev
= buffer
, buffer
= buffer
->next
;
1858 #endif /* standalone */
1860 /* Free all unmarked vectors */
1862 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
1863 total_vector_size
= 0;
1866 if (!(vector
->size
& ARRAY_MARK_FLAG
))
1869 prev
->next
= vector
->next
;
1871 all_vectors
= vector
->next
;
1872 next
= vector
->next
;
1878 vector
->size
&= ~ARRAY_MARK_FLAG
;
1879 total_vector_size
+= vector
->size
;
1880 prev
= vector
, vector
= vector
->next
;
1884 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
1886 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
1889 if (!(((struct Lisp_String
*)(&sb
->chars
[0]))->size
& ARRAY_MARK_FLAG
))
1892 prev
->next
= sb
->next
;
1894 large_string_blocks
= sb
->next
;
1901 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
1902 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
1903 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
1904 prev
= sb
, sb
= sb
->next
;
1909 /* Compactify strings, relocate references, and free empty string blocks. */
1914 /* String block of old strings we are scanning. */
1915 register struct string_block
*from_sb
;
1916 /* A preceding string block (or maybe the same one)
1917 where we are copying the still-live strings to. */
1918 register struct string_block
*to_sb
;
1922 to_sb
= first_string_block
;
1925 /* Scan each existing string block sequentially, string by string. */
1926 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
1929 /* POS is the index of the next string in the block. */
1930 while (pos
< from_sb
->pos
)
1932 register struct Lisp_String
*nextstr
1933 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
1935 register struct Lisp_String
*newaddr
;
1936 register int size
= nextstr
->size
;
1938 /* NEXTSTR is the old address of the next string.
1939 Just skip it if it isn't marked. */
1940 if ((unsigned) size
> STRING_BLOCK_SIZE
)
1942 /* It is marked, so its size field is really a chain of refs.
1943 Find the end of the chain, where the actual size lives. */
1944 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1946 if (size
& 1) size
^= MARKBIT
| 1;
1947 size
= *(int *)size
& ~MARKBIT
;
1950 total_string_size
+= size
;
1952 /* If it won't fit in TO_SB, close it out,
1953 and move to the next sb. Keep doing so until
1954 TO_SB reaches a large enough, empty enough string block.
1955 We know that TO_SB cannot advance past FROM_SB here
1956 since FROM_SB is large enough to contain this string.
1957 Any string blocks skipped here
1958 will be patched out and freed later. */
1959 while (to_pos
+ STRING_FULLSIZE (size
)
1960 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
1962 to_sb
->pos
= to_pos
;
1963 to_sb
= to_sb
->next
;
1966 /* Compute new address of this string
1967 and update TO_POS for the space being used. */
1968 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
1969 to_pos
+= STRING_FULLSIZE (size
);
1971 /* Copy the string itself to the new place. */
1972 if (nextstr
!= newaddr
)
1973 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (int)
1974 + INTERVAL_PTR_SIZE
);
1976 /* Go through NEXTSTR's chain of references
1977 and make each slot in the chain point to
1978 the new address of this string. */
1979 size
= newaddr
->size
;
1980 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1982 register Lisp_Object
*objptr
;
1983 if (size
& 1) size
^= MARKBIT
| 1;
1984 objptr
= (Lisp_Object
*)size
;
1986 size
= XFASTINT (*objptr
) & ~MARKBIT
;
1987 if (XMARKBIT (*objptr
))
1989 XSET (*objptr
, Lisp_String
, newaddr
);
1993 XSET (*objptr
, Lisp_String
, newaddr
);
1995 /* Store the actual size in the size field. */
1996 newaddr
->size
= size
;
1998 pos
+= STRING_FULLSIZE (size
);
2002 /* Close out the last string block still used and free any that follow. */
2003 to_sb
->pos
= to_pos
;
2004 current_string_block
= to_sb
;
2006 from_sb
= to_sb
->next
;
2010 to_sb
= from_sb
->next
;
2015 /* Free any empty string blocks further back in the chain.
2016 This loop will never free first_string_block, but it is very
2017 unlikely that that one will become empty, so why bother checking? */
2019 from_sb
= first_string_block
;
2020 while (to_sb
= from_sb
->next
)
2022 if (to_sb
->pos
== 0)
2024 if (from_sb
->next
= to_sb
->next
)
2025 from_sb
->next
->prev
= from_sb
;
2033 /* Debugging aids. */
2035 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, "",
2036 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2037 This may be helpful in debugging Emacs's memory usage.\n\
2038 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2043 XSET (end
, Lisp_Int
, (int) sbrk (0) / 1024);
2049 /* Initialization */
2053 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2056 pure_size
= PURESIZE
;
2059 ignore_warnings
= 1;
2064 #ifdef LISP_FLOAT_TYPE
2066 #endif /* LISP_FLOAT_TYPE */
2069 ignore_warnings
= 0;
2072 consing_since_gc
= 0;
2073 gc_cons_threshold
= 100000;
2074 #ifdef VIRT_ADDR_VARIES
2075 malloc_sbrk_unused
= 1<<22; /* A large number */
2076 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2077 #endif /* VIRT_ADDR_VARIES */
2088 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2089 "*Number of bytes of consing between garbage collections.\n\
2090 Garbage collection can happen automatically once this many bytes have been\n\
2091 allocated since the last garbage collection. All data types count.\n\n\
2092 Garbage collection happens automatically only when `eval' is called.\n\n\
2093 By binding this temporarily to a large number, you can effectively\n\
2094 prevent garbage collection during a part of the program.");
2096 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2097 "Number of bytes of sharable Lisp data allocated so far.");
2100 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2101 "Number of bytes of unshared memory allocated in this session.");
2103 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2104 "Number of bytes of unshared memory remaining available in this session.");
2107 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2108 "Non-nil means loading Lisp code in order to dump an executable.\n\
2109 This means that certain objects should be allocated in shared (pure) space.");
2111 DEFVAR_INT ("undo-limit", &undo_limit
,
2112 "Keep no more undo information once it exceeds this size.\n\
2113 This limit is applied when garbage collection happens.\n\
2114 The size is counted as the number of bytes occupied,\n\
2115 which includes both saved text and other data.");
2118 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2119 "Don't keep more than this much size of undo information.\n\
2120 A command which pushes past this size is itself forgotten.\n\
2121 This limit is applied when garbage collection happens.\n\
2122 The size is counted as the number of bytes occupied,\n\
2123 which includes both saved text and other data.");
2124 undo_strong_limit
= 30000;
2129 defsubr (&Smake_byte_code
);
2130 defsubr (&Smake_list
);
2131 defsubr (&Smake_vector
);
2132 defsubr (&Smake_string
);
2133 defsubr (&Smake_rope
);
2134 defsubr (&Srope_elt
);
2135 defsubr (&Smake_symbol
);
2136 defsubr (&Smake_marker
);
2137 defsubr (&Spurecopy
);
2138 defsubr (&Sgarbage_collect
);
2139 defsubr (&Smemory_limit
);