1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 1998
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Note that this declares bzero on OSF/1. How dumb. */
27 #include "intervals.h"
33 #include "blockinput.h"
38 #include "syssignal.h"
42 #ifdef DOUG_LEA_MALLOC
44 #define __malloc_size_t int
46 /* The following come from gmalloc.c. */
48 #if defined (__STDC__) && __STDC__
50 #define __malloc_size_t size_t
52 #define __malloc_size_t unsigned int
54 extern __malloc_size_t _bytes_used
;
55 extern int __malloc_extra_blocks
;
56 #endif /* !defined(DOUG_LEA_MALLOC) */
58 #define max(A,B) ((A) > (B) ? (A) : (B))
59 #define min(A,B) ((A) < (B) ? (A) : (B))
61 /* Macro to verify that storage intended for Lisp objects is not
62 out of range to fit in the space for a pointer.
63 ADDRESS is the start of the block, and SIZE
64 is the amount of space within which objects can start. */
65 #define VALIDATE_LISP_STORAGE(address, size) \
69 XSETCONS (val, (char *) address + size); \
70 if ((char *) XCONS (val) != (char *) address + size) \
77 /* Value of _bytes_used, when spare_memory was freed. */
78 static __malloc_size_t bytes_used_when_full
;
80 /* Number of bytes of consing done since the last gc */
83 /* Count the amount of consing of various sorts of space. */
84 int cons_cells_consed
;
86 int vector_cells_consed
;
88 int string_chars_consed
;
89 int misc_objects_consed
;
92 /* Number of bytes of consing since gc before another gc should be done. */
93 int gc_cons_threshold
;
95 /* Nonzero during gc */
98 /* Nonzero means display messages at beginning and end of GC. */
99 int garbage_collection_messages
;
101 #ifndef VIRT_ADDR_VARIES
103 #endif /* VIRT_ADDR_VARIES */
104 int malloc_sbrk_used
;
106 #ifndef VIRT_ADDR_VARIES
108 #endif /* VIRT_ADDR_VARIES */
109 int malloc_sbrk_unused
;
111 /* Two limits controlling how much undo information to keep. */
113 int undo_strong_limit
;
115 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
116 int total_free_conses
, total_free_markers
, total_free_symbols
;
117 #ifdef LISP_FLOAT_TYPE
118 int total_free_floats
, total_floats
;
119 #endif /* LISP_FLOAT_TYPE */
121 /* Points to memory space allocated as "spare",
122 to be freed if we run out of memory. */
123 static char *spare_memory
;
125 /* Amount of spare memory to keep in reserve. */
126 #define SPARE_MEMORY (1 << 14)
128 /* Number of extra blocks malloc should get when it needs more core. */
129 static int malloc_hysteresis
;
131 /* Nonzero when malloc is called for allocating Lisp object space. */
132 int allocating_for_lisp
;
134 /* Non-nil means defun should do purecopy on the function definition */
135 Lisp_Object Vpurify_flag
;
138 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
139 #define PUREBEG (char *) pure
141 #define pure PURE_SEG_BITS /* Use shared memory segment */
142 #define PUREBEG (char *)PURE_SEG_BITS
144 /* This variable is used only by the XPNTR macro when HAVE_SHM is
145 defined. If we used the PURESIZE macro directly there, that would
146 make most of emacs dependent on puresize.h, which we don't want -
147 you should be able to change that without too much recompilation.
148 So map_in_data initializes pure_size, and the dependencies work
151 #endif /* not HAVE_SHM */
153 /* Index in pure at which next pure object will be allocated. */
156 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
157 char *pending_malloc_warning
;
159 /* Pre-computed signal argument for use when memory is exhausted. */
160 Lisp_Object memory_signal_data
;
162 /* Maximum amount of C stack to save when a GC happens. */
164 #ifndef MAX_SAVE_STACK
165 #define MAX_SAVE_STACK 16000
168 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
169 pointer to a Lisp_Object, when that pointer is viewed as an integer.
170 (On most machines, pointers are even, so we can use the low bit.
171 Word-addressable architectures may need to override this in the m-file.)
172 When linking references to small strings through the size field, we
173 use this slot to hold the bit that would otherwise be interpreted as
175 #ifndef DONT_COPY_FLAG
176 #define DONT_COPY_FLAG 1
177 #endif /* no DONT_COPY_FLAG */
179 /* Buffer in which we save a copy of the C stack at each GC. */
184 /* Non-zero means ignore malloc warnings. Set during initialization. */
187 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
189 static void mark_object (), mark_buffer (), mark_kboards ();
190 static void clear_marks (), gc_sweep ();
191 static void compact_strings ();
193 extern int message_enable_multibyte
;
195 /* Versions of malloc and realloc that print warnings as memory gets full. */
198 malloc_warning_1 (str
)
201 Fprinc (str
, Vstandard_output
);
202 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
203 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
204 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
208 /* malloc calls this if it finds we are near exhausting storage */
214 pending_malloc_warning
= str
;
218 display_malloc_warning ()
220 register Lisp_Object val
;
222 val
= build_string (pending_malloc_warning
);
223 pending_malloc_warning
= 0;
224 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
227 #ifdef DOUG_LEA_MALLOC
228 # define BYTES_USED (mallinfo ().arena)
230 # define BYTES_USED _bytes_used
233 /* Called if malloc returns zero */
238 #ifndef SYSTEM_MALLOC
239 bytes_used_when_full
= BYTES_USED
;
242 /* The first time we get here, free the spare memory. */
249 /* This used to call error, but if we've run out of memory, we could get
250 infinite recursion trying to build the string. */
252 Fsignal (Qnil
, memory_signal_data
);
255 /* Called if we can't allocate relocatable space for a buffer. */
258 buffer_memory_full ()
260 /* If buffers use the relocating allocator,
261 no need to free spare_memory, because we may have plenty of malloc
262 space left that we could get, and if we don't, the malloc that fails
263 will itself cause spare_memory to be freed.
264 If buffers don't use the relocating allocator,
265 treat this like any other failing malloc. */
271 /* This used to call error, but if we've run out of memory, we could get
272 infinite recursion trying to build the string. */
274 Fsignal (Qerror
, memory_signal_data
);
277 /* like malloc routines but check for no memory and block interrupt input. */
286 val
= (long *) malloc (size
);
289 if (!val
&& size
) memory_full ();
294 xrealloc (block
, size
)
301 /* We must call malloc explicitly when BLOCK is 0, since some
302 reallocs don't do this. */
304 val
= (long *) malloc (size
);
306 val
= (long *) realloc (block
, size
);
309 if (!val
&& size
) memory_full ();
323 /* Arranging to disable input signals while we're in malloc.
325 This only works with GNU malloc. To help out systems which can't
326 use GNU malloc, all the calls to malloc, realloc, and free
327 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
328 pairs; unfortunately, we have no idea what C library functions
329 might call malloc, so we can't really protect them unless you're
330 using GNU malloc. Fortunately, most of the major operating can use
333 #ifndef SYSTEM_MALLOC
334 extern void * (*__malloc_hook
) ();
335 static void * (*old_malloc_hook
) ();
336 extern void * (*__realloc_hook
) ();
337 static void * (*old_realloc_hook
) ();
338 extern void (*__free_hook
) ();
339 static void (*old_free_hook
) ();
341 /* This function is used as the hook for free to call. */
344 emacs_blocked_free (ptr
)
348 __free_hook
= old_free_hook
;
350 /* If we released our reserve (due to running out of memory),
351 and we have a fair amount free once again,
352 try to set aside another reserve in case we run out once more. */
353 if (spare_memory
== 0
354 /* Verify there is enough space that even with the malloc
355 hysteresis this call won't run out again.
356 The code here is correct as long as SPARE_MEMORY
357 is substantially larger than the block size malloc uses. */
358 && (bytes_used_when_full
359 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
360 spare_memory
= (char *) malloc (SPARE_MEMORY
);
362 __free_hook
= emacs_blocked_free
;
366 /* If we released our reserve (due to running out of memory),
367 and we have a fair amount free once again,
368 try to set aside another reserve in case we run out once more.
370 This is called when a relocatable block is freed in ralloc.c. */
373 refill_memory_reserve ()
375 if (spare_memory
== 0)
376 spare_memory
= (char *) malloc (SPARE_MEMORY
);
379 /* This function is the malloc hook that Emacs uses. */
382 emacs_blocked_malloc (size
)
388 __malloc_hook
= old_malloc_hook
;
389 #ifdef DOUG_LEA_MALLOC
390 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
392 __malloc_extra_blocks
= malloc_hysteresis
;
394 value
= (void *) malloc (size
);
395 __malloc_hook
= emacs_blocked_malloc
;
402 emacs_blocked_realloc (ptr
, size
)
409 __realloc_hook
= old_realloc_hook
;
410 value
= (void *) realloc (ptr
, size
);
411 __realloc_hook
= emacs_blocked_realloc
;
418 uninterrupt_malloc ()
420 old_free_hook
= __free_hook
;
421 __free_hook
= emacs_blocked_free
;
423 old_malloc_hook
= __malloc_hook
;
424 __malloc_hook
= emacs_blocked_malloc
;
426 old_realloc_hook
= __realloc_hook
;
427 __realloc_hook
= emacs_blocked_realloc
;
431 /* Interval allocation. */
433 #ifdef USE_TEXT_PROPERTIES
434 #define INTERVAL_BLOCK_SIZE \
435 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
437 struct interval_block
439 struct interval_block
*next
;
440 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
443 struct interval_block
*interval_block
;
444 static int interval_block_index
;
446 INTERVAL interval_free_list
;
451 allocating_for_lisp
= 1;
453 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
454 allocating_for_lisp
= 0;
455 interval_block
->next
= 0;
456 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
457 interval_block_index
= 0;
458 interval_free_list
= 0;
461 #define INIT_INTERVALS init_intervals ()
468 if (interval_free_list
)
470 val
= interval_free_list
;
471 interval_free_list
= interval_free_list
->parent
;
475 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
477 register struct interval_block
*newi
;
479 allocating_for_lisp
= 1;
480 newi
= (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
482 allocating_for_lisp
= 0;
483 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
484 newi
->next
= interval_block
;
485 interval_block
= newi
;
486 interval_block_index
= 0;
488 val
= &interval_block
->intervals
[interval_block_index
++];
490 consing_since_gc
+= sizeof (struct interval
);
492 RESET_INTERVAL (val
);
496 static int total_free_intervals
, total_intervals
;
498 /* Mark the pointers of one interval. */
501 mark_interval (i
, dummy
)
505 if (XMARKBIT (i
->plist
))
507 mark_object (&i
->plist
);
512 mark_interval_tree (tree
)
513 register INTERVAL tree
;
515 /* No need to test if this tree has been marked already; this
516 function is always called through the MARK_INTERVAL_TREE macro,
517 which takes care of that. */
519 /* XMARK expands to an assignment; the LHS of an assignment can't be
521 XMARK (* (Lisp_Object
*) &tree
->parent
);
523 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
526 #define MARK_INTERVAL_TREE(i) \
528 if (!NULL_INTERVAL_P (i) \
529 && ! XMARKBIT (*(Lisp_Object *) &i->parent)) \
530 mark_interval_tree (i); \
533 /* The oddity in the call to XUNMARK is necessary because XUNMARK
534 expands to an assignment to its argument, and most C compilers don't
535 support casts on the left operand of `='. */
536 #define UNMARK_BALANCE_INTERVALS(i) \
538 if (! NULL_INTERVAL_P (i)) \
540 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
541 (i) = balance_intervals (i); \
545 #else /* no interval use */
547 #define INIT_INTERVALS
549 #define UNMARK_BALANCE_INTERVALS(i)
550 #define MARK_INTERVAL_TREE(i)
552 #endif /* no interval use */
554 /* Floating point allocation. */
556 #ifdef LISP_FLOAT_TYPE
557 /* Allocation of float cells, just like conses */
558 /* We store float cells inside of float_blocks, allocating a new
559 float_block with malloc whenever necessary. Float cells reclaimed by
560 GC are put on a free list to be reallocated before allocating
561 any new float cells from the latest float_block.
563 Each float_block is just under 1020 bytes long,
564 since malloc really allocates in units of powers of two
565 and uses 4 bytes for its own overhead. */
567 #define FLOAT_BLOCK_SIZE \
568 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
572 struct float_block
*next
;
573 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
576 struct float_block
*float_block
;
577 int float_block_index
;
579 struct Lisp_Float
*float_free_list
;
584 allocating_for_lisp
= 1;
585 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
586 allocating_for_lisp
= 0;
587 float_block
->next
= 0;
588 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
589 float_block_index
= 0;
593 /* Explicitly free a float cell. */
596 struct Lisp_Float
*ptr
;
598 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
599 float_free_list
= ptr
;
603 make_float (float_value
)
606 register Lisp_Object val
;
610 /* We use the data field for chaining the free list
611 so that we won't use the same field that has the mark bit. */
612 XSETFLOAT (val
, float_free_list
);
613 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
617 if (float_block_index
== FLOAT_BLOCK_SIZE
)
619 register struct float_block
*new;
621 allocating_for_lisp
= 1;
622 new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
623 allocating_for_lisp
= 0;
624 VALIDATE_LISP_STORAGE (new, sizeof *new);
625 new->next
= float_block
;
627 float_block_index
= 0;
629 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
631 XFLOAT (val
)->data
= float_value
;
632 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
633 consing_since_gc
+= sizeof (struct Lisp_Float
);
638 #endif /* LISP_FLOAT_TYPE */
640 /* Allocation of cons cells */
641 /* We store cons cells inside of cons_blocks, allocating a new
642 cons_block with malloc whenever necessary. Cons cells reclaimed by
643 GC are put on a free list to be reallocated before allocating
644 any new cons cells from the latest cons_block.
646 Each cons_block is just under 1020 bytes long,
647 since malloc really allocates in units of powers of two
648 and uses 4 bytes for its own overhead. */
650 #define CONS_BLOCK_SIZE \
651 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
655 struct cons_block
*next
;
656 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
659 struct cons_block
*cons_block
;
660 int cons_block_index
;
662 struct Lisp_Cons
*cons_free_list
;
667 allocating_for_lisp
= 1;
668 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
669 allocating_for_lisp
= 0;
670 cons_block
->next
= 0;
671 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
672 cons_block_index
= 0;
676 /* Explicitly free a cons cell. */
680 struct Lisp_Cons
*ptr
;
682 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
683 cons_free_list
= ptr
;
686 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
687 "Create a new cons, give it CAR and CDR as components, and return it.")
689 Lisp_Object car
, cdr
;
691 register Lisp_Object val
;
695 /* We use the cdr for chaining the free list
696 so that we won't use the same field that has the mark bit. */
697 XSETCONS (val
, cons_free_list
);
698 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
702 if (cons_block_index
== CONS_BLOCK_SIZE
)
704 register struct cons_block
*new;
705 allocating_for_lisp
= 1;
706 new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
707 allocating_for_lisp
= 0;
708 VALIDATE_LISP_STORAGE (new, sizeof *new);
709 new->next
= cons_block
;
711 cons_block_index
= 0;
713 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
715 XCONS (val
)->car
= car
;
716 XCONS (val
)->cdr
= cdr
;
717 consing_since_gc
+= sizeof (struct Lisp_Cons
);
722 /* Make a list of 2, 3, 4 or 5 specified objects. */
726 Lisp_Object arg1
, arg2
;
728 return Fcons (arg1
, Fcons (arg2
, Qnil
));
732 list3 (arg1
, arg2
, arg3
)
733 Lisp_Object arg1
, arg2
, arg3
;
735 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
739 list4 (arg1
, arg2
, arg3
, arg4
)
740 Lisp_Object arg1
, arg2
, arg3
, arg4
;
742 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
746 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
747 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
749 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
750 Fcons (arg5
, Qnil
)))));
753 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
754 "Return a newly created list with specified arguments as elements.\n\
755 Any number of arguments, even zero arguments, are allowed.")
758 register Lisp_Object
*args
;
760 register Lisp_Object val
;
766 val
= Fcons (args
[nargs
], val
);
771 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
772 "Return a newly created list of length LENGTH, with each element being INIT.")
774 register Lisp_Object length
, init
;
776 register Lisp_Object val
;
779 CHECK_NATNUM (length
, 0);
780 size
= XFASTINT (length
);
784 val
= Fcons (init
, val
);
788 /* Allocation of vectors */
790 struct Lisp_Vector
*all_vectors
;
793 allocate_vectorlike (len
)
796 struct Lisp_Vector
*p
;
798 allocating_for_lisp
= 1;
799 #ifdef DOUG_LEA_MALLOC
800 /* Prevent mmap'ing the chunk (which is potentially very large). */
801 mallopt (M_MMAP_MAX
, 0);
803 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
804 + (len
- 1) * sizeof (Lisp_Object
));
805 #ifdef DOUG_LEA_MALLOC
806 /* Back to a reasonable maximum of mmap'ed areas. */
807 mallopt (M_MMAP_MAX
, 64);
809 allocating_for_lisp
= 0;
810 VALIDATE_LISP_STORAGE (p
, 0);
811 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
812 + (len
- 1) * sizeof (Lisp_Object
));
813 vector_cells_consed
+= len
;
815 p
->next
= all_vectors
;
820 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
821 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
822 See also the function `vector'.")
824 register Lisp_Object length
, init
;
827 register EMACS_INT sizei
;
829 register struct Lisp_Vector
*p
;
831 CHECK_NATNUM (length
, 0);
832 sizei
= XFASTINT (length
);
834 p
= allocate_vectorlike (sizei
);
836 for (index
= 0; index
< sizei
; index
++)
837 p
->contents
[index
] = init
;
839 XSETVECTOR (vector
, p
);
843 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
844 "Return a newly created char-table, with purpose PURPOSE.\n\
845 Each element is initialized to INIT, which defaults to nil.\n\
846 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
847 The property's value should be an integer between 0 and 10.")
849 register Lisp_Object purpose
, init
;
853 CHECK_SYMBOL (purpose
, 1);
854 n
= Fget (purpose
, Qchar_table_extra_slots
);
856 if (XINT (n
) < 0 || XINT (n
) > 10)
857 args_out_of_range (n
, Qnil
);
858 /* Add 2 to the size for the defalt and parent slots. */
859 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
861 XCHAR_TABLE (vector
)->top
= Qt
;
862 XCHAR_TABLE (vector
)->parent
= Qnil
;
863 XCHAR_TABLE (vector
)->purpose
= purpose
;
864 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
868 /* Return a newly created sub char table with default value DEFALT.
869 Since a sub char table does not appear as a top level Emacs Lisp
870 object, we don't need a Lisp interface to make it. */
873 make_sub_char_table (defalt
)
877 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
878 XCHAR_TABLE (vector
)->top
= Qnil
;
879 XCHAR_TABLE (vector
)->defalt
= defalt
;
880 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
884 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
885 "Return a newly created vector with specified arguments as elements.\n\
886 Any number of arguments, even zero arguments, are allowed.")
891 register Lisp_Object len
, val
;
893 register struct Lisp_Vector
*p
;
895 XSETFASTINT (len
, nargs
);
896 val
= Fmake_vector (len
, Qnil
);
898 for (index
= 0; index
< nargs
; index
++)
899 p
->contents
[index
] = args
[index
];
903 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
904 "Create a byte-code object with specified arguments as elements.\n\
905 The arguments should be the arglist, bytecode-string, constant vector,\n\
906 stack size, (optional) doc string, and (optional) interactive spec.\n\
907 The first four arguments are required; at most six have any\n\
913 register Lisp_Object len
, val
;
915 register struct Lisp_Vector
*p
;
917 XSETFASTINT (len
, nargs
);
918 if (!NILP (Vpurify_flag
))
919 val
= make_pure_vector ((EMACS_INT
) nargs
);
921 val
= Fmake_vector (len
, Qnil
);
923 for (index
= 0; index
< nargs
; index
++)
925 if (!NILP (Vpurify_flag
))
926 args
[index
] = Fpurecopy (args
[index
]);
927 p
->contents
[index
] = args
[index
];
929 XSETCOMPILED (val
, p
);
933 /* Allocation of symbols.
934 Just like allocation of conses!
936 Each symbol_block is just under 1020 bytes long,
937 since malloc really allocates in units of powers of two
938 and uses 4 bytes for its own overhead. */
940 #define SYMBOL_BLOCK_SIZE \
941 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
945 struct symbol_block
*next
;
946 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
949 struct symbol_block
*symbol_block
;
950 int symbol_block_index
;
952 struct Lisp_Symbol
*symbol_free_list
;
957 allocating_for_lisp
= 1;
958 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
959 allocating_for_lisp
= 0;
960 symbol_block
->next
= 0;
961 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
962 symbol_block_index
= 0;
963 symbol_free_list
= 0;
966 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
967 "Return a newly allocated uninterned symbol whose name is NAME.\n\
968 Its value and function definition are void, and its property list is nil.")
972 register Lisp_Object val
;
973 register struct Lisp_Symbol
*p
;
975 CHECK_STRING (name
, 0);
977 if (symbol_free_list
)
979 XSETSYMBOL (val
, symbol_free_list
);
980 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
984 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
986 struct symbol_block
*new;
987 allocating_for_lisp
= 1;
988 new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
989 allocating_for_lisp
= 0;
990 VALIDATE_LISP_STORAGE (new, sizeof *new);
991 new->next
= symbol_block
;
993 symbol_block_index
= 0;
995 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
998 p
->name
= XSTRING (name
);
1001 p
->value
= Qunbound
;
1002 p
->function
= Qunbound
;
1004 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
1009 /* Allocation of markers and other objects that share that structure.
1010 Works like allocation of conses. */
1012 #define MARKER_BLOCK_SIZE \
1013 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
1017 struct marker_block
*next
;
1018 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
1021 struct marker_block
*marker_block
;
1022 int marker_block_index
;
1024 union Lisp_Misc
*marker_free_list
;
1029 allocating_for_lisp
= 1;
1030 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
1031 allocating_for_lisp
= 0;
1032 marker_block
->next
= 0;
1033 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
1034 marker_block_index
= 0;
1035 marker_free_list
= 0;
1038 /* Return a newly allocated Lisp_Misc object, with no substructure. */
1044 if (marker_free_list
)
1046 XSETMISC (val
, marker_free_list
);
1047 marker_free_list
= marker_free_list
->u_free
.chain
;
1051 if (marker_block_index
== MARKER_BLOCK_SIZE
)
1053 struct marker_block
*new;
1054 allocating_for_lisp
= 1;
1055 new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
1056 allocating_for_lisp
= 0;
1057 VALIDATE_LISP_STORAGE (new, sizeof *new);
1058 new->next
= marker_block
;
1060 marker_block_index
= 0;
1062 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
1064 consing_since_gc
+= sizeof (union Lisp_Misc
);
1065 misc_objects_consed
++;
1069 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
1070 "Return a newly allocated marker which does not point at any place.")
1073 register Lisp_Object val
;
1074 register struct Lisp_Marker
*p
;
1076 val
= allocate_misc ();
1077 XMISCTYPE (val
) = Lisp_Misc_Marker
;
1083 p
->insertion_type
= 0;
1087 /* Put MARKER back on the free list after using it temporarily. */
1090 free_marker (marker
)
1093 unchain_marker (marker
);
1095 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
1096 XMISC (marker
)->u_free
.chain
= marker_free_list
;
1097 marker_free_list
= XMISC (marker
);
1099 total_free_markers
++;
1102 /* Allocation of strings */
1104 /* Strings reside inside of string_blocks. The entire data of the string,
1105 both the size and the contents, live in part of the `chars' component of a string_block.
1106 The `pos' component is the index within `chars' of the first free byte.
1108 first_string_block points to the first string_block ever allocated.
1109 Each block points to the next one with its `next' field.
1110 The `prev' fields chain in reverse order.
1111 The last one allocated is the one currently being filled.
1112 current_string_block points to it.
1114 The string_blocks that hold individual large strings
1115 go in a separate chain, started by large_string_blocks. */
1118 /* String blocks contain this many useful bytes.
1119 8188 is power of 2, minus 4 for malloc overhead. */
1120 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
1122 /* A string bigger than this gets its own specially-made string block
1123 if it doesn't fit in the current one. */
1124 #define STRING_BLOCK_OUTSIZE 1024
1126 struct string_block_head
1128 struct string_block
*next
, *prev
;
1134 struct string_block
*next
, *prev
;
1136 char chars
[STRING_BLOCK_SIZE
];
1139 /* This points to the string block we are now allocating strings. */
1141 struct string_block
*current_string_block
;
1143 /* This points to the oldest string block, the one that starts the chain. */
1145 struct string_block
*first_string_block
;
1147 /* Last string block in chain of those made for individual large strings. */
1149 struct string_block
*large_string_blocks
;
1151 /* If SIZE is the length of a string, this returns how many bytes
1152 the string occupies in a string_block (including padding). */
1154 #define STRING_FULLSIZE(size) (((size) + 1 + STRING_BASE_SIZE + STRING_PAD - 1) \
1155 & ~(STRING_PAD - 1))
1156 /* Add 1 for the null terminator,
1157 and add STRING_PAD - 1 as part of rounding up. */
1159 #define STRING_PAD (sizeof (EMACS_INT))
1160 /* Size of the stuff in the string not including its data. */
1161 #define STRING_BASE_SIZE (((sizeof (struct Lisp_String) - 1) / STRING_PAD) * STRING_PAD)
1164 #define STRING_FULLSIZE(SIZE) \
1165 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
1171 allocating_for_lisp
= 1;
1172 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
1173 allocating_for_lisp
= 0;
1174 first_string_block
= current_string_block
;
1175 consing_since_gc
+= sizeof (struct string_block
);
1176 current_string_block
->next
= 0;
1177 current_string_block
->prev
= 0;
1178 current_string_block
->pos
= 0;
1179 large_string_blocks
= 0;
1182 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1183 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1184 Both LENGTH and INIT must be numbers.")
1186 Lisp_Object length
, init
;
1188 register Lisp_Object val
;
1189 register unsigned char *p
, *end
;
1192 CHECK_NATNUM (length
, 0);
1193 CHECK_NUMBER (init
, 1);
1196 if (SINGLE_BYTE_CHAR_P (c
))
1198 nbytes
= XINT (length
);
1199 val
= make_uninit_string (nbytes
);
1200 p
= XSTRING (val
)->data
;
1201 end
= p
+ XSTRING (val
)->size
;
1207 unsigned char work
[4], *str
;
1208 int len
= CHAR_STRING (c
, work
, str
);
1210 nbytes
= len
* XINT (length
);
1211 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1212 p
= XSTRING (val
)->data
;
1216 bcopy (str
, p
, len
);
1224 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1225 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1226 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1228 Lisp_Object length
, init
;
1230 register Lisp_Object val
;
1231 struct Lisp_Bool_Vector
*p
;
1233 int length_in_chars
, length_in_elts
, bits_per_value
;
1235 CHECK_NATNUM (length
, 0);
1237 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1239 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1240 length_in_chars
= length_in_elts
* sizeof (EMACS_INT
);
1242 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1243 slot `size' of the struct Lisp_Bool_Vector. */
1244 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1245 p
= XBOOL_VECTOR (val
);
1246 /* Get rid of any bits that would cause confusion. */
1248 XSETBOOL_VECTOR (val
, p
);
1249 p
->size
= XFASTINT (length
);
1251 real_init
= (NILP (init
) ? 0 : -1);
1252 for (i
= 0; i
< length_in_chars
; i
++)
1253 p
->data
[i
] = real_init
;
1258 /* Make a string from NBYTES bytes at CONTENTS,
1259 and compute the number of characters from the contents.
1260 This string may be unibyte or multibyte, depending on the contents. */
1263 make_string (contents
, nbytes
)
1267 register Lisp_Object val
;
1268 int nchars
= chars_in_text (contents
, nbytes
);
1269 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1270 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1271 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1272 SET_STRING_BYTES (XSTRING (val
), -1);
1276 /* Make a unibyte string from LENGTH bytes at CONTENTS. */
1279 make_unibyte_string (contents
, length
)
1283 register Lisp_Object val
;
1284 val
= make_uninit_string (length
);
1285 bcopy (contents
, XSTRING (val
)->data
, length
);
1286 SET_STRING_BYTES (XSTRING (val
), -1);
1290 /* Make a multibyte string from NCHARS characters
1291 occupying NBYTES bytes at CONTENTS. */
1294 make_multibyte_string (contents
, nchars
, nbytes
)
1298 register Lisp_Object val
;
1299 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1300 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1304 /* Make a string from NCHARS characters
1305 occupying NBYTES bytes at CONTENTS.
1306 It is a multibyte string if NBYTES != NCHARS. */
1309 make_string_from_bytes (contents
, nchars
, nbytes
)
1313 register Lisp_Object val
;
1314 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1315 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1316 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1317 SET_STRING_BYTES (XSTRING (val
), -1);
1321 /* Make a multibyte string from NCHARS characters
1322 occupying NBYTES bytes at CONTENTS. */
1325 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
1330 register Lisp_Object val
;
1331 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1332 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1334 SET_STRING_BYTES (XSTRING (val
), -1);
1338 /* Make a string from the data at STR,
1339 treating it as multibyte if the data warrants. */
1345 return make_string (str
, strlen (str
));
1349 make_uninit_string (length
)
1353 val
= make_uninit_multibyte_string (length
, length
);
1354 SET_STRING_BYTES (XSTRING (val
), -1);
1359 make_uninit_multibyte_string (length
, length_byte
)
1360 int length
, length_byte
;
1362 register Lisp_Object val
;
1363 register int fullsize
= STRING_FULLSIZE (length_byte
);
1365 if (length
< 0) abort ();
1367 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1368 /* This string can fit in the current string block */
1371 ((struct Lisp_String
*)
1372 (current_string_block
->chars
+ current_string_block
->pos
)));
1373 current_string_block
->pos
+= fullsize
;
1375 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1376 /* This string gets its own string block */
1378 register struct string_block
*new;
1379 allocating_for_lisp
= 1;
1380 #ifdef DOUG_LEA_MALLOC
1381 /* Prevent mmap'ing the chunk (which is potentially very large). */
1382 mallopt (M_MMAP_MAX
, 0);
1384 new = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
1385 #ifdef DOUG_LEA_MALLOC
1386 /* Back to a reasonable maximum of mmap'ed areas. */
1387 mallopt (M_MMAP_MAX
, 64);
1389 allocating_for_lisp
= 0;
1390 VALIDATE_LISP_STORAGE (new, 0);
1391 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1392 new->pos
= fullsize
;
1393 new->next
= large_string_blocks
;
1394 large_string_blocks
= new;
1396 ((struct Lisp_String
*)
1397 ((struct string_block_head
*)new + 1)));
1400 /* Make a new current string block and start it off with this string */
1402 register struct string_block
*new;
1403 allocating_for_lisp
= 1;
1404 new = (struct string_block
*) xmalloc (sizeof (struct string_block
));
1405 allocating_for_lisp
= 0;
1406 VALIDATE_LISP_STORAGE (new, sizeof *new);
1407 consing_since_gc
+= sizeof (struct string_block
);
1408 current_string_block
->next
= new;
1409 new->prev
= current_string_block
;
1411 current_string_block
= new;
1412 new->pos
= fullsize
;
1414 (struct Lisp_String
*) current_string_block
->chars
);
1417 string_chars_consed
+= fullsize
;
1418 XSTRING (val
)->size
= length
;
1419 SET_STRING_BYTES (XSTRING (val
), length_byte
);
1420 XSTRING (val
)->data
[length_byte
] = 0;
1421 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1426 /* Return a newly created vector or string with specified arguments as
1427 elements. If all the arguments are characters that can fit
1428 in a string of events, make a string; otherwise, make a vector.
1430 Any number of arguments, even zero arguments, are allowed. */
1433 make_event_array (nargs
, args
)
1439 for (i
= 0; i
< nargs
; i
++)
1440 /* The things that fit in a string
1441 are characters that are in 0...127,
1442 after discarding the meta bit and all the bits above it. */
1443 if (!INTEGERP (args
[i
])
1444 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1445 return Fvector (nargs
, args
);
1447 /* Since the loop exited, we know that all the things in it are
1448 characters, so we can make a string. */
1452 result
= Fmake_string (make_number (nargs
), make_number (0));
1453 for (i
= 0; i
< nargs
; i
++)
1455 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1456 /* Move the meta bit to the right place for a string char. */
1457 if (XINT (args
[i
]) & CHAR_META
)
1458 XSTRING (result
)->data
[i
] |= 0x80;
1465 /* Pure storage management. */
1467 /* Must get an error if pure storage is full,
1468 since if it cannot hold a large string
1469 it may be able to hold conses that point to that string;
1470 then the string is not protected from gc. */
1473 make_pure_string (data
, length
, length_byte
, multibyte
)
1480 register Lisp_Object
new;
1481 register int size
= STRING_FULLSIZE (length_byte
);
1483 if (pureptr
+ size
> PURESIZE
)
1484 error ("Pure Lisp storage exhausted");
1485 XSETSTRING (new, PUREBEG
+ pureptr
);
1486 XSTRING (new)->size
= length
;
1487 SET_STRING_BYTES (XSTRING (new), (multibyte
? length_byte
: -1));
1488 bcopy (data
, XSTRING (new)->data
, length_byte
);
1489 XSTRING (new)->data
[length_byte
] = 0;
1491 /* We must give strings in pure storage some kind of interval. So we
1492 give them a null one. */
1493 #if defined (USE_TEXT_PROPERTIES)
1494 XSTRING (new)->intervals
= NULL_INTERVAL
;
1501 pure_cons (car
, cdr
)
1502 Lisp_Object car
, cdr
;
1504 register Lisp_Object
new;
1506 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1507 error ("Pure Lisp storage exhausted");
1508 XSETCONS (new, PUREBEG
+ pureptr
);
1509 pureptr
+= sizeof (struct Lisp_Cons
);
1510 XCONS (new)->car
= Fpurecopy (car
);
1511 XCONS (new)->cdr
= Fpurecopy (cdr
);
1515 #ifdef LISP_FLOAT_TYPE
1518 make_pure_float (num
)
1521 register Lisp_Object
new;
1523 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1524 (double) boundary. Some architectures (like the sparc) require
1525 this, and I suspect that floats are rare enough that it's no
1526 tragedy for those that do. */
1529 char *p
= PUREBEG
+ pureptr
;
1533 alignment
= __alignof (struct Lisp_Float
);
1535 alignment
= sizeof (struct Lisp_Float
);
1538 alignment
= sizeof (struct Lisp_Float
);
1540 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1541 pureptr
= p
- PUREBEG
;
1544 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1545 error ("Pure Lisp storage exhausted");
1546 XSETFLOAT (new, PUREBEG
+ pureptr
);
1547 pureptr
+= sizeof (struct Lisp_Float
);
1548 XFLOAT (new)->data
= num
;
1549 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1553 #endif /* LISP_FLOAT_TYPE */
1556 make_pure_vector (len
)
1559 register Lisp_Object
new;
1560 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1562 if (pureptr
+ size
> PURESIZE
)
1563 error ("Pure Lisp storage exhausted");
1565 XSETVECTOR (new, PUREBEG
+ pureptr
);
1567 XVECTOR (new)->size
= len
;
1571 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1572 "Make a copy of OBJECT in pure storage.\n\
1573 Recursively copies contents of vectors and cons cells.\n\
1574 Does not copy symbols.")
1576 register Lisp_Object obj
;
1578 if (NILP (Vpurify_flag
))
1581 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1582 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1586 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1587 #ifdef LISP_FLOAT_TYPE
1588 else if (FLOATP (obj
))
1589 return make_pure_float (XFLOAT (obj
)->data
);
1590 #endif /* LISP_FLOAT_TYPE */
1591 else if (STRINGP (obj
))
1592 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
1593 STRING_BYTES (XSTRING (obj
)),
1594 STRING_MULTIBYTE (obj
));
1595 else if (COMPILEDP (obj
) || VECTORP (obj
))
1597 register struct Lisp_Vector
*vec
;
1598 register int i
, size
;
1600 size
= XVECTOR (obj
)->size
;
1601 if (size
& PSEUDOVECTOR_FLAG
)
1602 size
&= PSEUDOVECTOR_SIZE_MASK
;
1603 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
1604 for (i
= 0; i
< size
; i
++)
1605 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1606 if (COMPILEDP (obj
))
1607 XSETCOMPILED (obj
, vec
);
1609 XSETVECTOR (obj
, vec
);
1612 else if (MARKERP (obj
))
1613 error ("Attempt to copy a marker to pure storage");
1618 /* Recording what needs to be marked for gc. */
1620 struct gcpro
*gcprolist
;
1622 #define NSTATICS 768
1624 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1628 /* Put an entry in staticvec, pointing at the variable whose address is given */
1631 staticpro (varaddress
)
1632 Lisp_Object
*varaddress
;
1634 staticvec
[staticidx
++] = varaddress
;
1635 if (staticidx
>= NSTATICS
)
1643 struct catchtag
*next
;
1644 #if 0 /* We don't need this for GC purposes */
1651 struct backtrace
*next
;
1652 Lisp_Object
*function
;
1653 Lisp_Object
*args
; /* Points to vector of args. */
1654 int nargs
; /* length of vector */
1655 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1659 /* Garbage collection! */
1661 /* Temporarily prevent garbage collection. */
1664 inhibit_garbage_collection ()
1666 int count
= specpdl_ptr
- specpdl
;
1668 int nbits
= min (VALBITS
, BITS_PER_INT
);
1670 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1672 specbind (Qgc_cons_threshold
, number
);
1677 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1678 "Reclaim storage for Lisp objects no longer needed.\n\
1679 Returns info on amount of space in use:\n\
1680 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1681 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1682 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS))\n\
1683 Garbage collection happens automatically if you cons more than\n\
1684 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1687 register struct gcpro
*tail
;
1688 register struct specbinding
*bind
;
1689 struct catchtag
*catch;
1690 struct handler
*handler
;
1691 register struct backtrace
*backlist
;
1692 register Lisp_Object tem
;
1693 char *omessage
= echo_area_glyphs
;
1694 int omessage_length
= echo_area_glyphs_length
;
1695 int oldmultibyte
= message_enable_multibyte
;
1696 char stack_top_variable
;
1699 /* In case user calls debug_print during GC,
1700 don't let that cause a recursive GC. */
1701 consing_since_gc
= 0;
1703 /* Save a copy of the contents of the stack, for debugging. */
1704 #if MAX_SAVE_STACK > 0
1705 if (NILP (Vpurify_flag
))
1707 i
= &stack_top_variable
- stack_bottom
;
1709 if (i
< MAX_SAVE_STACK
)
1711 if (stack_copy
== 0)
1712 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1713 else if (stack_copy_size
< i
)
1714 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1717 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1718 bcopy (stack_bottom
, stack_copy
, i
);
1720 bcopy (&stack_top_variable
, stack_copy
, i
);
1724 #endif /* MAX_SAVE_STACK > 0 */
1726 if (garbage_collection_messages
)
1727 message1_nolog ("Garbage collecting...");
1729 /* Don't keep undo information around forever. */
1731 register struct buffer
*nextb
= all_buffers
;
1735 /* If a buffer's undo list is Qt, that means that undo is
1736 turned off in that buffer. Calling truncate_undo_list on
1737 Qt tends to return NULL, which effectively turns undo back on.
1738 So don't call truncate_undo_list if undo_list is Qt. */
1739 if (! EQ (nextb
->undo_list
, Qt
))
1741 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1743 nextb
= nextb
->next
;
1749 /* clear_marks (); */
1751 /* In each "large string", set the MARKBIT of the size field.
1752 That enables mark_object to recognize them. */
1754 register struct string_block
*b
;
1755 for (b
= large_string_blocks
; b
; b
= b
->next
)
1756 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1759 /* Mark all the special slots that serve as the roots of accessibility.
1761 Usually the special slots to mark are contained in particular structures.
1762 Then we know no slot is marked twice because the structures don't overlap.
1763 In some cases, the structures point to the slots to be marked.
1764 For these, we use MARKBIT to avoid double marking of the slot. */
1766 for (i
= 0; i
< staticidx
; i
++)
1767 mark_object (staticvec
[i
]);
1768 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1769 for (i
= 0; i
< tail
->nvars
; i
++)
1770 if (!XMARKBIT (tail
->var
[i
]))
1772 mark_object (&tail
->var
[i
]);
1773 XMARK (tail
->var
[i
]);
1775 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1777 mark_object (&bind
->symbol
);
1778 mark_object (&bind
->old_value
);
1780 for (catch = catchlist
; catch; catch = catch->next
)
1782 mark_object (&catch->tag
);
1783 mark_object (&catch->val
);
1785 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1787 mark_object (&handler
->handler
);
1788 mark_object (&handler
->var
);
1790 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1792 if (!XMARKBIT (*backlist
->function
))
1794 mark_object (backlist
->function
);
1795 XMARK (*backlist
->function
);
1797 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1800 i
= backlist
->nargs
- 1;
1802 if (!XMARKBIT (backlist
->args
[i
]))
1804 mark_object (&backlist
->args
[i
]);
1805 XMARK (backlist
->args
[i
]);
1810 /* Look thru every buffer's undo list
1811 for elements that update markers that were not marked,
1814 register struct buffer
*nextb
= all_buffers
;
1818 /* If a buffer's undo list is Qt, that means that undo is
1819 turned off in that buffer. Calling truncate_undo_list on
1820 Qt tends to return NULL, which effectively turns undo back on.
1821 So don't call truncate_undo_list if undo_list is Qt. */
1822 if (! EQ (nextb
->undo_list
, Qt
))
1824 Lisp_Object tail
, prev
;
1825 tail
= nextb
->undo_list
;
1827 while (CONSP (tail
))
1829 if (GC_CONSP (XCONS (tail
)->car
)
1830 && GC_MARKERP (XCONS (XCONS (tail
)->car
)->car
)
1831 && ! XMARKBIT (XMARKER (XCONS (XCONS (tail
)->car
)->car
)->chain
))
1834 nextb
->undo_list
= tail
= XCONS (tail
)->cdr
;
1836 tail
= XCONS (prev
)->cdr
= XCONS (tail
)->cdr
;
1841 tail
= XCONS (tail
)->cdr
;
1846 nextb
= nextb
->next
;
1852 /* Clear the mark bits that we set in certain root slots. */
1854 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1855 for (i
= 0; i
< tail
->nvars
; i
++)
1856 XUNMARK (tail
->var
[i
]);
1857 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1859 XUNMARK (*backlist
->function
);
1860 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1863 i
= backlist
->nargs
- 1;
1865 XUNMARK (backlist
->args
[i
]);
1867 XUNMARK (buffer_defaults
.name
);
1868 XUNMARK (buffer_local_symbols
.name
);
1870 /* clear_marks (); */
1873 consing_since_gc
= 0;
1874 if (gc_cons_threshold
< 10000)
1875 gc_cons_threshold
= 10000;
1877 if (garbage_collection_messages
)
1879 if (omessage
|| minibuf_level
> 0)
1880 message2_nolog (omessage
, omessage_length
, oldmultibyte
);
1882 message1_nolog ("Garbage collecting...done");
1885 return Fcons (Fcons (make_number (total_conses
),
1886 make_number (total_free_conses
)),
1887 Fcons (Fcons (make_number (total_symbols
),
1888 make_number (total_free_symbols
)),
1889 Fcons (Fcons (make_number (total_markers
),
1890 make_number (total_free_markers
)),
1891 Fcons (make_number (total_string_size
),
1892 Fcons (make_number (total_vector_size
),
1894 #ifdef LISP_FLOAT_TYPE
1895 (make_number (total_floats
),
1896 make_number (total_free_floats
)),
1897 #else /* not LISP_FLOAT_TYPE */
1898 (make_number (0), make_number (0)),
1899 #endif /* not LISP_FLOAT_TYPE */
1901 #ifdef USE_TEXT_PROPERTIES
1902 (make_number (total_intervals
),
1903 make_number (total_free_intervals
)),
1904 #else /* not USE_TEXT_PROPERTIES */
1905 (make_number (0), make_number (0)),
1906 #endif /* not USE_TEXT_PROPERTIES */
1914 /* Clear marks on all conses */
1916 register struct cons_block
*cblk
;
1917 register int lim
= cons_block_index
;
1919 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1922 for (i
= 0; i
< lim
; i
++)
1923 XUNMARK (cblk
->conses
[i
].car
);
1924 lim
= CONS_BLOCK_SIZE
;
1927 /* Clear marks on all symbols */
1929 register struct symbol_block
*sblk
;
1930 register int lim
= symbol_block_index
;
1932 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1935 for (i
= 0; i
< lim
; i
++)
1937 XUNMARK (sblk
->symbols
[i
].plist
);
1939 lim
= SYMBOL_BLOCK_SIZE
;
1942 /* Clear marks on all markers */
1944 register struct marker_block
*sblk
;
1945 register int lim
= marker_block_index
;
1947 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1950 for (i
= 0; i
< lim
; i
++)
1951 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1952 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1953 lim
= MARKER_BLOCK_SIZE
;
1956 /* Clear mark bits on all buffers */
1958 register struct buffer
*nextb
= all_buffers
;
1962 XUNMARK (nextb
->name
);
1963 nextb
= nextb
->next
;
1969 /* Mark reference to a Lisp_Object.
1970 If the object referred to has not been seen yet, recursively mark
1971 all the references contained in it.
1973 If the object referenced is a short string, the referencing slot
1974 is threaded into a chain of such slots, pointed to from
1975 the `size' field of the string. The actual string size
1976 lives in the last slot in the chain. We recognize the end
1977 because it is < (unsigned) STRING_BLOCK_SIZE. */
1979 #define LAST_MARKED_SIZE 500
1980 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1981 int last_marked_index
;
1984 mark_object (argptr
)
1985 Lisp_Object
*argptr
;
1987 Lisp_Object
*objptr
= argptr
;
1988 register Lisp_Object obj
;
1995 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1996 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1999 last_marked
[last_marked_index
++] = objptr
;
2000 if (last_marked_index
== LAST_MARKED_SIZE
)
2001 last_marked_index
= 0;
2003 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
2007 register struct Lisp_String
*ptr
= XSTRING (obj
);
2009 MARK_INTERVAL_TREE (ptr
->intervals
);
2010 if (ptr
->size
& MARKBIT
)
2011 /* A large string. Just set ARRAY_MARK_FLAG. */
2012 ptr
->size
|= ARRAY_MARK_FLAG
;
2015 /* A small string. Put this reference
2016 into the chain of references to it.
2017 If the address includes MARKBIT, put that bit elsewhere
2018 when we store OBJPTR into the size field. */
2020 if (XMARKBIT (*objptr
))
2022 XSETFASTINT (*objptr
, ptr
->size
);
2026 XSETFASTINT (*objptr
, ptr
->size
);
2028 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
2030 ptr
->size
= (EMACS_INT
) objptr
;
2031 if (ptr
->size
& MARKBIT
)
2032 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
2037 case Lisp_Vectorlike
:
2038 if (GC_BUFFERP (obj
))
2040 if (!XMARKBIT (XBUFFER (obj
)->name
))
2043 else if (GC_SUBRP (obj
))
2045 else if (GC_COMPILEDP (obj
))
2046 /* We could treat this just like a vector, but it is better
2047 to save the COMPILED_CONSTANTS element for last and avoid recursion
2050 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2051 register EMACS_INT size
= ptr
->size
;
2052 /* See comment above under Lisp_Vector. */
2053 struct Lisp_Vector
*volatile ptr1
= ptr
;
2056 if (size
& ARRAY_MARK_FLAG
)
2057 break; /* Already marked */
2058 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2059 size
&= PSEUDOVECTOR_SIZE_MASK
;
2060 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2062 if (i
!= COMPILED_CONSTANTS
)
2063 mark_object (&ptr1
->contents
[i
]);
2065 /* This cast should be unnecessary, but some Mips compiler complains
2066 (MIPS-ABI + SysVR4, DC/OSx, etc). */
2067 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
2070 else if (GC_FRAMEP (obj
))
2072 /* See comment above under Lisp_Vector for why this is volatile. */
2073 register struct frame
*volatile ptr
= XFRAME (obj
);
2074 register EMACS_INT size
= ptr
->size
;
2076 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2077 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2079 mark_object (&ptr
->name
);
2080 mark_object (&ptr
->icon_name
);
2081 mark_object (&ptr
->title
);
2082 mark_object (&ptr
->focus_frame
);
2083 mark_object (&ptr
->selected_window
);
2084 mark_object (&ptr
->minibuffer_window
);
2085 mark_object (&ptr
->param_alist
);
2086 mark_object (&ptr
->scroll_bars
);
2087 mark_object (&ptr
->condemned_scroll_bars
);
2088 mark_object (&ptr
->menu_bar_items
);
2089 mark_object (&ptr
->face_alist
);
2090 mark_object (&ptr
->menu_bar_vector
);
2091 mark_object (&ptr
->buffer_predicate
);
2092 mark_object (&ptr
->buffer_list
);
2094 else if (GC_BOOL_VECTOR_P (obj
))
2096 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2098 if (ptr
->size
& ARRAY_MARK_FLAG
)
2099 break; /* Already marked */
2100 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2104 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2105 register EMACS_INT size
= ptr
->size
;
2106 /* The reason we use ptr1 is to avoid an apparent hardware bug
2107 that happens occasionally on the FSF's HP 300s.
2108 The bug is that a2 gets clobbered by recursive calls to mark_object.
2109 The clobberage seems to happen during function entry,
2110 perhaps in the moveml instruction.
2111 Yes, this is a crock, but we have to do it. */
2112 struct Lisp_Vector
*volatile ptr1
= ptr
;
2115 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2116 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2117 if (size
& PSEUDOVECTOR_FLAG
)
2118 size
&= PSEUDOVECTOR_SIZE_MASK
;
2119 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2120 mark_object (&ptr1
->contents
[i
]);
2126 /* See comment above under Lisp_Vector for why this is volatile. */
2127 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
2128 struct Lisp_Symbol
*ptrx
;
2130 if (XMARKBIT (ptr
->plist
)) break;
2132 mark_object ((Lisp_Object
*) &ptr
->value
);
2133 mark_object (&ptr
->function
);
2134 mark_object (&ptr
->plist
);
2135 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
2136 mark_object (&ptr
->name
);
2137 /* Note that we do not mark the obarray of the symbol.
2138 It is safe not to do so because nothing accesses that
2139 slot except to check whether it is nil. */
2143 /* For the benefit of the last_marked log. */
2144 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
2145 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
2146 XSETSYMBOL (obj
, ptrx
);
2147 /* We can't goto loop here because *objptr doesn't contain an
2148 actual Lisp_Object with valid datatype field. */
2155 switch (XMISCTYPE (obj
))
2157 case Lisp_Misc_Marker
:
2158 XMARK (XMARKER (obj
)->chain
);
2159 /* DO NOT mark thru the marker's chain.
2160 The buffer's markers chain does not preserve markers from gc;
2161 instead, markers are removed from the chain when freed by gc. */
2164 case Lisp_Misc_Buffer_Local_Value
:
2165 case Lisp_Misc_Some_Buffer_Local_Value
:
2167 register struct Lisp_Buffer_Local_Value
*ptr
2168 = XBUFFER_LOCAL_VALUE (obj
);
2169 if (XMARKBIT (ptr
->realvalue
)) break;
2170 XMARK (ptr
->realvalue
);
2171 /* If the cdr is nil, avoid recursion for the car. */
2172 if (EQ (ptr
->cdr
, Qnil
))
2174 objptr
= &ptr
->realvalue
;
2177 mark_object (&ptr
->realvalue
);
2178 mark_object (&ptr
->buffer
);
2179 mark_object (&ptr
->frame
);
2180 /* See comment above under Lisp_Vector for why not use ptr here. */
2181 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
2185 case Lisp_Misc_Intfwd
:
2186 case Lisp_Misc_Boolfwd
:
2187 case Lisp_Misc_Objfwd
:
2188 case Lisp_Misc_Buffer_Objfwd
:
2189 case Lisp_Misc_Kboard_Objfwd
:
2190 /* Don't bother with Lisp_Buffer_Objfwd,
2191 since all markable slots in current buffer marked anyway. */
2192 /* Don't need to do Lisp_Objfwd, since the places they point
2193 are protected with staticpro. */
2196 case Lisp_Misc_Overlay
:
2198 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
2199 if (!XMARKBIT (ptr
->plist
))
2202 mark_object (&ptr
->start
);
2203 mark_object (&ptr
->end
);
2204 objptr
= &ptr
->plist
;
2217 register struct Lisp_Cons
*ptr
= XCONS (obj
);
2218 if (XMARKBIT (ptr
->car
)) break;
2220 /* If the cdr is nil, avoid recursion for the car. */
2221 if (EQ (ptr
->cdr
, Qnil
))
2226 mark_object (&ptr
->car
);
2227 /* See comment above under Lisp_Vector for why not use ptr here. */
2228 objptr
= &XCONS (obj
)->cdr
;
2232 #ifdef LISP_FLOAT_TYPE
2234 XMARK (XFLOAT (obj
)->type
);
2236 #endif /* LISP_FLOAT_TYPE */
2246 /* Mark the pointers in a buffer structure. */
2252 register struct buffer
*buffer
= XBUFFER (buf
);
2253 register Lisp_Object
*ptr
;
2254 Lisp_Object base_buffer
;
2256 /* This is the buffer's markbit */
2257 mark_object (&buffer
->name
);
2258 XMARK (buffer
->name
);
2260 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
2262 if (CONSP (buffer
->undo_list
))
2265 tail
= buffer
->undo_list
;
2267 while (CONSP (tail
))
2269 register struct Lisp_Cons
*ptr
= XCONS (tail
);
2271 if (XMARKBIT (ptr
->car
))
2274 if (GC_CONSP (ptr
->car
)
2275 && ! XMARKBIT (XCONS (ptr
->car
)->car
)
2276 && GC_MARKERP (XCONS (ptr
->car
)->car
))
2278 XMARK (XCONS (ptr
->car
)->car
);
2279 mark_object (&XCONS (ptr
->car
)->cdr
);
2282 mark_object (&ptr
->car
);
2284 if (CONSP (ptr
->cdr
))
2290 mark_object (&XCONS (tail
)->cdr
);
2293 mark_object (&buffer
->undo_list
);
2296 mark_object (buffer
->syntax_table
);
2298 /* Mark the various string-pointers in the buffer object.
2299 Since the strings may be relocated, we must mark them
2300 in their actual slots. So gc_sweep must convert each slot
2301 back to an ordinary C pointer. */
2302 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
2303 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
2304 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
2305 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
2307 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
2308 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
2309 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
2310 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
2313 for (ptr
= &buffer
->name
+ 1;
2314 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
2318 /* If this is an indirect buffer, mark its base buffer. */
2319 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
2321 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2322 mark_buffer (base_buffer
);
2327 /* Mark the pointers in the kboard objects. */
2334 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2336 if (kb
->kbd_macro_buffer
)
2337 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2339 mark_object (&kb
->Vprefix_arg
);
2340 mark_object (&kb
->kbd_queue
);
2341 mark_object (&kb
->Vlast_kbd_macro
);
2342 mark_object (&kb
->Vsystem_key_alist
);
2343 mark_object (&kb
->system_key_syms
);
2347 /* Sweep: find all structures not marked, and free them. */
2352 total_string_size
= 0;
2355 /* Put all unmarked conses on free list */
2357 register struct cons_block
*cblk
;
2358 struct cons_block
**cprev
= &cons_block
;
2359 register int lim
= cons_block_index
;
2360 register int num_free
= 0, num_used
= 0;
2364 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
2368 for (i
= 0; i
< lim
; i
++)
2369 if (!XMARKBIT (cblk
->conses
[i
].car
))
2372 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
2373 cons_free_list
= &cblk
->conses
[i
];
2378 XUNMARK (cblk
->conses
[i
].car
);
2380 lim
= CONS_BLOCK_SIZE
;
2381 /* If this block contains only free conses and we have already
2382 seen more than two blocks worth of free conses then deallocate
2384 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
2386 *cprev
= cblk
->next
;
2387 /* Unhook from the free list. */
2388 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
2393 num_free
+= this_free
;
2394 cprev
= &cblk
->next
;
2397 total_conses
= num_used
;
2398 total_free_conses
= num_free
;
2401 #ifdef LISP_FLOAT_TYPE
2402 /* Put all unmarked floats on free list */
2404 register struct float_block
*fblk
;
2405 struct float_block
**fprev
= &float_block
;
2406 register int lim
= float_block_index
;
2407 register int num_free
= 0, num_used
= 0;
2409 float_free_list
= 0;
2411 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
2415 for (i
= 0; i
< lim
; i
++)
2416 if (!XMARKBIT (fblk
->floats
[i
].type
))
2419 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
2420 float_free_list
= &fblk
->floats
[i
];
2425 XUNMARK (fblk
->floats
[i
].type
);
2427 lim
= FLOAT_BLOCK_SIZE
;
2428 /* If this block contains only free floats and we have already
2429 seen more than two blocks worth of free floats then deallocate
2431 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
2433 *fprev
= fblk
->next
;
2434 /* Unhook from the free list. */
2435 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
2440 num_free
+= this_free
;
2441 fprev
= &fblk
->next
;
2444 total_floats
= num_used
;
2445 total_free_floats
= num_free
;
2447 #endif /* LISP_FLOAT_TYPE */
2449 #ifdef USE_TEXT_PROPERTIES
2450 /* Put all unmarked intervals on free list */
2452 register struct interval_block
*iblk
;
2453 struct interval_block
**iprev
= &interval_block
;
2454 register int lim
= interval_block_index
;
2455 register int num_free
= 0, num_used
= 0;
2457 interval_free_list
= 0;
2459 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
2464 for (i
= 0; i
< lim
; i
++)
2466 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2468 iblk
->intervals
[i
].parent
= interval_free_list
;
2469 interval_free_list
= &iblk
->intervals
[i
];
2475 XUNMARK (iblk
->intervals
[i
].plist
);
2478 lim
= INTERVAL_BLOCK_SIZE
;
2479 /* If this block contains only free intervals and we have already
2480 seen more than two blocks worth of free intervals then
2481 deallocate this block. */
2482 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
2484 *iprev
= iblk
->next
;
2485 /* Unhook from the free list. */
2486 interval_free_list
= iblk
->intervals
[0].parent
;
2491 num_free
+= this_free
;
2492 iprev
= &iblk
->next
;
2495 total_intervals
= num_used
;
2496 total_free_intervals
= num_free
;
2498 #endif /* USE_TEXT_PROPERTIES */
2500 /* Put all unmarked symbols on free list */
2502 register struct symbol_block
*sblk
;
2503 struct symbol_block
**sprev
= &symbol_block
;
2504 register int lim
= symbol_block_index
;
2505 register int num_free
= 0, num_used
= 0;
2507 symbol_free_list
= 0;
2509 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
2513 for (i
= 0; i
< lim
; i
++)
2514 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2516 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2517 symbol_free_list
= &sblk
->symbols
[i
];
2523 sblk
->symbols
[i
].name
2524 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2525 XUNMARK (sblk
->symbols
[i
].plist
);
2527 lim
= SYMBOL_BLOCK_SIZE
;
2528 /* If this block contains only free symbols and we have already
2529 seen more than two blocks worth of free symbols then deallocate
2531 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
2533 *sprev
= sblk
->next
;
2534 /* Unhook from the free list. */
2535 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
2540 num_free
+= this_free
;
2541 sprev
= &sblk
->next
;
2544 total_symbols
= num_used
;
2545 total_free_symbols
= num_free
;
2549 /* Put all unmarked misc's on free list.
2550 For a marker, first unchain it from the buffer it points into. */
2552 register struct marker_block
*mblk
;
2553 struct marker_block
**mprev
= &marker_block
;
2554 register int lim
= marker_block_index
;
2555 register int num_free
= 0, num_used
= 0;
2557 marker_free_list
= 0;
2559 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
2563 EMACS_INT already_free
= -1;
2565 for (i
= 0; i
< lim
; i
++)
2567 Lisp_Object
*markword
;
2568 switch (mblk
->markers
[i
].u_marker
.type
)
2570 case Lisp_Misc_Marker
:
2571 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2573 case Lisp_Misc_Buffer_Local_Value
:
2574 case Lisp_Misc_Some_Buffer_Local_Value
:
2575 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
2577 case Lisp_Misc_Overlay
:
2578 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2580 case Lisp_Misc_Free
:
2581 /* If the object was already free, keep it
2582 on the free list. */
2583 markword
= (Lisp_Object
*) &already_free
;
2589 if (markword
&& !XMARKBIT (*markword
))
2592 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2594 /* tem1 avoids Sun compiler bug */
2595 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2596 XSETMARKER (tem
, tem1
);
2597 unchain_marker (tem
);
2599 /* Set the type of the freed object to Lisp_Misc_Free.
2600 We could leave the type alone, since nobody checks it,
2601 but this might catch bugs faster. */
2602 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2603 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2604 marker_free_list
= &mblk
->markers
[i
];
2611 XUNMARK (*markword
);
2614 lim
= MARKER_BLOCK_SIZE
;
2615 /* If this block contains only free markers and we have already
2616 seen more than two blocks worth of free markers then deallocate
2618 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
2620 *mprev
= mblk
->next
;
2621 /* Unhook from the free list. */
2622 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
2627 num_free
+= this_free
;
2628 mprev
= &mblk
->next
;
2632 total_markers
= num_used
;
2633 total_free_markers
= num_free
;
2636 /* Free all unmarked buffers */
2638 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2641 if (!XMARKBIT (buffer
->name
))
2644 prev
->next
= buffer
->next
;
2646 all_buffers
= buffer
->next
;
2647 next
= buffer
->next
;
2653 XUNMARK (buffer
->name
);
2654 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2657 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2658 for purposes of marking and relocation.
2659 Turn them back into C pointers now. */
2660 buffer
->upcase_table
2661 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2662 buffer
->downcase_table
2663 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2665 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2666 buffer
->folding_sort_table
2667 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2670 prev
= buffer
, buffer
= buffer
->next
;
2674 #endif /* standalone */
2676 /* Free all unmarked vectors */
2678 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2679 total_vector_size
= 0;
2682 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2685 prev
->next
= vector
->next
;
2687 all_vectors
= vector
->next
;
2688 next
= vector
->next
;
2694 vector
->size
&= ~ARRAY_MARK_FLAG
;
2695 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2696 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2698 total_vector_size
+= vector
->size
;
2699 prev
= vector
, vector
= vector
->next
;
2703 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2705 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2706 struct Lisp_String
*s
;
2710 s
= (struct Lisp_String
*) &sb
->chars
[0];
2711 if (s
->size
& ARRAY_MARK_FLAG
)
2713 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2714 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2715 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2716 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2717 prev
= sb
, sb
= sb
->next
;
2722 prev
->next
= sb
->next
;
2724 large_string_blocks
= sb
->next
;
2733 /* Compactify strings, relocate references, and free empty string blocks. */
2738 /* String block of old strings we are scanning. */
2739 register struct string_block
*from_sb
;
2740 /* A preceding string block (or maybe the same one)
2741 where we are copying the still-live strings to. */
2742 register struct string_block
*to_sb
;
2746 to_sb
= first_string_block
;
2749 /* Scan each existing string block sequentially, string by string. */
2750 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2753 /* POS is the index of the next string in the block. */
2754 while (pos
< from_sb
->pos
)
2756 register struct Lisp_String
*nextstr
2757 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2759 register struct Lisp_String
*newaddr
;
2760 register EMACS_INT size
= nextstr
->size
;
2761 EMACS_INT size_byte
= nextstr
->size_byte
;
2763 /* NEXTSTR is the old address of the next string.
2764 Just skip it if it isn't marked. */
2765 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2767 /* It is marked, so its size field is really a chain of refs.
2768 Find the end of the chain, where the actual size lives. */
2769 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2771 if (size
& DONT_COPY_FLAG
)
2772 size
^= MARKBIT
| DONT_COPY_FLAG
;
2773 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2779 total_string_size
+= size_byte
;
2781 /* If it won't fit in TO_SB, close it out,
2782 and move to the next sb. Keep doing so until
2783 TO_SB reaches a large enough, empty enough string block.
2784 We know that TO_SB cannot advance past FROM_SB here
2785 since FROM_SB is large enough to contain this string.
2786 Any string blocks skipped here
2787 will be patched out and freed later. */
2788 while (to_pos
+ STRING_FULLSIZE (size_byte
)
2789 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2791 to_sb
->pos
= to_pos
;
2792 to_sb
= to_sb
->next
;
2795 /* Compute new address of this string
2796 and update TO_POS for the space being used. */
2797 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2798 to_pos
+= STRING_FULLSIZE (size_byte
);
2800 /* Copy the string itself to the new place. */
2801 if (nextstr
!= newaddr
)
2802 bcopy (nextstr
, newaddr
, STRING_FULLSIZE (size_byte
));
2804 /* Go through NEXTSTR's chain of references
2805 and make each slot in the chain point to
2806 the new address of this string. */
2807 size
= newaddr
->size
;
2808 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2810 register Lisp_Object
*objptr
;
2811 if (size
& DONT_COPY_FLAG
)
2812 size
^= MARKBIT
| DONT_COPY_FLAG
;
2813 objptr
= (Lisp_Object
*)size
;
2815 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2816 if (XMARKBIT (*objptr
))
2818 XSETSTRING (*objptr
, newaddr
);
2822 XSETSTRING (*objptr
, newaddr
);
2824 /* Store the actual size in the size field. */
2825 newaddr
->size
= size
;
2827 #ifdef USE_TEXT_PROPERTIES
2828 /* Now that the string has been relocated, rebalance its
2829 interval tree, and update the tree's parent pointer. */
2830 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2832 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2833 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2836 #endif /* USE_TEXT_PROPERTIES */
2838 else if (size_byte
< 0)
2841 pos
+= STRING_FULLSIZE (size_byte
);
2845 /* Close out the last string block still used and free any that follow. */
2846 to_sb
->pos
= to_pos
;
2847 current_string_block
= to_sb
;
2849 from_sb
= to_sb
->next
;
2853 to_sb
= from_sb
->next
;
2858 /* Free any empty string blocks further back in the chain.
2859 This loop will never free first_string_block, but it is very
2860 unlikely that that one will become empty, so why bother checking? */
2862 from_sb
= first_string_block
;
2863 while (to_sb
= from_sb
->next
)
2865 if (to_sb
->pos
== 0)
2867 if (from_sb
->next
= to_sb
->next
)
2868 from_sb
->next
->prev
= from_sb
;
2876 /* Debugging aids. */
2878 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2879 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2880 This may be helpful in debugging Emacs's memory usage.\n\
2881 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2886 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2891 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2892 "Return a list of counters that measure how much consing there has been.\n\
2893 Each of these counters increments for a certain kind of object.\n\
2894 The counters wrap around from the largest positive integer to zero.\n\
2895 Garbage collection does not decrease them.\n\
2896 The elements of the value are as follows:\n\
2897 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2898 All are in units of 1 = one object consed\n\
2899 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2901 MISCS include overlays, markers, and some internal types.\n\
2902 Frames, windows, buffers, and subprocesses count as vectors\n\
2903 (but the contents of a buffer's text do not count here).")
2906 Lisp_Object lisp_cons_cells_consed
;
2907 Lisp_Object lisp_floats_consed
;
2908 Lisp_Object lisp_vector_cells_consed
;
2909 Lisp_Object lisp_symbols_consed
;
2910 Lisp_Object lisp_string_chars_consed
;
2911 Lisp_Object lisp_misc_objects_consed
;
2912 Lisp_Object lisp_intervals_consed
;
2914 XSETINT (lisp_cons_cells_consed
,
2915 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2916 XSETINT (lisp_floats_consed
,
2917 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2918 XSETINT (lisp_vector_cells_consed
,
2919 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2920 XSETINT (lisp_symbols_consed
,
2921 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2922 XSETINT (lisp_string_chars_consed
,
2923 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2924 XSETINT (lisp_misc_objects_consed
,
2925 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2926 XSETINT (lisp_intervals_consed
,
2927 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2929 return Fcons (lisp_cons_cells_consed
,
2930 Fcons (lisp_floats_consed
,
2931 Fcons (lisp_vector_cells_consed
,
2932 Fcons (lisp_symbols_consed
,
2933 Fcons (lisp_string_chars_consed
,
2934 Fcons (lisp_misc_objects_consed
,
2935 Fcons (lisp_intervals_consed
,
2939 /* Initialization */
2944 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2947 pure_size
= PURESIZE
;
2950 ignore_warnings
= 1;
2951 #ifdef DOUG_LEA_MALLOC
2952 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
2953 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
2954 mallopt (M_MMAP_MAX
, 64); /* max. number of mmap'ed areas */
2960 #ifdef LISP_FLOAT_TYPE
2962 #endif /* LISP_FLOAT_TYPE */
2966 malloc_hysteresis
= 32;
2968 malloc_hysteresis
= 0;
2971 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2973 ignore_warnings
= 0;
2976 consing_since_gc
= 0;
2977 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
2978 #ifdef VIRT_ADDR_VARIES
2979 malloc_sbrk_unused
= 1<<22; /* A large number */
2980 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2981 #endif /* VIRT_ADDR_VARIES */
2993 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2994 "*Number of bytes of consing between garbage collections.\n\
2995 Garbage collection can happen automatically once this many bytes have been\n\
2996 allocated since the last garbage collection. All data types count.\n\n\
2997 Garbage collection happens automatically only when `eval' is called.\n\n\
2998 By binding this temporarily to a large number, you can effectively\n\
2999 prevent garbage collection during a part of the program.");
3001 DEFVAR_INT ("pure-bytes-used", &pureptr
,
3002 "Number of bytes of sharable Lisp data allocated so far.");
3004 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
3005 "Number of cons cells that have been consed so far.");
3007 DEFVAR_INT ("floats-consed", &floats_consed
,
3008 "Number of floats that have been consed so far.");
3010 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
3011 "Number of vector cells that have been consed so far.");
3013 DEFVAR_INT ("symbols-consed", &symbols_consed
,
3014 "Number of symbols that have been consed so far.");
3016 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
3017 "Number of string characters that have been consed so far.");
3019 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
3020 "Number of miscellaneous objects that have been consed so far.");
3022 DEFVAR_INT ("intervals-consed", &intervals_consed
,
3023 "Number of intervals that have been consed so far.");
3026 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
3027 "Number of bytes of unshared memory allocated in this session.");
3029 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
3030 "Number of bytes of unshared memory remaining available in this session.");
3033 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
3034 "Non-nil means loading Lisp code in order to dump an executable.\n\
3035 This means that certain objects should be allocated in shared (pure) space.");
3037 DEFVAR_INT ("undo-limit", &undo_limit
,
3038 "Keep no more undo information once it exceeds this size.\n\
3039 This limit is applied when garbage collection happens.\n\
3040 The size is counted as the number of bytes occupied,\n\
3041 which includes both saved text and other data.");
3044 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
3045 "Don't keep more than this much size of undo information.\n\
3046 A command which pushes past this size is itself forgotten.\n\
3047 This limit is applied when garbage collection happens.\n\
3048 The size is counted as the number of bytes occupied,\n\
3049 which includes both saved text and other data.");
3050 undo_strong_limit
= 30000;
3052 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
3053 "Non-nil means display messages at start and end of garbage collection.");
3054 garbage_collection_messages
= 0;
3056 /* We build this in advance because if we wait until we need it, we might
3057 not be able to allocate the memory to hold it. */
3059 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
3060 staticpro (&memory_signal_data
);
3062 staticpro (&Qgc_cons_threshold
);
3063 Qgc_cons_threshold
= intern ("gc-cons-threshold");
3065 staticpro (&Qchar_table_extra_slots
);
3066 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
3071 defsubr (&Smake_byte_code
);
3072 defsubr (&Smake_list
);
3073 defsubr (&Smake_vector
);
3074 defsubr (&Smake_char_table
);
3075 defsubr (&Smake_string
);
3076 defsubr (&Smake_bool_vector
);
3077 defsubr (&Smake_symbol
);
3078 defsubr (&Smake_marker
);
3079 defsubr (&Spurecopy
);
3080 defsubr (&Sgarbage_collect
);
3081 defsubr (&Smemory_limit
);
3082 defsubr (&Smemory_use_counts
);