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. */
251 mark_interval (i
, dummy
)
255 if (XMARKBIT (i
->plist
))
257 mark_object (&i
->plist
);
262 mark_interval_tree (tree
)
263 register INTERVAL tree
;
265 if (XMARKBIT (tree
->plist
))
268 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
271 #define MARK_INTERVAL_TREE(i) \
272 { if (!NULL_INTERVAL_P (i)) mark_interval_tree (i); }
274 /* The oddity in the call to XUNMARK is necessary because XUNMARK
275 expands to an assigment to its argument, and most C compilers don't
276 support casts on the left operand of `='. */
277 #define UNMARK_BALANCE_INTERVALS(i) \
279 if (! NULL_INTERVAL_P (i)) \
281 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
282 (i) = balance_intervals (i); \
286 #else /* no interval use */
288 #define INIT_INTERVALS
290 #define UNMARK_BALANCE_INTERVALS(i)
291 #define MARK_INTERVAL_TREE(i)
293 #endif /* no interval use */
295 /* Floating point allocation. */
297 #ifdef LISP_FLOAT_TYPE
298 /* Allocation of float cells, just like conses */
299 /* We store float cells inside of float_blocks, allocating a new
300 float_block with malloc whenever necessary. Float cells reclaimed by
301 GC are put on a free list to be reallocated before allocating
302 any new float cells from the latest float_block.
304 Each float_block is just under 1020 bytes long,
305 since malloc really allocates in units of powers of two
306 and uses 4 bytes for its own overhead. */
308 #define FLOAT_BLOCK_SIZE \
309 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
313 struct float_block
*next
;
314 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
317 struct float_block
*float_block
;
318 int float_block_index
;
320 struct Lisp_Float
*float_free_list
;
325 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
326 float_block
->next
= 0;
327 bzero (float_block
->floats
, sizeof float_block
->floats
);
328 float_block_index
= 0;
332 /* Explicitly free a float cell. */
334 struct Lisp_Float
*ptr
;
336 XFASTINT (ptr
->type
) = (int) float_free_list
;
337 float_free_list
= ptr
;
341 make_float (float_value
)
344 register Lisp_Object val
;
348 XSET (val
, Lisp_Float
, float_free_list
);
349 float_free_list
= (struct Lisp_Float
*) XFASTINT (float_free_list
->type
);
353 if (float_block_index
== FLOAT_BLOCK_SIZE
)
355 register struct float_block
*new = (struct float_block
*) malloc (sizeof (struct float_block
));
356 if (!new) memory_full ();
357 VALIDATE_LISP_STORAGE (new, sizeof *new);
358 new->next
= float_block
;
360 float_block_index
= 0;
362 XSET (val
, Lisp_Float
, &float_block
->floats
[float_block_index
++]);
364 XFLOAT (val
)->data
= float_value
;
365 XFLOAT (val
)->type
= 0; /* bug chasing -wsr */
366 consing_since_gc
+= sizeof (struct Lisp_Float
);
370 #endif /* LISP_FLOAT_TYPE */
372 /* Allocation of cons cells */
373 /* We store cons cells inside of cons_blocks, allocating a new
374 cons_block with malloc whenever necessary. Cons cells reclaimed by
375 GC are put on a free list to be reallocated before allocating
376 any new cons cells from the latest cons_block.
378 Each cons_block is just under 1020 bytes long,
379 since malloc really allocates in units of powers of two
380 and uses 4 bytes for its own overhead. */
382 #define CONS_BLOCK_SIZE \
383 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
387 struct cons_block
*next
;
388 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
391 struct cons_block
*cons_block
;
392 int cons_block_index
;
394 struct Lisp_Cons
*cons_free_list
;
399 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
400 cons_block
->next
= 0;
401 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
402 cons_block_index
= 0;
406 /* Explicitly free a cons cell. */
408 struct Lisp_Cons
*ptr
;
410 XFASTINT (ptr
->car
) = (int) cons_free_list
;
411 cons_free_list
= ptr
;
414 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
415 "Create a new cons, give it CAR and CDR as components, and return it.")
417 Lisp_Object car
, cdr
;
419 register Lisp_Object val
;
423 XSET (val
, Lisp_Cons
, cons_free_list
);
424 cons_free_list
= (struct Lisp_Cons
*) XFASTINT (cons_free_list
->car
);
428 if (cons_block_index
== CONS_BLOCK_SIZE
)
430 register struct cons_block
*new = (struct cons_block
*) malloc (sizeof (struct cons_block
));
431 if (!new) memory_full ();
432 VALIDATE_LISP_STORAGE (new, sizeof *new);
433 new->next
= cons_block
;
435 cons_block_index
= 0;
437 XSET (val
, Lisp_Cons
, &cons_block
->conses
[cons_block_index
++]);
439 XCONS (val
)->car
= car
;
440 XCONS (val
)->cdr
= cdr
;
441 consing_since_gc
+= sizeof (struct Lisp_Cons
);
445 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
446 "Return a newly created list with specified arguments as elements.\n\
447 Any number of arguments, even zero arguments, are allowed.")
450 register Lisp_Object
*args
;
452 register Lisp_Object len
, val
, val_tail
;
454 XFASTINT (len
) = nargs
;
455 val
= Fmake_list (len
, Qnil
);
457 while (!NILP (val_tail
))
459 XCONS (val_tail
)->car
= *args
++;
460 val_tail
= XCONS (val_tail
)->cdr
;
465 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
466 "Return a newly created list of length LENGTH, with each element being INIT.")
468 register Lisp_Object length
, init
;
470 register Lisp_Object val
;
473 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
474 length
= wrong_type_argument (Qnatnump
, length
);
475 size
= XINT (length
);
479 val
= Fcons (init
, val
);
483 /* Allocation of vectors */
485 struct Lisp_Vector
*all_vectors
;
487 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
488 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
489 See also the function `vector'.")
491 register Lisp_Object length
, init
;
493 register int sizei
, index
;
494 register Lisp_Object vector
;
495 register struct Lisp_Vector
*p
;
497 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
498 length
= wrong_type_argument (Qnatnump
, length
);
499 sizei
= XINT (length
);
501 p
= (struct Lisp_Vector
*) malloc (sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
));
504 VALIDATE_LISP_STORAGE (p
, 0);
506 XSET (vector
, Lisp_Vector
, p
);
507 consing_since_gc
+= sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
);
510 p
->next
= all_vectors
;
513 for (index
= 0; index
< sizei
; index
++)
514 p
->contents
[index
] = init
;
519 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
520 "Return a newly created vector with specified arguments as elements.\n\
521 Any number of arguments, even zero arguments, are allowed.")
526 register Lisp_Object len
, val
;
528 register struct Lisp_Vector
*p
;
530 XFASTINT (len
) = nargs
;
531 val
= Fmake_vector (len
, Qnil
);
533 for (index
= 0; index
< nargs
; index
++)
534 p
->contents
[index
] = args
[index
];
538 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
539 "Create a byte-code object with specified arguments as elements.\n\
540 The arguments should be the arglist, bytecode-string, constant vector,\n\
541 stack size, (optional) doc string, and (optional) interactive spec.\n\
542 The first four arguments are required; at most six have any\n\
548 register Lisp_Object len
, val
;
550 register struct Lisp_Vector
*p
;
552 XFASTINT (len
) = nargs
;
553 if (!NILP (Vpurify_flag
))
554 val
= make_pure_vector (len
);
556 val
= Fmake_vector (len
, Qnil
);
558 for (index
= 0; index
< nargs
; index
++)
560 if (!NILP (Vpurify_flag
))
561 args
[index
] = Fpurecopy (args
[index
]);
562 p
->contents
[index
] = args
[index
];
564 XSETTYPE (val
, Lisp_Compiled
);
568 /* Allocation of symbols.
569 Just like allocation of conses!
571 Each symbol_block is just under 1020 bytes long,
572 since malloc really allocates in units of powers of two
573 and uses 4 bytes for its own overhead. */
575 #define SYMBOL_BLOCK_SIZE \
576 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
580 struct symbol_block
*next
;
581 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
584 struct symbol_block
*symbol_block
;
585 int symbol_block_index
;
587 struct Lisp_Symbol
*symbol_free_list
;
592 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
593 symbol_block
->next
= 0;
594 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
595 symbol_block_index
= 0;
596 symbol_free_list
= 0;
599 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
600 "Return a newly allocated uninterned symbol whose name is NAME.\n\
601 Its value and function definition are void, and its property list is nil.")
605 register Lisp_Object val
;
606 register struct Lisp_Symbol
*p
;
608 CHECK_STRING (str
, 0);
610 if (symbol_free_list
)
612 XSET (val
, Lisp_Symbol
, symbol_free_list
);
614 = (struct Lisp_Symbol
*) XFASTINT (symbol_free_list
->value
);
618 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
620 struct symbol_block
*new = (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
621 if (!new) memory_full ();
622 VALIDATE_LISP_STORAGE (new, sizeof *new);
623 new->next
= symbol_block
;
625 symbol_block_index
= 0;
627 XSET (val
, Lisp_Symbol
, &symbol_block
->symbols
[symbol_block_index
++]);
630 p
->name
= XSTRING (str
);
633 p
->function
= Qunbound
;
635 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
639 /* Allocation of markers.
640 Works like allocation of conses. */
642 #define MARKER_BLOCK_SIZE \
643 ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker))
647 struct marker_block
*next
;
648 struct Lisp_Marker markers
[MARKER_BLOCK_SIZE
];
651 struct marker_block
*marker_block
;
652 int marker_block_index
;
654 struct Lisp_Marker
*marker_free_list
;
659 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
660 marker_block
->next
= 0;
661 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
662 marker_block_index
= 0;
663 marker_free_list
= 0;
666 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
667 "Return a newly allocated marker which does not point at any place.")
670 register Lisp_Object val
;
671 register struct Lisp_Marker
*p
;
673 if (marker_free_list
)
675 XSET (val
, Lisp_Marker
, marker_free_list
);
677 = (struct Lisp_Marker
*) XFASTINT (marker_free_list
->chain
);
681 if (marker_block_index
== MARKER_BLOCK_SIZE
)
683 struct marker_block
*new = (struct marker_block
*) malloc (sizeof (struct marker_block
));
684 if (!new) memory_full ();
685 VALIDATE_LISP_STORAGE (new, sizeof *new);
686 new->next
= marker_block
;
688 marker_block_index
= 0;
690 XSET (val
, Lisp_Marker
, &marker_block
->markers
[marker_block_index
++]);
696 consing_since_gc
+= sizeof (struct Lisp_Marker
);
700 /* Allocation of strings */
702 /* Strings reside inside of string_blocks. The entire data of the string,
703 both the size and the contents, live in part of the `chars' component of a string_block.
704 The `pos' component is the index within `chars' of the first free byte.
706 first_string_block points to the first string_block ever allocated.
707 Each block points to the next one with its `next' field.
708 The `prev' fields chain in reverse order.
709 The last one allocated is the one currently being filled.
710 current_string_block points to it.
712 The string_blocks that hold individual large strings
713 go in a separate chain, started by large_string_blocks. */
716 /* String blocks contain this many useful bytes.
717 8188 is power of 2, minus 4 for malloc overhead. */
718 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
720 /* A string bigger than this gets its own specially-made string block
721 if it doesn't fit in the current one. */
722 #define STRING_BLOCK_OUTSIZE 1024
724 struct string_block_head
726 struct string_block
*next
, *prev
;
732 struct string_block
*next
, *prev
;
734 char chars
[STRING_BLOCK_SIZE
];
737 /* This points to the string block we are now allocating strings. */
739 struct string_block
*current_string_block
;
741 /* This points to the oldest string block, the one that starts the chain. */
743 struct string_block
*first_string_block
;
745 /* Last string block in chain of those made for individual large strings. */
747 struct string_block
*large_string_blocks
;
749 /* If SIZE is the length of a string, this returns how many bytes
750 the string occupies in a string_block (including padding). */
752 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
754 #define PAD (sizeof (int))
757 #define STRING_FULLSIZE(SIZE) \
758 (((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1))
764 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
765 first_string_block
= current_string_block
;
766 consing_since_gc
+= sizeof (struct string_block
);
767 current_string_block
->next
= 0;
768 current_string_block
->prev
= 0;
769 current_string_block
->pos
= 0;
770 large_string_blocks
= 0;
773 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
774 "Return a newly created string of length LENGTH, with each element being INIT.\n\
775 Both LENGTH and INIT must be numbers.")
777 Lisp_Object length
, init
;
779 register Lisp_Object val
;
780 register unsigned char *p
, *end
, c
;
782 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
783 length
= wrong_type_argument (Qnatnump
, length
);
784 CHECK_NUMBER (init
, 1);
785 val
= make_uninit_string (XINT (length
));
787 p
= XSTRING (val
)->data
;
788 end
= p
+ XSTRING (val
)->size
;
796 make_string (contents
, length
)
800 register Lisp_Object val
;
801 val
= make_uninit_string (length
);
802 bcopy (contents
, XSTRING (val
)->data
, length
);
810 return make_string (str
, strlen (str
));
814 make_uninit_string (length
)
817 register Lisp_Object val
;
818 register int fullsize
= STRING_FULLSIZE (length
);
820 if (length
< 0) abort ();
822 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
823 /* This string can fit in the current string block */
825 XSET (val
, Lisp_String
,
826 (struct Lisp_String
*) (current_string_block
->chars
+ current_string_block
->pos
));
827 current_string_block
->pos
+= fullsize
;
829 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
830 /* This string gets its own string block */
832 register struct string_block
*new
833 = (struct string_block
*) malloc (sizeof (struct string_block_head
) + fullsize
);
834 VALIDATE_LISP_STORAGE (new, 0);
835 if (!new) memory_full ();
836 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
838 new->next
= large_string_blocks
;
839 large_string_blocks
= new;
840 XSET (val
, Lisp_String
,
841 (struct Lisp_String
*) ((struct string_block_head
*)new + 1));
844 /* Make a new current string block and start it off with this string */
846 register struct string_block
*new
847 = (struct string_block
*) malloc (sizeof (struct string_block
));
848 if (!new) memory_full ();
849 VALIDATE_LISP_STORAGE (new, sizeof *new);
850 consing_since_gc
+= sizeof (struct string_block
);
851 current_string_block
->next
= new;
852 new->prev
= current_string_block
;
854 current_string_block
= new;
856 XSET (val
, Lisp_String
,
857 (struct Lisp_String
*) current_string_block
->chars
);
860 XSTRING (val
)->size
= length
;
861 XSTRING (val
)->data
[length
] = 0;
862 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
867 /* Return a newly created vector or string with specified arguments as
868 elements. If all the arguments are characters, make a string;
869 otherwise, make a vector. Any number of arguments, even zero
870 arguments, are allowed. */
873 make_array (nargs
, args
)
879 for (i
= 0; i
< nargs
; i
++)
880 if (XTYPE (args
[i
]) != Lisp_Int
881 || (unsigned) XINT (args
[i
]) >= 0400)
882 return Fvector (nargs
, args
);
884 /* Since the loop exited, we know that all the things in it are
885 characters, so we can make a string. */
887 Lisp_Object result
= Fmake_string (nargs
, make_number (0));
889 for (i
= 0; i
< nargs
; i
++)
890 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
896 /* Allocation of ropes. */
898 /* Note: the user cannot manipulate ropes portably by referring
899 to the chars of the string, because combining two chars to make a GLYPH
900 depends on endianness. */
902 DEFUN ("make-rope", Fmake_rope
, Smake_rope
, 0, MANY
, 0,
903 "Return a newly created rope containing the arguments of this function.\n\
904 A rope is a string, except that its contents will be treated as an\n\
905 array of glyphs, where a glyph is an integer type that may be larger\n\
906 than a character. Emacs is normally configured to use 8-bit glyphs,\n\
907 so ropes are normally no different from strings. But Emacs may be\n\
908 configured to use 16-bit glyphs, to allow the use of larger fonts.\n\
910 Each argument (which must be an integer) specifies one glyph, whatever\n\
911 size glyphs may be.\n\
913 See variable `buffer-display-table' for the uses of ropes.")
919 register Lisp_Object val
;
922 val
= make_uninit_string (nargs
* sizeof (GLYPH
));
924 p
= (GLYPH
*) XSTRING (val
)->data
;
925 for (i
= 0; i
< nargs
; i
++)
927 CHECK_NUMBER (args
[i
], i
);
928 p
[i
] = XFASTINT (args
[i
]);
933 DEFUN ("rope-elt", Frope_elt
, Srope_elt
, 2, 2, 0,
934 "Return an element of rope R at index N.\n\
935 A rope is a string in which each pair of bytes is considered an element.\n\
936 See variable `buffer-display-table' for the uses of ropes.")
942 if ((XSTRING (r
)->size
/ sizeof (GLYPH
)) <= XINT (n
) || XINT (n
) < 0)
943 args_out_of_range (r
, n
);
944 return ((GLYPH
*) XSTRING (r
)->data
)[XFASTINT (n
)];
947 /* Pure storage management. */
949 /* Must get an error if pure storage is full,
950 since if it cannot hold a large string
951 it may be able to hold conses that point to that string;
952 then the string is not protected from gc. */
955 make_pure_string (data
, length
)
959 register Lisp_Object
new;
960 register int size
= sizeof (int) + INTERVAL_PTR_SIZE
+ length
+ 1;
962 if (pureptr
+ size
> PURESIZE
)
963 error ("Pure Lisp storage exhausted");
964 XSET (new, Lisp_String
, PUREBEG
+ pureptr
);
965 XSTRING (new)->size
= length
;
966 bcopy (data
, XSTRING (new)->data
, length
);
967 XSTRING (new)->data
[length
] = 0;
968 pureptr
+= (size
+ sizeof (int) - 1)
969 / sizeof (int) * sizeof (int);
975 Lisp_Object car
, cdr
;
977 register Lisp_Object
new;
979 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
980 error ("Pure Lisp storage exhausted");
981 XSET (new, Lisp_Cons
, PUREBEG
+ pureptr
);
982 pureptr
+= sizeof (struct Lisp_Cons
);
983 XCONS (new)->car
= Fpurecopy (car
);
984 XCONS (new)->cdr
= Fpurecopy (cdr
);
988 #ifdef LISP_FLOAT_TYPE
991 make_pure_float (num
)
994 register Lisp_Object
new;
996 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
997 (double) boundary. Some architectures (like the sparc) require
998 this, and I suspect that floats are rare enough that it's no
999 tragedy for those that do. */
1002 char *p
= PUREBEG
+ pureptr
;
1006 alignment
= __alignof (struct Lisp_Float
);
1008 alignment
= sizeof (struct Lisp_Float
);
1011 alignment
= sizeof (struct Lisp_Float
);
1013 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1014 pureptr
= p
- PUREBEG
;
1017 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1018 error ("Pure Lisp storage exhausted");
1019 XSET (new, Lisp_Float
, PUREBEG
+ pureptr
);
1020 pureptr
+= sizeof (struct Lisp_Float
);
1021 XFLOAT (new)->data
= num
;
1022 XFLOAT (new)->type
= 0; /* bug chasing -wsr */
1026 #endif /* LISP_FLOAT_TYPE */
1029 make_pure_vector (len
)
1032 register Lisp_Object
new;
1033 register int size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1035 if (pureptr
+ size
> PURESIZE
)
1036 error ("Pure Lisp storage exhausted");
1038 XSET (new, Lisp_Vector
, PUREBEG
+ pureptr
);
1040 XVECTOR (new)->size
= len
;
1044 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1045 "Make a copy of OBJECT in pure storage.\n\
1046 Recursively copies contents of vectors and cons cells.\n\
1047 Does not copy symbols.")
1049 register Lisp_Object obj
;
1051 register Lisp_Object
new, tem
;
1054 if (NILP (Vpurify_flag
))
1057 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1058 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1061 #ifdef SWITCH_ENUM_BUG
1062 switch ((int) XTYPE (obj
))
1064 switch (XTYPE (obj
))
1068 error ("Attempt to copy a marker to pure storage");
1071 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1073 #ifdef LISP_FLOAT_TYPE
1075 return make_pure_float (XFLOAT (obj
)->data
);
1076 #endif /* LISP_FLOAT_TYPE */
1079 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1083 new = make_pure_vector (XVECTOR (obj
)->size
);
1084 for (i
= 0; i
< XVECTOR (obj
)->size
; i
++)
1086 tem
= XVECTOR (obj
)->contents
[i
];
1087 XVECTOR (new)->contents
[i
] = Fpurecopy (tem
);
1089 XSETTYPE (new, XTYPE (obj
));
1097 /* Recording what needs to be marked for gc. */
1099 struct gcpro
*gcprolist
;
1101 #define NSTATICS 512
1103 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1107 /* Put an entry in staticvec, pointing at the variable whose address is given */
1110 staticpro (varaddress
)
1111 Lisp_Object
*varaddress
;
1113 staticvec
[staticidx
++] = varaddress
;
1114 if (staticidx
>= NSTATICS
)
1122 struct catchtag
*next
;
1123 /* jmp_buf jmp; /* We don't need this for GC purposes */
1128 struct backtrace
*next
;
1129 Lisp_Object
*function
;
1130 Lisp_Object
*args
; /* Points to vector of args. */
1131 int nargs
; /* length of vector */
1132 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1136 /* Two flags that are set during GC in the `size' component
1137 of a string or vector. On some machines, these flags
1138 are defined by the m- file to be different bits. */
1140 /* On vector, means it has been marked.
1141 On string size field or a reference to a string,
1142 means not the last reference in the chain. */
1144 #ifndef ARRAY_MARK_FLAG
1145 #define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
1146 #endif /* no ARRAY_MARK_FLAG */
1148 /* Any slot that is a Lisp_Object can point to a string
1149 and thus can be put on a string's reference-chain
1150 and thus may need to have its ARRAY_MARK_FLAG set.
1151 This includes the slots whose markbits are used to mark
1152 the containing objects. */
1154 #if ARRAY_MARK_FLAG == MARKBIT
1158 /* Garbage collection! */
1160 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1161 int total_free_conses
, total_free_markers
, total_free_symbols
;
1162 #ifdef LISP_FLOAT_TYPE
1163 int total_free_floats
, total_floats
;
1164 #endif /* LISP_FLOAT_TYPE */
1166 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1167 "Reclaim storage for Lisp objects no longer needed.\n\
1168 Returns info on amount of space in use:\n\
1169 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1170 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1171 (USED-FLOATS . FREE-FLOATS))\n\
1172 Garbage collection happens automatically if you cons more than\n\
1173 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1176 register struct gcpro
*tail
;
1177 register struct specbinding
*bind
;
1178 struct catchtag
*catch;
1179 struct handler
*handler
;
1180 register struct backtrace
*backlist
;
1181 register Lisp_Object tem
;
1182 char *omessage
= echo_area_glyphs
;
1183 char stack_top_variable
;
1186 /* Save a copy of the contents of the stack, for debugging. */
1187 #if MAX_SAVE_STACK > 0
1188 if (NILP (Vpurify_flag
))
1190 i
= &stack_top_variable
- stack_bottom
;
1192 if (i
< MAX_SAVE_STACK
)
1194 if (stack_copy
== 0)
1195 stack_copy
= (char *) malloc (stack_copy_size
= i
);
1196 else if (stack_copy_size
< i
)
1197 stack_copy
= (char *) realloc (stack_copy
, (stack_copy_size
= i
));
1200 if ((int) (&stack_top_variable
- stack_bottom
) > 0)
1201 bcopy (stack_bottom
, stack_copy
, i
);
1203 bcopy (&stack_top_variable
, stack_copy
, i
);
1207 #endif /* MAX_SAVE_STACK > 0 */
1209 if (!noninteractive
)
1210 message1 ("Garbage collecting...");
1212 /* Don't keep command history around forever */
1213 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1215 XCONS (tem
)->cdr
= Qnil
;
1217 /* Likewise for undo information. */
1219 register struct buffer
*nextb
= all_buffers
;
1223 /* If a buffer's undo list is Qt, that means that undo is
1224 turned off in that buffer. Calling truncate_undo_list on
1225 Qt tends to return NULL, which effectively turns undo back on.
1226 So don't call truncate_undo_list if undo_list is Qt. */
1227 if (! EQ (nextb
->undo_list
, Qt
))
1229 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1231 nextb
= nextb
->next
;
1237 /* clear_marks (); */
1239 /* In each "large string", set the MARKBIT of the size field.
1240 That enables mark_object to recognize them. */
1242 register struct string_block
*b
;
1243 for (b
= large_string_blocks
; b
; b
= b
->next
)
1244 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1247 /* Mark all the special slots that serve as the roots of accessibility.
1249 Usually the special slots to mark are contained in particular structures.
1250 Then we know no slot is marked twice because the structures don't overlap.
1251 In some cases, the structures point to the slots to be marked.
1252 For these, we use MARKBIT to avoid double marking of the slot. */
1254 for (i
= 0; i
< staticidx
; i
++)
1255 mark_object (staticvec
[i
]);
1256 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1257 for (i
= 0; i
< tail
->nvars
; i
++)
1258 if (!XMARKBIT (tail
->var
[i
]))
1260 mark_object (&tail
->var
[i
]);
1261 XMARK (tail
->var
[i
]);
1263 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1265 mark_object (&bind
->symbol
);
1266 mark_object (&bind
->old_value
);
1268 for (catch = catchlist
; catch; catch = catch->next
)
1270 mark_object (&catch->tag
);
1271 mark_object (&catch->val
);
1273 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1275 mark_object (&handler
->handler
);
1276 mark_object (&handler
->var
);
1278 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1280 if (!XMARKBIT (*backlist
->function
))
1282 mark_object (backlist
->function
);
1283 XMARK (*backlist
->function
);
1285 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1288 i
= backlist
->nargs
- 1;
1290 if (!XMARKBIT (backlist
->args
[i
]))
1292 mark_object (&backlist
->args
[i
]);
1293 XMARK (backlist
->args
[i
]);
1299 /* Clear the mark bits that we set in certain root slots. */
1301 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1302 for (i
= 0; i
< tail
->nvars
; i
++)
1303 XUNMARK (tail
->var
[i
]);
1304 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1306 XUNMARK (*backlist
->function
);
1307 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1310 i
= backlist
->nargs
- 1;
1312 XUNMARK (backlist
->args
[i
]);
1314 XUNMARK (buffer_defaults
.name
);
1315 XUNMARK (buffer_local_symbols
.name
);
1317 /* clear_marks (); */
1320 consing_since_gc
= 0;
1321 if (gc_cons_threshold
< 10000)
1322 gc_cons_threshold
= 10000;
1325 message1 (omessage
);
1326 else if (!noninteractive
)
1327 message1 ("Garbage collecting...done");
1329 return Fcons (Fcons (make_number (total_conses
),
1330 make_number (total_free_conses
)),
1331 Fcons (Fcons (make_number (total_symbols
),
1332 make_number (total_free_symbols
)),
1333 Fcons (Fcons (make_number (total_markers
),
1334 make_number (total_free_markers
)),
1335 Fcons (make_number (total_string_size
),
1336 Fcons (make_number (total_vector_size
),
1338 #ifdef LISP_FLOAT_TYPE
1339 Fcons (Fcons (make_number (total_floats
),
1340 make_number (total_free_floats
)),
1342 #else /* not LISP_FLOAT_TYPE */
1344 #endif /* not LISP_FLOAT_TYPE */
1352 /* Clear marks on all conses */
1354 register struct cons_block
*cblk
;
1355 register int lim
= cons_block_index
;
1357 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1360 for (i
= 0; i
< lim
; i
++)
1361 XUNMARK (cblk
->conses
[i
].car
);
1362 lim
= CONS_BLOCK_SIZE
;
1365 /* Clear marks on all symbols */
1367 register struct symbol_block
*sblk
;
1368 register int lim
= symbol_block_index
;
1370 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1373 for (i
= 0; i
< lim
; i
++)
1375 XUNMARK (sblk
->symbols
[i
].plist
);
1377 lim
= SYMBOL_BLOCK_SIZE
;
1380 /* Clear marks on all markers */
1382 register struct marker_block
*sblk
;
1383 register int lim
= marker_block_index
;
1385 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1388 for (i
= 0; i
< lim
; i
++)
1389 XUNMARK (sblk
->markers
[i
].chain
);
1390 lim
= MARKER_BLOCK_SIZE
;
1393 /* Clear mark bits on all buffers */
1395 register struct buffer
*nextb
= all_buffers
;
1399 XUNMARK (nextb
->name
);
1400 nextb
= nextb
->next
;
1406 /* Mark reference to a Lisp_Object.
1407 If the object referred to has not been seen yet, recursively mark
1408 all the references contained in it.
1410 If the object referenced is a short string, the referrencing slot
1411 is threaded into a chain of such slots, pointed to from
1412 the `size' field of the string. The actual string size
1413 lives in the last slot in the chain. We recognize the end
1414 because it is < (unsigned) STRING_BLOCK_SIZE. */
1416 #define LAST_MARKED_SIZE 500
1417 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1418 int last_marked_index
;
1421 mark_object (objptr
)
1422 Lisp_Object
*objptr
;
1424 register Lisp_Object obj
;
1431 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1432 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1435 last_marked
[last_marked_index
++] = objptr
;
1436 if (last_marked_index
== LAST_MARKED_SIZE
)
1437 last_marked_index
= 0;
1439 #ifdef SWITCH_ENUM_BUG
1440 switch ((int) XGCTYPE (obj
))
1442 switch (XGCTYPE (obj
))
1447 register struct Lisp_String
*ptr
= XSTRING (obj
);
1449 MARK_INTERVAL_TREE (ptr
->intervals
);
1450 if (ptr
->size
& MARKBIT
)
1451 /* A large string. Just set ARRAY_MARK_FLAG. */
1452 ptr
->size
|= ARRAY_MARK_FLAG
;
1455 /* A small string. Put this reference
1456 into the chain of references to it.
1457 The address OBJPTR is even, so if the address
1458 includes MARKBIT, put it in the low bit
1459 when we store OBJPTR into the size field. */
1461 if (XMARKBIT (*objptr
))
1463 XFASTINT (*objptr
) = ptr
->size
;
1467 XFASTINT (*objptr
) = ptr
->size
;
1468 if ((int)objptr
& 1) abort ();
1469 ptr
->size
= (int) objptr
& ~MARKBIT
;
1470 if ((int) objptr
& MARKBIT
)
1479 case Lisp_Window_Configuration
:
1481 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1482 register int size
= ptr
->size
;
1483 struct Lisp_Vector
*volatile ptr1
= ptr
;
1486 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1487 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1488 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1492 mark_object (&ptr
->contents
[i
]);
1498 /* We could treat this just like a vector, but it is better
1499 to save the COMPILED_CONSTANTS element for last and avoid recursion
1502 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1503 register int size
= ptr
->size
;
1504 struct Lisp_Vector
*volatile ptr1
= ptr
;
1507 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1508 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1509 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1513 if (i
!= COMPILED_CONSTANTS
)
1514 mark_object (&ptr
->contents
[i
]);
1516 objptr
= &ptr
->contents
[COMPILED_CONSTANTS
];
1524 register struct frame
*ptr
= XFRAME (obj
);
1525 register int size
= ptr
->size
;
1527 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1528 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1530 mark_object (&ptr
->name
);
1531 mark_object (&ptr
->focus_frame
);
1532 mark_object (&ptr
->width
);
1533 mark_object (&ptr
->height
);
1534 mark_object (&ptr
->selected_window
);
1535 mark_object (&ptr
->minibuffer_window
);
1536 mark_object (&ptr
->param_alist
);
1537 mark_object (&ptr
->scroll_bars
);
1538 mark_object (&ptr
->condemned_scroll_bars
);
1541 #endif /* not MULTI_FRAME */
1545 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
1546 struct Lisp_Symbol
*ptrx
;
1548 if (XMARKBIT (ptr
->plist
)) break;
1550 mark_object ((Lisp_Object
*) &ptr
->value
);
1551 mark_object (&ptr
->function
);
1552 mark_object (&ptr
->plist
);
1553 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1554 mark_object (&ptr
->name
);
1558 ptrx
= ptr
; /* Use pf ptrx avoids compiler bug on Sun */
1559 XSETSYMBOL (obj
, ptrx
);
1566 XMARK (XMARKER (obj
)->chain
);
1567 /* DO NOT mark thru the marker's chain.
1568 The buffer's markers chain does not preserve markers from gc;
1569 instead, markers are removed from the chain when freed by gc. */
1573 case Lisp_Buffer_Local_Value
:
1574 case Lisp_Some_Buffer_Local_Value
:
1576 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1577 if (XMARKBIT (ptr
->car
)) break;
1579 /* If the cdr is nil, avoid recursion for the car. */
1580 if (EQ (ptr
->cdr
, Qnil
))
1587 mark_object (&ptr
->car
);
1593 #ifdef LISP_FLOAT_TYPE
1595 XMARK (XFLOAT (obj
)->type
);
1597 #endif /* LISP_FLOAT_TYPE */
1600 if (!XMARKBIT (XBUFFER (obj
)->name
))
1610 case Lisp_Buffer_Objfwd
:
1611 case Lisp_Internal_Stream
:
1612 /* Don't bother with Lisp_Buffer_Objfwd,
1613 since all markable slots in current buffer marked anyway. */
1614 /* Don't need to do Lisp_Objfwd, since the places they point
1615 are protected with staticpro. */
1623 /* Mark the pointers in a buffer structure. */
1629 register struct buffer
*buffer
= XBUFFER (buf
);
1630 register Lisp_Object
*ptr
;
1632 /* This is the buffer's markbit */
1633 mark_object (&buffer
->name
);
1634 XMARK (buffer
->name
);
1636 MARK_INTERVAL_TREE (buffer
->intervals
);
1639 mark_object (buffer
->syntax_table
);
1641 /* Mark the various string-pointers in the buffer object.
1642 Since the strings may be relocated, we must mark them
1643 in their actual slots. So gc_sweep must convert each slot
1644 back to an ordinary C pointer. */
1645 XSET (*(Lisp_Object
*)&buffer
->upcase_table
,
1646 Lisp_String
, buffer
->upcase_table
);
1647 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1648 XSET (*(Lisp_Object
*)&buffer
->downcase_table
,
1649 Lisp_String
, buffer
->downcase_table
);
1650 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1652 XSET (*(Lisp_Object
*)&buffer
->sort_table
,
1653 Lisp_String
, buffer
->sort_table
);
1654 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1655 XSET (*(Lisp_Object
*)&buffer
->folding_sort_table
,
1656 Lisp_String
, buffer
->folding_sort_table
);
1657 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1660 for (ptr
= &buffer
->name
+ 1;
1661 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1666 /* Sweep: find all structures not marked, and free them. */
1671 total_string_size
= 0;
1674 /* Put all unmarked conses on free list */
1676 register struct cons_block
*cblk
;
1677 register int lim
= cons_block_index
;
1678 register int num_free
= 0, num_used
= 0;
1682 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1685 for (i
= 0; i
< lim
; i
++)
1686 if (!XMARKBIT (cblk
->conses
[i
].car
))
1688 XFASTINT (cblk
->conses
[i
].car
) = (int) cons_free_list
;
1690 cons_free_list
= &cblk
->conses
[i
];
1695 XUNMARK (cblk
->conses
[i
].car
);
1697 lim
= CONS_BLOCK_SIZE
;
1699 total_conses
= num_used
;
1700 total_free_conses
= num_free
;
1703 #ifdef LISP_FLOAT_TYPE
1704 /* Put all unmarked floats on free list */
1706 register struct float_block
*fblk
;
1707 register int lim
= float_block_index
;
1708 register int num_free
= 0, num_used
= 0;
1710 float_free_list
= 0;
1712 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1715 for (i
= 0; i
< lim
; i
++)
1716 if (!XMARKBIT (fblk
->floats
[i
].type
))
1718 XFASTINT (fblk
->floats
[i
].type
) = (int) float_free_list
;
1720 float_free_list
= &fblk
->floats
[i
];
1725 XUNMARK (fblk
->floats
[i
].type
);
1727 lim
= FLOAT_BLOCK_SIZE
;
1729 total_floats
= num_used
;
1730 total_free_floats
= num_free
;
1732 #endif /* LISP_FLOAT_TYPE */
1734 #ifdef USE_TEXT_PROPERTIES
1735 /* Put all unmarked intervals on free list */
1737 register struct interval_block
*iblk
;
1738 register int lim
= interval_block_index
;
1739 register int num_free
= 0, num_used
= 0;
1741 interval_free_list
= 0;
1743 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1747 for (i
= 0; i
< lim
; i
++)
1749 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1751 iblk
->intervals
[i
].parent
= interval_free_list
;
1752 interval_free_list
= &iblk
->intervals
[i
];
1758 XUNMARK (iblk
->intervals
[i
].plist
);
1761 lim
= INTERVAL_BLOCK_SIZE
;
1763 total_intervals
= num_used
;
1764 total_free_intervals
= num_free
;
1766 #endif /* USE_TEXT_PROPERTIES */
1768 /* Put all unmarked symbols on free list */
1770 register struct symbol_block
*sblk
;
1771 register int lim
= symbol_block_index
;
1772 register int num_free
= 0, num_used
= 0;
1774 symbol_free_list
= 0;
1776 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1779 for (i
= 0; i
< lim
; i
++)
1780 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1782 XFASTINT (sblk
->symbols
[i
].value
) = (int) symbol_free_list
;
1783 symbol_free_list
= &sblk
->symbols
[i
];
1789 sblk
->symbols
[i
].name
1790 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1791 XUNMARK (sblk
->symbols
[i
].plist
);
1793 lim
= SYMBOL_BLOCK_SIZE
;
1795 total_symbols
= num_used
;
1796 total_free_symbols
= num_free
;
1800 /* Put all unmarked markers on free list.
1801 Dechain each one first from the buffer it points into. */
1803 register struct marker_block
*mblk
;
1804 struct Lisp_Marker
*tem1
;
1805 register int lim
= marker_block_index
;
1806 register int num_free
= 0, num_used
= 0;
1808 marker_free_list
= 0;
1810 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1813 for (i
= 0; i
< lim
; i
++)
1814 if (!XMARKBIT (mblk
->markers
[i
].chain
))
1817 tem1
= &mblk
->markers
[i
]; /* tem1 avoids Sun compiler bug */
1818 XSET (tem
, Lisp_Marker
, tem1
);
1819 unchain_marker (tem
);
1820 XFASTINT (mblk
->markers
[i
].chain
) = (int) marker_free_list
;
1821 marker_free_list
= &mblk
->markers
[i
];
1827 XUNMARK (mblk
->markers
[i
].chain
);
1829 lim
= MARKER_BLOCK_SIZE
;
1832 total_markers
= num_used
;
1833 total_free_markers
= num_free
;
1836 /* Free all unmarked buffers */
1838 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1841 if (!XMARKBIT (buffer
->name
))
1844 prev
->next
= buffer
->next
;
1846 all_buffers
= buffer
->next
;
1847 next
= buffer
->next
;
1853 XUNMARK (buffer
->name
);
1854 UNMARK_BALANCE_INTERVALS (buffer
->intervals
);
1857 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1858 for purposes of marking and relocation.
1859 Turn them back into C pointers now. */
1860 buffer
->upcase_table
1861 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
1862 buffer
->downcase_table
1863 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
1865 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
1866 buffer
->folding_sort_table
1867 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
1870 prev
= buffer
, buffer
= buffer
->next
;
1874 #endif /* standalone */
1876 /* Free all unmarked vectors */
1878 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
1879 total_vector_size
= 0;
1882 if (!(vector
->size
& ARRAY_MARK_FLAG
))
1885 prev
->next
= vector
->next
;
1887 all_vectors
= vector
->next
;
1888 next
= vector
->next
;
1894 vector
->size
&= ~ARRAY_MARK_FLAG
;
1895 total_vector_size
+= vector
->size
;
1896 prev
= vector
, vector
= vector
->next
;
1900 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
1902 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
1905 if (!(((struct Lisp_String
*)(&sb
->chars
[0]))->size
& ARRAY_MARK_FLAG
))
1908 prev
->next
= sb
->next
;
1910 large_string_blocks
= sb
->next
;
1917 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
1918 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
1919 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
1920 prev
= sb
, sb
= sb
->next
;
1925 /* Compactify strings, relocate references, and free empty string blocks. */
1930 /* String block of old strings we are scanning. */
1931 register struct string_block
*from_sb
;
1932 /* A preceding string block (or maybe the same one)
1933 where we are copying the still-live strings to. */
1934 register struct string_block
*to_sb
;
1938 to_sb
= first_string_block
;
1941 /* Scan each existing string block sequentially, string by string. */
1942 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
1945 /* POS is the index of the next string in the block. */
1946 while (pos
< from_sb
->pos
)
1948 register struct Lisp_String
*nextstr
1949 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
1951 register struct Lisp_String
*newaddr
;
1952 register int size
= nextstr
->size
;
1954 /* NEXTSTR is the old address of the next string.
1955 Just skip it if it isn't marked. */
1956 if ((unsigned) size
> STRING_BLOCK_SIZE
)
1958 /* It is marked, so its size field is really a chain of refs.
1959 Find the end of the chain, where the actual size lives. */
1960 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1962 if (size
& 1) size
^= MARKBIT
| 1;
1963 size
= *(int *)size
& ~MARKBIT
;
1966 total_string_size
+= size
;
1968 /* If it won't fit in TO_SB, close it out,
1969 and move to the next sb. Keep doing so until
1970 TO_SB reaches a large enough, empty enough string block.
1971 We know that TO_SB cannot advance past FROM_SB here
1972 since FROM_SB is large enough to contain this string.
1973 Any string blocks skipped here
1974 will be patched out and freed later. */
1975 while (to_pos
+ STRING_FULLSIZE (size
)
1976 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
1978 to_sb
->pos
= to_pos
;
1979 to_sb
= to_sb
->next
;
1982 /* Compute new address of this string
1983 and update TO_POS for the space being used. */
1984 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
1985 to_pos
+= STRING_FULLSIZE (size
);
1987 /* Copy the string itself to the new place. */
1988 if (nextstr
!= newaddr
)
1989 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (int)
1990 + INTERVAL_PTR_SIZE
);
1992 /* Go through NEXTSTR's chain of references
1993 and make each slot in the chain point to
1994 the new address of this string. */
1995 size
= newaddr
->size
;
1996 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1998 register Lisp_Object
*objptr
;
1999 if (size
& 1) size
^= MARKBIT
| 1;
2000 objptr
= (Lisp_Object
*)size
;
2002 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2003 if (XMARKBIT (*objptr
))
2005 XSET (*objptr
, Lisp_String
, newaddr
);
2009 XSET (*objptr
, Lisp_String
, newaddr
);
2011 /* Store the actual size in the size field. */
2012 newaddr
->size
= size
;
2014 pos
+= STRING_FULLSIZE (size
);
2018 /* Close out the last string block still used and free any that follow. */
2019 to_sb
->pos
= to_pos
;
2020 current_string_block
= to_sb
;
2022 from_sb
= to_sb
->next
;
2026 to_sb
= from_sb
->next
;
2031 /* Free any empty string blocks further back in the chain.
2032 This loop will never free first_string_block, but it is very
2033 unlikely that that one will become empty, so why bother checking? */
2035 from_sb
= first_string_block
;
2036 while (to_sb
= from_sb
->next
)
2038 if (to_sb
->pos
== 0)
2040 if (from_sb
->next
= to_sb
->next
)
2041 from_sb
->next
->prev
= from_sb
;
2049 /* Debugging aids. */
2051 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, "",
2052 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2053 This may be helpful in debugging Emacs's memory usage.\n\
2054 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2059 XSET (end
, Lisp_Int
, (int) sbrk (0) / 1024);
2065 /* Initialization */
2069 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2072 pure_size
= PURESIZE
;
2075 ignore_warnings
= 1;
2080 #ifdef LISP_FLOAT_TYPE
2082 #endif /* LISP_FLOAT_TYPE */
2085 ignore_warnings
= 0;
2088 consing_since_gc
= 0;
2089 gc_cons_threshold
= 100000;
2090 #ifdef VIRT_ADDR_VARIES
2091 malloc_sbrk_unused
= 1<<22; /* A large number */
2092 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2093 #endif /* VIRT_ADDR_VARIES */
2104 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2105 "*Number of bytes of consing between garbage collections.\n\
2106 Garbage collection can happen automatically once this many bytes have been\n\
2107 allocated since the last garbage collection. All data types count.\n\n\
2108 Garbage collection happens automatically only when `eval' is called.\n\n\
2109 By binding this temporarily to a large number, you can effectively\n\
2110 prevent garbage collection during a part of the program.");
2112 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2113 "Number of bytes of sharable Lisp data allocated so far.");
2116 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2117 "Number of bytes of unshared memory allocated in this session.");
2119 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2120 "Number of bytes of unshared memory remaining available in this session.");
2123 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2124 "Non-nil means loading Lisp code in order to dump an executable.\n\
2125 This means that certain objects should be allocated in shared (pure) space.");
2127 DEFVAR_INT ("undo-limit", &undo_limit
,
2128 "Keep no more undo information once it exceeds this size.\n\
2129 This limit is applied when garbage collection happens.\n\
2130 The size is counted as the number of bytes occupied,\n\
2131 which includes both saved text and other data.");
2134 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2135 "Don't keep more than this much size of undo information.\n\
2136 A command which pushes past this size is itself forgotten.\n\
2137 This limit is applied when garbage collection happens.\n\
2138 The size is counted as the number of bytes occupied,\n\
2139 which includes both saved text and other data.");
2140 undo_strong_limit
= 30000;
2145 defsubr (&Smake_byte_code
);
2146 defsubr (&Smake_list
);
2147 defsubr (&Smake_vector
);
2148 defsubr (&Smake_string
);
2149 defsubr (&Smake_rope
);
2150 defsubr (&Srope_elt
);
2151 defsubr (&Smake_symbol
);
2152 defsubr (&Smake_marker
);
2153 defsubr (&Spurecopy
);
2154 defsubr (&Sgarbage_collect
);
2155 defsubr (&Smemory_limit
);