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
= ((XFASTINT (length
) + BITS_PER_CHAR
- 1) / BITS_PER_CHAR
);
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
;
1254 /* Clear the extraneous bits in the last byte. */
1255 if (XINT (length
) != length_in_chars
* BITS_PER_CHAR
)
1256 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
1257 &= (1 << (XINT (length
) % BITS_PER_CHAR
)) - 1;
1262 /* Make a string from NBYTES bytes at CONTENTS,
1263 and compute the number of characters from the contents.
1264 This string may be unibyte or multibyte, depending on the contents. */
1267 make_string (contents
, nbytes
)
1271 register Lisp_Object val
;
1272 int nchars
= chars_in_text (contents
, nbytes
);
1273 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1274 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1275 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1276 SET_STRING_BYTES (XSTRING (val
), -1);
1280 /* Make a unibyte string from LENGTH bytes at CONTENTS. */
1283 make_unibyte_string (contents
, length
)
1287 register Lisp_Object val
;
1288 val
= make_uninit_string (length
);
1289 bcopy (contents
, XSTRING (val
)->data
, length
);
1290 SET_STRING_BYTES (XSTRING (val
), -1);
1294 /* Make a multibyte string from NCHARS characters
1295 occupying NBYTES bytes at CONTENTS. */
1298 make_multibyte_string (contents
, nchars
, nbytes
)
1302 register Lisp_Object val
;
1303 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1304 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1308 /* Make a string from NCHARS characters
1309 occupying NBYTES bytes at CONTENTS.
1310 It is a multibyte string if NBYTES != NCHARS. */
1313 make_string_from_bytes (contents
, nchars
, nbytes
)
1317 register Lisp_Object val
;
1318 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1319 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1320 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1321 SET_STRING_BYTES (XSTRING (val
), -1);
1325 /* Make a multibyte string from NCHARS characters
1326 occupying NBYTES bytes at CONTENTS. */
1329 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
1334 register Lisp_Object val
;
1335 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1336 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1338 SET_STRING_BYTES (XSTRING (val
), -1);
1342 /* Make a string from the data at STR,
1343 treating it as multibyte if the data warrants. */
1349 return make_string (str
, strlen (str
));
1353 make_uninit_string (length
)
1357 val
= make_uninit_multibyte_string (length
, length
);
1358 SET_STRING_BYTES (XSTRING (val
), -1);
1363 make_uninit_multibyte_string (length
, length_byte
)
1364 int length
, length_byte
;
1366 register Lisp_Object val
;
1367 register int fullsize
= STRING_FULLSIZE (length_byte
);
1369 if (length
< 0) abort ();
1371 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1372 /* This string can fit in the current string block */
1375 ((struct Lisp_String
*)
1376 (current_string_block
->chars
+ current_string_block
->pos
)));
1377 current_string_block
->pos
+= fullsize
;
1379 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1380 /* This string gets its own string block */
1382 register struct string_block
*new;
1383 allocating_for_lisp
= 1;
1384 #ifdef DOUG_LEA_MALLOC
1385 /* Prevent mmap'ing the chunk (which is potentially very large). */
1386 mallopt (M_MMAP_MAX
, 0);
1388 new = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
1389 #ifdef DOUG_LEA_MALLOC
1390 /* Back to a reasonable maximum of mmap'ed areas. */
1391 mallopt (M_MMAP_MAX
, 64);
1393 allocating_for_lisp
= 0;
1394 VALIDATE_LISP_STORAGE (new, 0);
1395 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1396 new->pos
= fullsize
;
1397 new->next
= large_string_blocks
;
1398 large_string_blocks
= new;
1400 ((struct Lisp_String
*)
1401 ((struct string_block_head
*)new + 1)));
1404 /* Make a new current string block and start it off with this string */
1406 register struct string_block
*new;
1407 allocating_for_lisp
= 1;
1408 new = (struct string_block
*) xmalloc (sizeof (struct string_block
));
1409 allocating_for_lisp
= 0;
1410 VALIDATE_LISP_STORAGE (new, sizeof *new);
1411 consing_since_gc
+= sizeof (struct string_block
);
1412 current_string_block
->next
= new;
1413 new->prev
= current_string_block
;
1415 current_string_block
= new;
1416 new->pos
= fullsize
;
1418 (struct Lisp_String
*) current_string_block
->chars
);
1421 string_chars_consed
+= fullsize
;
1422 XSTRING (val
)->size
= length
;
1423 SET_STRING_BYTES (XSTRING (val
), length_byte
);
1424 XSTRING (val
)->data
[length_byte
] = 0;
1425 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1430 /* Return a newly created vector or string with specified arguments as
1431 elements. If all the arguments are characters that can fit
1432 in a string of events, make a string; otherwise, make a vector.
1434 Any number of arguments, even zero arguments, are allowed. */
1437 make_event_array (nargs
, args
)
1443 for (i
= 0; i
< nargs
; i
++)
1444 /* The things that fit in a string
1445 are characters that are in 0...127,
1446 after discarding the meta bit and all the bits above it. */
1447 if (!INTEGERP (args
[i
])
1448 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1449 return Fvector (nargs
, args
);
1451 /* Since the loop exited, we know that all the things in it are
1452 characters, so we can make a string. */
1456 result
= Fmake_string (make_number (nargs
), make_number (0));
1457 for (i
= 0; i
< nargs
; i
++)
1459 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1460 /* Move the meta bit to the right place for a string char. */
1461 if (XINT (args
[i
]) & CHAR_META
)
1462 XSTRING (result
)->data
[i
] |= 0x80;
1469 /* Pure storage management. */
1471 /* Must get an error if pure storage is full,
1472 since if it cannot hold a large string
1473 it may be able to hold conses that point to that string;
1474 then the string is not protected from gc. */
1477 make_pure_string (data
, length
, length_byte
, multibyte
)
1484 register Lisp_Object
new;
1485 register int size
= STRING_FULLSIZE (length_byte
);
1487 if (pureptr
+ size
> PURESIZE
)
1488 error ("Pure Lisp storage exhausted");
1489 XSETSTRING (new, PUREBEG
+ pureptr
);
1490 XSTRING (new)->size
= length
;
1491 SET_STRING_BYTES (XSTRING (new), (multibyte
? length_byte
: -1));
1492 bcopy (data
, XSTRING (new)->data
, length_byte
);
1493 XSTRING (new)->data
[length_byte
] = 0;
1495 /* We must give strings in pure storage some kind of interval. So we
1496 give them a null one. */
1497 #if defined (USE_TEXT_PROPERTIES)
1498 XSTRING (new)->intervals
= NULL_INTERVAL
;
1505 pure_cons (car
, cdr
)
1506 Lisp_Object car
, cdr
;
1508 register Lisp_Object
new;
1510 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1511 error ("Pure Lisp storage exhausted");
1512 XSETCONS (new, PUREBEG
+ pureptr
);
1513 pureptr
+= sizeof (struct Lisp_Cons
);
1514 XCONS (new)->car
= Fpurecopy (car
);
1515 XCONS (new)->cdr
= Fpurecopy (cdr
);
1519 #ifdef LISP_FLOAT_TYPE
1522 make_pure_float (num
)
1525 register Lisp_Object
new;
1527 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1528 (double) boundary. Some architectures (like the sparc) require
1529 this, and I suspect that floats are rare enough that it's no
1530 tragedy for those that do. */
1533 char *p
= PUREBEG
+ pureptr
;
1537 alignment
= __alignof (struct Lisp_Float
);
1539 alignment
= sizeof (struct Lisp_Float
);
1542 alignment
= sizeof (struct Lisp_Float
);
1544 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1545 pureptr
= p
- PUREBEG
;
1548 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1549 error ("Pure Lisp storage exhausted");
1550 XSETFLOAT (new, PUREBEG
+ pureptr
);
1551 pureptr
+= sizeof (struct Lisp_Float
);
1552 XFLOAT (new)->data
= num
;
1553 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1557 #endif /* LISP_FLOAT_TYPE */
1560 make_pure_vector (len
)
1563 register Lisp_Object
new;
1564 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1566 if (pureptr
+ size
> PURESIZE
)
1567 error ("Pure Lisp storage exhausted");
1569 XSETVECTOR (new, PUREBEG
+ pureptr
);
1571 XVECTOR (new)->size
= len
;
1575 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1576 "Make a copy of OBJECT in pure storage.\n\
1577 Recursively copies contents of vectors and cons cells.\n\
1578 Does not copy symbols.")
1580 register Lisp_Object obj
;
1582 if (NILP (Vpurify_flag
))
1585 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1586 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1590 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1591 #ifdef LISP_FLOAT_TYPE
1592 else if (FLOATP (obj
))
1593 return make_pure_float (XFLOAT (obj
)->data
);
1594 #endif /* LISP_FLOAT_TYPE */
1595 else if (STRINGP (obj
))
1596 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
1597 STRING_BYTES (XSTRING (obj
)),
1598 STRING_MULTIBYTE (obj
));
1599 else if (COMPILEDP (obj
) || VECTORP (obj
))
1601 register struct Lisp_Vector
*vec
;
1602 register int i
, size
;
1604 size
= XVECTOR (obj
)->size
;
1605 if (size
& PSEUDOVECTOR_FLAG
)
1606 size
&= PSEUDOVECTOR_SIZE_MASK
;
1607 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
1608 for (i
= 0; i
< size
; i
++)
1609 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1610 if (COMPILEDP (obj
))
1611 XSETCOMPILED (obj
, vec
);
1613 XSETVECTOR (obj
, vec
);
1616 else if (MARKERP (obj
))
1617 error ("Attempt to copy a marker to pure storage");
1622 /* Recording what needs to be marked for gc. */
1624 struct gcpro
*gcprolist
;
1626 #define NSTATICS 768
1628 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1632 /* Put an entry in staticvec, pointing at the variable whose address is given */
1635 staticpro (varaddress
)
1636 Lisp_Object
*varaddress
;
1638 staticvec
[staticidx
++] = varaddress
;
1639 if (staticidx
>= NSTATICS
)
1647 struct catchtag
*next
;
1648 #if 0 /* We don't need this for GC purposes */
1655 struct backtrace
*next
;
1656 Lisp_Object
*function
;
1657 Lisp_Object
*args
; /* Points to vector of args. */
1658 int nargs
; /* length of vector */
1659 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1663 /* Garbage collection! */
1665 /* Temporarily prevent garbage collection. */
1668 inhibit_garbage_collection ()
1670 int count
= specpdl_ptr
- specpdl
;
1672 int nbits
= min (VALBITS
, BITS_PER_INT
);
1674 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1676 specbind (Qgc_cons_threshold
, number
);
1681 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1682 "Reclaim storage for Lisp objects no longer needed.\n\
1683 Returns info on amount of space in use:\n\
1684 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1685 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1686 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS))\n\
1687 Garbage collection happens automatically if you cons more than\n\
1688 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1691 register struct gcpro
*tail
;
1692 register struct specbinding
*bind
;
1693 struct catchtag
*catch;
1694 struct handler
*handler
;
1695 register struct backtrace
*backlist
;
1696 register Lisp_Object tem
;
1697 char *omessage
= echo_area_glyphs
;
1698 int omessage_length
= echo_area_glyphs_length
;
1699 int oldmultibyte
= message_enable_multibyte
;
1700 char stack_top_variable
;
1703 /* In case user calls debug_print during GC,
1704 don't let that cause a recursive GC. */
1705 consing_since_gc
= 0;
1707 /* Save a copy of the contents of the stack, for debugging. */
1708 #if MAX_SAVE_STACK > 0
1709 if (NILP (Vpurify_flag
))
1711 i
= &stack_top_variable
- stack_bottom
;
1713 if (i
< MAX_SAVE_STACK
)
1715 if (stack_copy
== 0)
1716 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1717 else if (stack_copy_size
< i
)
1718 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1721 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1722 bcopy (stack_bottom
, stack_copy
, i
);
1724 bcopy (&stack_top_variable
, stack_copy
, i
);
1728 #endif /* MAX_SAVE_STACK > 0 */
1730 if (garbage_collection_messages
)
1731 message1_nolog ("Garbage collecting...");
1733 shrink_regexp_cache ();
1735 /* Don't keep undo information around forever. */
1737 register struct buffer
*nextb
= all_buffers
;
1741 /* If a buffer's undo list is Qt, that means that undo is
1742 turned off in that buffer. Calling truncate_undo_list on
1743 Qt tends to return NULL, which effectively turns undo back on.
1744 So don't call truncate_undo_list if undo_list is Qt. */
1745 if (! EQ (nextb
->undo_list
, Qt
))
1747 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1749 nextb
= nextb
->next
;
1755 /* clear_marks (); */
1757 /* In each "large string", set the MARKBIT of the size field.
1758 That enables mark_object to recognize them. */
1760 register struct string_block
*b
;
1761 for (b
= large_string_blocks
; b
; b
= b
->next
)
1762 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1765 /* Mark all the special slots that serve as the roots of accessibility.
1767 Usually the special slots to mark are contained in particular structures.
1768 Then we know no slot is marked twice because the structures don't overlap.
1769 In some cases, the structures point to the slots to be marked.
1770 For these, we use MARKBIT to avoid double marking of the slot. */
1772 for (i
= 0; i
< staticidx
; i
++)
1773 mark_object (staticvec
[i
]);
1774 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1775 for (i
= 0; i
< tail
->nvars
; i
++)
1776 if (!XMARKBIT (tail
->var
[i
]))
1778 mark_object (&tail
->var
[i
]);
1779 XMARK (tail
->var
[i
]);
1781 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1783 mark_object (&bind
->symbol
);
1784 mark_object (&bind
->old_value
);
1786 for (catch = catchlist
; catch; catch = catch->next
)
1788 mark_object (&catch->tag
);
1789 mark_object (&catch->val
);
1791 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1793 mark_object (&handler
->handler
);
1794 mark_object (&handler
->var
);
1796 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1798 if (!XMARKBIT (*backlist
->function
))
1800 mark_object (backlist
->function
);
1801 XMARK (*backlist
->function
);
1803 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1806 i
= backlist
->nargs
- 1;
1808 if (!XMARKBIT (backlist
->args
[i
]))
1810 mark_object (&backlist
->args
[i
]);
1811 XMARK (backlist
->args
[i
]);
1816 /* Look thru every buffer's undo list
1817 for elements that update markers that were not marked,
1820 register struct buffer
*nextb
= all_buffers
;
1824 /* If a buffer's undo list is Qt, that means that undo is
1825 turned off in that buffer. Calling truncate_undo_list on
1826 Qt tends to return NULL, which effectively turns undo back on.
1827 So don't call truncate_undo_list if undo_list is Qt. */
1828 if (! EQ (nextb
->undo_list
, Qt
))
1830 Lisp_Object tail
, prev
;
1831 tail
= nextb
->undo_list
;
1833 while (CONSP (tail
))
1835 if (GC_CONSP (XCONS (tail
)->car
)
1836 && GC_MARKERP (XCONS (XCONS (tail
)->car
)->car
)
1837 && ! XMARKBIT (XMARKER (XCONS (XCONS (tail
)->car
)->car
)->chain
))
1840 nextb
->undo_list
= tail
= XCONS (tail
)->cdr
;
1842 tail
= XCONS (prev
)->cdr
= XCONS (tail
)->cdr
;
1847 tail
= XCONS (tail
)->cdr
;
1852 nextb
= nextb
->next
;
1858 /* Clear the mark bits that we set in certain root slots. */
1860 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1861 for (i
= 0; i
< tail
->nvars
; i
++)
1862 XUNMARK (tail
->var
[i
]);
1863 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1865 XUNMARK (*backlist
->function
);
1866 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1869 i
= backlist
->nargs
- 1;
1871 XUNMARK (backlist
->args
[i
]);
1873 XUNMARK (buffer_defaults
.name
);
1874 XUNMARK (buffer_local_symbols
.name
);
1876 /* clear_marks (); */
1879 consing_since_gc
= 0;
1880 if (gc_cons_threshold
< 10000)
1881 gc_cons_threshold
= 10000;
1883 if (garbage_collection_messages
)
1885 if (omessage
|| minibuf_level
> 0)
1886 message2_nolog (omessage
, omessage_length
, oldmultibyte
);
1888 message1_nolog ("Garbage collecting...done");
1891 return Fcons (Fcons (make_number (total_conses
),
1892 make_number (total_free_conses
)),
1893 Fcons (Fcons (make_number (total_symbols
),
1894 make_number (total_free_symbols
)),
1895 Fcons (Fcons (make_number (total_markers
),
1896 make_number (total_free_markers
)),
1897 Fcons (make_number (total_string_size
),
1898 Fcons (make_number (total_vector_size
),
1900 #ifdef LISP_FLOAT_TYPE
1901 (make_number (total_floats
),
1902 make_number (total_free_floats
)),
1903 #else /* not LISP_FLOAT_TYPE */
1904 (make_number (0), make_number (0)),
1905 #endif /* not LISP_FLOAT_TYPE */
1907 #ifdef USE_TEXT_PROPERTIES
1908 (make_number (total_intervals
),
1909 make_number (total_free_intervals
)),
1910 #else /* not USE_TEXT_PROPERTIES */
1911 (make_number (0), make_number (0)),
1912 #endif /* not USE_TEXT_PROPERTIES */
1920 /* Clear marks on all conses */
1922 register struct cons_block
*cblk
;
1923 register int lim
= cons_block_index
;
1925 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1928 for (i
= 0; i
< lim
; i
++)
1929 XUNMARK (cblk
->conses
[i
].car
);
1930 lim
= CONS_BLOCK_SIZE
;
1933 /* Clear marks on all symbols */
1935 register struct symbol_block
*sblk
;
1936 register int lim
= symbol_block_index
;
1938 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1941 for (i
= 0; i
< lim
; i
++)
1943 XUNMARK (sblk
->symbols
[i
].plist
);
1945 lim
= SYMBOL_BLOCK_SIZE
;
1948 /* Clear marks on all markers */
1950 register struct marker_block
*sblk
;
1951 register int lim
= marker_block_index
;
1953 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1956 for (i
= 0; i
< lim
; i
++)
1957 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1958 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1959 lim
= MARKER_BLOCK_SIZE
;
1962 /* Clear mark bits on all buffers */
1964 register struct buffer
*nextb
= all_buffers
;
1968 XUNMARK (nextb
->name
);
1969 nextb
= nextb
->next
;
1975 /* Mark reference to a Lisp_Object.
1976 If the object referred to has not been seen yet, recursively mark
1977 all the references contained in it.
1979 If the object referenced is a short string, the referencing slot
1980 is threaded into a chain of such slots, pointed to from
1981 the `size' field of the string. The actual string size
1982 lives in the last slot in the chain. We recognize the end
1983 because it is < (unsigned) STRING_BLOCK_SIZE. */
1985 #define LAST_MARKED_SIZE 500
1986 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1987 int last_marked_index
;
1990 mark_object (argptr
)
1991 Lisp_Object
*argptr
;
1993 Lisp_Object
*objptr
= argptr
;
1994 register Lisp_Object obj
;
2001 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
2002 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
2005 last_marked
[last_marked_index
++] = objptr
;
2006 if (last_marked_index
== LAST_MARKED_SIZE
)
2007 last_marked_index
= 0;
2009 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
2013 register struct Lisp_String
*ptr
= XSTRING (obj
);
2015 MARK_INTERVAL_TREE (ptr
->intervals
);
2016 if (ptr
->size
& MARKBIT
)
2017 /* A large string. Just set ARRAY_MARK_FLAG. */
2018 ptr
->size
|= ARRAY_MARK_FLAG
;
2021 /* A small string. Put this reference
2022 into the chain of references to it.
2023 If the address includes MARKBIT, put that bit elsewhere
2024 when we store OBJPTR into the size field. */
2026 if (XMARKBIT (*objptr
))
2028 XSETFASTINT (*objptr
, ptr
->size
);
2032 XSETFASTINT (*objptr
, ptr
->size
);
2034 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
2036 ptr
->size
= (EMACS_INT
) objptr
;
2037 if (ptr
->size
& MARKBIT
)
2038 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
2043 case Lisp_Vectorlike
:
2044 if (GC_BUFFERP (obj
))
2046 if (!XMARKBIT (XBUFFER (obj
)->name
))
2049 else if (GC_SUBRP (obj
))
2051 else if (GC_COMPILEDP (obj
))
2052 /* We could treat this just like a vector, but it is better
2053 to save the COMPILED_CONSTANTS element for last and avoid recursion
2056 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2057 register EMACS_INT size
= ptr
->size
;
2058 /* See comment above under Lisp_Vector. */
2059 struct Lisp_Vector
*volatile ptr1
= ptr
;
2062 if (size
& ARRAY_MARK_FLAG
)
2063 break; /* Already marked */
2064 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2065 size
&= PSEUDOVECTOR_SIZE_MASK
;
2066 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2068 if (i
!= COMPILED_CONSTANTS
)
2069 mark_object (&ptr1
->contents
[i
]);
2071 /* This cast should be unnecessary, but some Mips compiler complains
2072 (MIPS-ABI + SysVR4, DC/OSx, etc). */
2073 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
2076 else if (GC_FRAMEP (obj
))
2078 /* See comment above under Lisp_Vector for why this is volatile. */
2079 register struct frame
*volatile ptr
= XFRAME (obj
);
2080 register EMACS_INT size
= ptr
->size
;
2082 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2083 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2085 mark_object (&ptr
->name
);
2086 mark_object (&ptr
->icon_name
);
2087 mark_object (&ptr
->title
);
2088 mark_object (&ptr
->focus_frame
);
2089 mark_object (&ptr
->selected_window
);
2090 mark_object (&ptr
->minibuffer_window
);
2091 mark_object (&ptr
->param_alist
);
2092 mark_object (&ptr
->scroll_bars
);
2093 mark_object (&ptr
->condemned_scroll_bars
);
2094 mark_object (&ptr
->menu_bar_items
);
2095 mark_object (&ptr
->face_alist
);
2096 mark_object (&ptr
->menu_bar_vector
);
2097 mark_object (&ptr
->buffer_predicate
);
2098 mark_object (&ptr
->buffer_list
);
2100 else if (GC_BOOL_VECTOR_P (obj
))
2102 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2104 if (ptr
->size
& ARRAY_MARK_FLAG
)
2105 break; /* Already marked */
2106 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2110 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2111 register EMACS_INT size
= ptr
->size
;
2112 /* The reason we use ptr1 is to avoid an apparent hardware bug
2113 that happens occasionally on the FSF's HP 300s.
2114 The bug is that a2 gets clobbered by recursive calls to mark_object.
2115 The clobberage seems to happen during function entry,
2116 perhaps in the moveml instruction.
2117 Yes, this is a crock, but we have to do it. */
2118 struct Lisp_Vector
*volatile ptr1
= ptr
;
2121 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2122 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2123 if (size
& PSEUDOVECTOR_FLAG
)
2124 size
&= PSEUDOVECTOR_SIZE_MASK
;
2125 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2126 mark_object (&ptr1
->contents
[i
]);
2132 /* See comment above under Lisp_Vector for why this is volatile. */
2133 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
2134 struct Lisp_Symbol
*ptrx
;
2136 if (XMARKBIT (ptr
->plist
)) break;
2138 mark_object ((Lisp_Object
*) &ptr
->value
);
2139 mark_object (&ptr
->function
);
2140 mark_object (&ptr
->plist
);
2141 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
2142 mark_object (&ptr
->name
);
2143 /* Note that we do not mark the obarray of the symbol.
2144 It is safe not to do so because nothing accesses that
2145 slot except to check whether it is nil. */
2149 /* For the benefit of the last_marked log. */
2150 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
2151 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
2152 XSETSYMBOL (obj
, ptrx
);
2153 /* We can't goto loop here because *objptr doesn't contain an
2154 actual Lisp_Object with valid datatype field. */
2161 switch (XMISCTYPE (obj
))
2163 case Lisp_Misc_Marker
:
2164 XMARK (XMARKER (obj
)->chain
);
2165 /* DO NOT mark thru the marker's chain.
2166 The buffer's markers chain does not preserve markers from gc;
2167 instead, markers are removed from the chain when freed by gc. */
2170 case Lisp_Misc_Buffer_Local_Value
:
2171 case Lisp_Misc_Some_Buffer_Local_Value
:
2173 register struct Lisp_Buffer_Local_Value
*ptr
2174 = XBUFFER_LOCAL_VALUE (obj
);
2175 if (XMARKBIT (ptr
->realvalue
)) break;
2176 XMARK (ptr
->realvalue
);
2177 /* If the cdr is nil, avoid recursion for the car. */
2178 if (EQ (ptr
->cdr
, Qnil
))
2180 objptr
= &ptr
->realvalue
;
2183 mark_object (&ptr
->realvalue
);
2184 mark_object (&ptr
->buffer
);
2185 mark_object (&ptr
->frame
);
2186 /* See comment above under Lisp_Vector for why not use ptr here. */
2187 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
2191 case Lisp_Misc_Intfwd
:
2192 case Lisp_Misc_Boolfwd
:
2193 case Lisp_Misc_Objfwd
:
2194 case Lisp_Misc_Buffer_Objfwd
:
2195 case Lisp_Misc_Kboard_Objfwd
:
2196 /* Don't bother with Lisp_Buffer_Objfwd,
2197 since all markable slots in current buffer marked anyway. */
2198 /* Don't need to do Lisp_Objfwd, since the places they point
2199 are protected with staticpro. */
2202 case Lisp_Misc_Overlay
:
2204 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
2205 if (!XMARKBIT (ptr
->plist
))
2208 mark_object (&ptr
->start
);
2209 mark_object (&ptr
->end
);
2210 objptr
= &ptr
->plist
;
2223 register struct Lisp_Cons
*ptr
= XCONS (obj
);
2224 if (XMARKBIT (ptr
->car
)) break;
2226 /* If the cdr is nil, avoid recursion for the car. */
2227 if (EQ (ptr
->cdr
, Qnil
))
2232 mark_object (&ptr
->car
);
2233 /* See comment above under Lisp_Vector for why not use ptr here. */
2234 objptr
= &XCONS (obj
)->cdr
;
2238 #ifdef LISP_FLOAT_TYPE
2240 XMARK (XFLOAT (obj
)->type
);
2242 #endif /* LISP_FLOAT_TYPE */
2252 /* Mark the pointers in a buffer structure. */
2258 register struct buffer
*buffer
= XBUFFER (buf
);
2259 register Lisp_Object
*ptr
;
2260 Lisp_Object base_buffer
;
2262 /* This is the buffer's markbit */
2263 mark_object (&buffer
->name
);
2264 XMARK (buffer
->name
);
2266 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
2268 if (CONSP (buffer
->undo_list
))
2271 tail
= buffer
->undo_list
;
2273 while (CONSP (tail
))
2275 register struct Lisp_Cons
*ptr
= XCONS (tail
);
2277 if (XMARKBIT (ptr
->car
))
2280 if (GC_CONSP (ptr
->car
)
2281 && ! XMARKBIT (XCONS (ptr
->car
)->car
)
2282 && GC_MARKERP (XCONS (ptr
->car
)->car
))
2284 XMARK (XCONS (ptr
->car
)->car
);
2285 mark_object (&XCONS (ptr
->car
)->cdr
);
2288 mark_object (&ptr
->car
);
2290 if (CONSP (ptr
->cdr
))
2296 mark_object (&XCONS (tail
)->cdr
);
2299 mark_object (&buffer
->undo_list
);
2302 mark_object (buffer
->syntax_table
);
2304 /* Mark the various string-pointers in the buffer object.
2305 Since the strings may be relocated, we must mark them
2306 in their actual slots. So gc_sweep must convert each slot
2307 back to an ordinary C pointer. */
2308 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
2309 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
2310 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
2311 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
2313 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
2314 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
2315 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
2316 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
2319 for (ptr
= &buffer
->name
+ 1;
2320 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
2324 /* If this is an indirect buffer, mark its base buffer. */
2325 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
2327 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2328 mark_buffer (base_buffer
);
2333 /* Mark the pointers in the kboard objects. */
2340 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2342 if (kb
->kbd_macro_buffer
)
2343 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2345 mark_object (&kb
->Voverriding_terminal_local_map
);
2346 mark_object (&kb
->Vlast_command
);
2347 mark_object (&kb
->Vreal_last_command
);
2348 mark_object (&kb
->Vprefix_arg
);
2349 mark_object (&kb
->Vlast_prefix_arg
);
2350 mark_object (&kb
->kbd_queue
);
2351 mark_object (&kb
->defining_kbd_macro
);
2352 mark_object (&kb
->Vlast_kbd_macro
);
2353 mark_object (&kb
->Vsystem_key_alist
);
2354 mark_object (&kb
->system_key_syms
);
2355 mark_object (&kb
->Vdefault_minibuffer_frame
);
2359 /* Sweep: find all structures not marked, and free them. */
2364 total_string_size
= 0;
2367 /* Put all unmarked conses on free list */
2369 register struct cons_block
*cblk
;
2370 struct cons_block
**cprev
= &cons_block
;
2371 register int lim
= cons_block_index
;
2372 register int num_free
= 0, num_used
= 0;
2376 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
2380 for (i
= 0; i
< lim
; i
++)
2381 if (!XMARKBIT (cblk
->conses
[i
].car
))
2384 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
2385 cons_free_list
= &cblk
->conses
[i
];
2390 XUNMARK (cblk
->conses
[i
].car
);
2392 lim
= CONS_BLOCK_SIZE
;
2393 /* If this block contains only free conses and we have already
2394 seen more than two blocks worth of free conses then deallocate
2396 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
2398 *cprev
= cblk
->next
;
2399 /* Unhook from the free list. */
2400 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
2405 num_free
+= this_free
;
2406 cprev
= &cblk
->next
;
2409 total_conses
= num_used
;
2410 total_free_conses
= num_free
;
2413 #ifdef LISP_FLOAT_TYPE
2414 /* Put all unmarked floats on free list */
2416 register struct float_block
*fblk
;
2417 struct float_block
**fprev
= &float_block
;
2418 register int lim
= float_block_index
;
2419 register int num_free
= 0, num_used
= 0;
2421 float_free_list
= 0;
2423 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
2427 for (i
= 0; i
< lim
; i
++)
2428 if (!XMARKBIT (fblk
->floats
[i
].type
))
2431 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
2432 float_free_list
= &fblk
->floats
[i
];
2437 XUNMARK (fblk
->floats
[i
].type
);
2439 lim
= FLOAT_BLOCK_SIZE
;
2440 /* If this block contains only free floats and we have already
2441 seen more than two blocks worth of free floats then deallocate
2443 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
2445 *fprev
= fblk
->next
;
2446 /* Unhook from the free list. */
2447 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
2452 num_free
+= this_free
;
2453 fprev
= &fblk
->next
;
2456 total_floats
= num_used
;
2457 total_free_floats
= num_free
;
2459 #endif /* LISP_FLOAT_TYPE */
2461 #ifdef USE_TEXT_PROPERTIES
2462 /* Put all unmarked intervals on free list */
2464 register struct interval_block
*iblk
;
2465 struct interval_block
**iprev
= &interval_block
;
2466 register int lim
= interval_block_index
;
2467 register int num_free
= 0, num_used
= 0;
2469 interval_free_list
= 0;
2471 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
2476 for (i
= 0; i
< lim
; i
++)
2478 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2480 iblk
->intervals
[i
].parent
= interval_free_list
;
2481 interval_free_list
= &iblk
->intervals
[i
];
2487 XUNMARK (iblk
->intervals
[i
].plist
);
2490 lim
= INTERVAL_BLOCK_SIZE
;
2491 /* If this block contains only free intervals and we have already
2492 seen more than two blocks worth of free intervals then
2493 deallocate this block. */
2494 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
2496 *iprev
= iblk
->next
;
2497 /* Unhook from the free list. */
2498 interval_free_list
= iblk
->intervals
[0].parent
;
2503 num_free
+= this_free
;
2504 iprev
= &iblk
->next
;
2507 total_intervals
= num_used
;
2508 total_free_intervals
= num_free
;
2510 #endif /* USE_TEXT_PROPERTIES */
2512 /* Put all unmarked symbols on free list */
2514 register struct symbol_block
*sblk
;
2515 struct symbol_block
**sprev
= &symbol_block
;
2516 register int lim
= symbol_block_index
;
2517 register int num_free
= 0, num_used
= 0;
2519 symbol_free_list
= 0;
2521 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
2525 for (i
= 0; i
< lim
; i
++)
2526 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2528 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2529 symbol_free_list
= &sblk
->symbols
[i
];
2535 sblk
->symbols
[i
].name
2536 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2537 XUNMARK (sblk
->symbols
[i
].plist
);
2539 lim
= SYMBOL_BLOCK_SIZE
;
2540 /* If this block contains only free symbols and we have already
2541 seen more than two blocks worth of free symbols then deallocate
2543 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
2545 *sprev
= sblk
->next
;
2546 /* Unhook from the free list. */
2547 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
2552 num_free
+= this_free
;
2553 sprev
= &sblk
->next
;
2556 total_symbols
= num_used
;
2557 total_free_symbols
= num_free
;
2561 /* Put all unmarked misc's on free list.
2562 For a marker, first unchain it from the buffer it points into. */
2564 register struct marker_block
*mblk
;
2565 struct marker_block
**mprev
= &marker_block
;
2566 register int lim
= marker_block_index
;
2567 register int num_free
= 0, num_used
= 0;
2569 marker_free_list
= 0;
2571 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
2575 EMACS_INT already_free
= -1;
2577 for (i
= 0; i
< lim
; i
++)
2579 Lisp_Object
*markword
;
2580 switch (mblk
->markers
[i
].u_marker
.type
)
2582 case Lisp_Misc_Marker
:
2583 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2585 case Lisp_Misc_Buffer_Local_Value
:
2586 case Lisp_Misc_Some_Buffer_Local_Value
:
2587 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
2589 case Lisp_Misc_Overlay
:
2590 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2592 case Lisp_Misc_Free
:
2593 /* If the object was already free, keep it
2594 on the free list. */
2595 markword
= (Lisp_Object
*) &already_free
;
2601 if (markword
&& !XMARKBIT (*markword
))
2604 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2606 /* tem1 avoids Sun compiler bug */
2607 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2608 XSETMARKER (tem
, tem1
);
2609 unchain_marker (tem
);
2611 /* Set the type of the freed object to Lisp_Misc_Free.
2612 We could leave the type alone, since nobody checks it,
2613 but this might catch bugs faster. */
2614 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2615 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2616 marker_free_list
= &mblk
->markers
[i
];
2623 XUNMARK (*markword
);
2626 lim
= MARKER_BLOCK_SIZE
;
2627 /* If this block contains only free markers and we have already
2628 seen more than two blocks worth of free markers then deallocate
2630 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
2632 *mprev
= mblk
->next
;
2633 /* Unhook from the free list. */
2634 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
2639 num_free
+= this_free
;
2640 mprev
= &mblk
->next
;
2644 total_markers
= num_used
;
2645 total_free_markers
= num_free
;
2648 /* Free all unmarked buffers */
2650 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2653 if (!XMARKBIT (buffer
->name
))
2656 prev
->next
= buffer
->next
;
2658 all_buffers
= buffer
->next
;
2659 next
= buffer
->next
;
2665 XUNMARK (buffer
->name
);
2666 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2669 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2670 for purposes of marking and relocation.
2671 Turn them back into C pointers now. */
2672 buffer
->upcase_table
2673 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2674 buffer
->downcase_table
2675 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2677 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2678 buffer
->folding_sort_table
2679 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2682 prev
= buffer
, buffer
= buffer
->next
;
2686 #endif /* standalone */
2688 /* Free all unmarked vectors */
2690 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2691 total_vector_size
= 0;
2694 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2697 prev
->next
= vector
->next
;
2699 all_vectors
= vector
->next
;
2700 next
= vector
->next
;
2706 vector
->size
&= ~ARRAY_MARK_FLAG
;
2707 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2708 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2710 total_vector_size
+= vector
->size
;
2711 prev
= vector
, vector
= vector
->next
;
2715 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2717 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2718 struct Lisp_String
*s
;
2722 s
= (struct Lisp_String
*) &sb
->chars
[0];
2723 if (s
->size
& ARRAY_MARK_FLAG
)
2725 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2726 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2727 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2728 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2729 prev
= sb
, sb
= sb
->next
;
2734 prev
->next
= sb
->next
;
2736 large_string_blocks
= sb
->next
;
2745 /* Compactify strings, relocate references, and free empty string blocks. */
2750 /* String block of old strings we are scanning. */
2751 register struct string_block
*from_sb
;
2752 /* A preceding string block (or maybe the same one)
2753 where we are copying the still-live strings to. */
2754 register struct string_block
*to_sb
;
2758 to_sb
= first_string_block
;
2761 /* Scan each existing string block sequentially, string by string. */
2762 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2765 /* POS is the index of the next string in the block. */
2766 while (pos
< from_sb
->pos
)
2768 register struct Lisp_String
*nextstr
2769 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2771 register struct Lisp_String
*newaddr
;
2772 register EMACS_INT size
= nextstr
->size
;
2773 EMACS_INT size_byte
= nextstr
->size_byte
;
2775 /* NEXTSTR is the old address of the next string.
2776 Just skip it if it isn't marked. */
2777 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2779 /* It is marked, so its size field is really a chain of refs.
2780 Find the end of the chain, where the actual size lives. */
2781 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2783 if (size
& DONT_COPY_FLAG
)
2784 size
^= MARKBIT
| DONT_COPY_FLAG
;
2785 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2791 total_string_size
+= size_byte
;
2793 /* If it won't fit in TO_SB, close it out,
2794 and move to the next sb. Keep doing so until
2795 TO_SB reaches a large enough, empty enough string block.
2796 We know that TO_SB cannot advance past FROM_SB here
2797 since FROM_SB is large enough to contain this string.
2798 Any string blocks skipped here
2799 will be patched out and freed later. */
2800 while (to_pos
+ STRING_FULLSIZE (size_byte
)
2801 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2803 to_sb
->pos
= to_pos
;
2804 to_sb
= to_sb
->next
;
2807 /* Compute new address of this string
2808 and update TO_POS for the space being used. */
2809 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2810 to_pos
+= STRING_FULLSIZE (size_byte
);
2812 /* Copy the string itself to the new place. */
2813 if (nextstr
!= newaddr
)
2814 bcopy (nextstr
, newaddr
, STRING_FULLSIZE (size_byte
));
2816 /* Go through NEXTSTR's chain of references
2817 and make each slot in the chain point to
2818 the new address of this string. */
2819 size
= newaddr
->size
;
2820 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2822 register Lisp_Object
*objptr
;
2823 if (size
& DONT_COPY_FLAG
)
2824 size
^= MARKBIT
| DONT_COPY_FLAG
;
2825 objptr
= (Lisp_Object
*)size
;
2827 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2828 if (XMARKBIT (*objptr
))
2830 XSETSTRING (*objptr
, newaddr
);
2834 XSETSTRING (*objptr
, newaddr
);
2836 /* Store the actual size in the size field. */
2837 newaddr
->size
= size
;
2839 #ifdef USE_TEXT_PROPERTIES
2840 /* Now that the string has been relocated, rebalance its
2841 interval tree, and update the tree's parent pointer. */
2842 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2844 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2845 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2848 #endif /* USE_TEXT_PROPERTIES */
2850 else if (size_byte
< 0)
2853 pos
+= STRING_FULLSIZE (size_byte
);
2857 /* Close out the last string block still used and free any that follow. */
2858 to_sb
->pos
= to_pos
;
2859 current_string_block
= to_sb
;
2861 from_sb
= to_sb
->next
;
2865 to_sb
= from_sb
->next
;
2870 /* Free any empty string blocks further back in the chain.
2871 This loop will never free first_string_block, but it is very
2872 unlikely that that one will become empty, so why bother checking? */
2874 from_sb
= first_string_block
;
2875 while (to_sb
= from_sb
->next
)
2877 if (to_sb
->pos
== 0)
2879 if (from_sb
->next
= to_sb
->next
)
2880 from_sb
->next
->prev
= from_sb
;
2888 /* Debugging aids. */
2890 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2891 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2892 This may be helpful in debugging Emacs's memory usage.\n\
2893 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2898 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2903 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2904 "Return a list of counters that measure how much consing there has been.\n\
2905 Each of these counters increments for a certain kind of object.\n\
2906 The counters wrap around from the largest positive integer to zero.\n\
2907 Garbage collection does not decrease them.\n\
2908 The elements of the value are as follows:\n\
2909 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2910 All are in units of 1 = one object consed\n\
2911 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2913 MISCS include overlays, markers, and some internal types.\n\
2914 Frames, windows, buffers, and subprocesses count as vectors\n\
2915 (but the contents of a buffer's text do not count here).")
2918 Lisp_Object lisp_cons_cells_consed
;
2919 Lisp_Object lisp_floats_consed
;
2920 Lisp_Object lisp_vector_cells_consed
;
2921 Lisp_Object lisp_symbols_consed
;
2922 Lisp_Object lisp_string_chars_consed
;
2923 Lisp_Object lisp_misc_objects_consed
;
2924 Lisp_Object lisp_intervals_consed
;
2926 XSETINT (lisp_cons_cells_consed
,
2927 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2928 XSETINT (lisp_floats_consed
,
2929 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2930 XSETINT (lisp_vector_cells_consed
,
2931 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2932 XSETINT (lisp_symbols_consed
,
2933 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2934 XSETINT (lisp_string_chars_consed
,
2935 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2936 XSETINT (lisp_misc_objects_consed
,
2937 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2938 XSETINT (lisp_intervals_consed
,
2939 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2941 return Fcons (lisp_cons_cells_consed
,
2942 Fcons (lisp_floats_consed
,
2943 Fcons (lisp_vector_cells_consed
,
2944 Fcons (lisp_symbols_consed
,
2945 Fcons (lisp_string_chars_consed
,
2946 Fcons (lisp_misc_objects_consed
,
2947 Fcons (lisp_intervals_consed
,
2951 /* Initialization */
2956 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2959 pure_size
= PURESIZE
;
2962 ignore_warnings
= 1;
2963 #ifdef DOUG_LEA_MALLOC
2964 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
2965 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
2966 mallopt (M_MMAP_MAX
, 64); /* max. number of mmap'ed areas */
2972 #ifdef LISP_FLOAT_TYPE
2974 #endif /* LISP_FLOAT_TYPE */
2978 malloc_hysteresis
= 32;
2980 malloc_hysteresis
= 0;
2983 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2985 ignore_warnings
= 0;
2988 consing_since_gc
= 0;
2989 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
2990 #ifdef VIRT_ADDR_VARIES
2991 malloc_sbrk_unused
= 1<<22; /* A large number */
2992 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2993 #endif /* VIRT_ADDR_VARIES */
3005 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
3006 "*Number of bytes of consing between garbage collections.\n\
3007 Garbage collection can happen automatically once this many bytes have been\n\
3008 allocated since the last garbage collection. All data types count.\n\n\
3009 Garbage collection happens automatically only when `eval' is called.\n\n\
3010 By binding this temporarily to a large number, you can effectively\n\
3011 prevent garbage collection during a part of the program.");
3013 DEFVAR_INT ("pure-bytes-used", &pureptr
,
3014 "Number of bytes of sharable Lisp data allocated so far.");
3016 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
3017 "Number of cons cells that have been consed so far.");
3019 DEFVAR_INT ("floats-consed", &floats_consed
,
3020 "Number of floats that have been consed so far.");
3022 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
3023 "Number of vector cells that have been consed so far.");
3025 DEFVAR_INT ("symbols-consed", &symbols_consed
,
3026 "Number of symbols that have been consed so far.");
3028 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
3029 "Number of string characters that have been consed so far.");
3031 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
3032 "Number of miscellaneous objects that have been consed so far.");
3034 DEFVAR_INT ("intervals-consed", &intervals_consed
,
3035 "Number of intervals that have been consed so far.");
3038 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
3039 "Number of bytes of unshared memory allocated in this session.");
3041 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
3042 "Number of bytes of unshared memory remaining available in this session.");
3045 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
3046 "Non-nil means loading Lisp code in order to dump an executable.\n\
3047 This means that certain objects should be allocated in shared (pure) space.");
3049 DEFVAR_INT ("undo-limit", &undo_limit
,
3050 "Keep no more undo information once it exceeds this size.\n\
3051 This limit is applied when garbage collection happens.\n\
3052 The size is counted as the number of bytes occupied,\n\
3053 which includes both saved text and other data.");
3056 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
3057 "Don't keep more than this much size of undo information.\n\
3058 A command which pushes past this size is itself forgotten.\n\
3059 This limit is applied when garbage collection happens.\n\
3060 The size is counted as the number of bytes occupied,\n\
3061 which includes both saved text and other data.");
3062 undo_strong_limit
= 30000;
3064 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
3065 "Non-nil means display messages at start and end of garbage collection.");
3066 garbage_collection_messages
= 0;
3068 /* We build this in advance because if we wait until we need it, we might
3069 not be able to allocate the memory to hold it. */
3071 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
3072 staticpro (&memory_signal_data
);
3074 staticpro (&Qgc_cons_threshold
);
3075 Qgc_cons_threshold
= intern ("gc-cons-threshold");
3077 staticpro (&Qchar_table_extra_slots
);
3078 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
3083 defsubr (&Smake_byte_code
);
3084 defsubr (&Smake_list
);
3085 defsubr (&Smake_vector
);
3086 defsubr (&Smake_char_table
);
3087 defsubr (&Smake_string
);
3088 defsubr (&Smake_bool_vector
);
3089 defsubr (&Smake_symbol
);
3090 defsubr (&Smake_marker
);
3091 defsubr (&Spurecopy
);
3092 defsubr (&Sgarbage_collect
);
3093 defsubr (&Smemory_limit
);
3094 defsubr (&Smemory_use_counts
);