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...");
1735 shrink_regexp_cache ();
1737 /* Don't keep undo information around forever. */
1739 register struct buffer
*nextb
= all_buffers
;
1743 /* If a buffer's undo list is Qt, that means that undo is
1744 turned off in that buffer. Calling truncate_undo_list on
1745 Qt tends to return NULL, which effectively turns undo back on.
1746 So don't call truncate_undo_list if undo_list is Qt. */
1747 if (! EQ (nextb
->undo_list
, Qt
))
1749 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1751 nextb
= nextb
->next
;
1757 /* clear_marks (); */
1759 /* In each "large string", set the MARKBIT of the size field.
1760 That enables mark_object to recognize them. */
1762 register struct string_block
*b
;
1763 for (b
= large_string_blocks
; b
; b
= b
->next
)
1764 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1767 /* Mark all the special slots that serve as the roots of accessibility.
1769 Usually the special slots to mark are contained in particular structures.
1770 Then we know no slot is marked twice because the structures don't overlap.
1771 In some cases, the structures point to the slots to be marked.
1772 For these, we use MARKBIT to avoid double marking of the slot. */
1774 for (i
= 0; i
< staticidx
; i
++)
1775 mark_object (staticvec
[i
]);
1776 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1777 for (i
= 0; i
< tail
->nvars
; i
++)
1778 if (!XMARKBIT (tail
->var
[i
]))
1780 mark_object (&tail
->var
[i
]);
1781 XMARK (tail
->var
[i
]);
1783 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1785 mark_object (&bind
->symbol
);
1786 mark_object (&bind
->old_value
);
1788 for (catch = catchlist
; catch; catch = catch->next
)
1790 mark_object (&catch->tag
);
1791 mark_object (&catch->val
);
1793 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1795 mark_object (&handler
->handler
);
1796 mark_object (&handler
->var
);
1798 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1800 if (!XMARKBIT (*backlist
->function
))
1802 mark_object (backlist
->function
);
1803 XMARK (*backlist
->function
);
1805 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1808 i
= backlist
->nargs
- 1;
1810 if (!XMARKBIT (backlist
->args
[i
]))
1812 mark_object (&backlist
->args
[i
]);
1813 XMARK (backlist
->args
[i
]);
1818 /* Look thru every buffer's undo list
1819 for elements that update markers that were not marked,
1822 register struct buffer
*nextb
= all_buffers
;
1826 /* If a buffer's undo list is Qt, that means that undo is
1827 turned off in that buffer. Calling truncate_undo_list on
1828 Qt tends to return NULL, which effectively turns undo back on.
1829 So don't call truncate_undo_list if undo_list is Qt. */
1830 if (! EQ (nextb
->undo_list
, Qt
))
1832 Lisp_Object tail
, prev
;
1833 tail
= nextb
->undo_list
;
1835 while (CONSP (tail
))
1837 if (GC_CONSP (XCONS (tail
)->car
)
1838 && GC_MARKERP (XCONS (XCONS (tail
)->car
)->car
)
1839 && ! XMARKBIT (XMARKER (XCONS (XCONS (tail
)->car
)->car
)->chain
))
1842 nextb
->undo_list
= tail
= XCONS (tail
)->cdr
;
1844 tail
= XCONS (prev
)->cdr
= XCONS (tail
)->cdr
;
1849 tail
= XCONS (tail
)->cdr
;
1854 nextb
= nextb
->next
;
1860 /* Clear the mark bits that we set in certain root slots. */
1862 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1863 for (i
= 0; i
< tail
->nvars
; i
++)
1864 XUNMARK (tail
->var
[i
]);
1865 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1867 XUNMARK (*backlist
->function
);
1868 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1871 i
= backlist
->nargs
- 1;
1873 XUNMARK (backlist
->args
[i
]);
1875 XUNMARK (buffer_defaults
.name
);
1876 XUNMARK (buffer_local_symbols
.name
);
1880 /* clear_marks (); */
1883 consing_since_gc
= 0;
1884 if (gc_cons_threshold
< 10000)
1885 gc_cons_threshold
= 10000;
1887 if (garbage_collection_messages
)
1889 if (omessage
|| minibuf_level
> 0)
1890 message2_nolog (omessage
, omessage_length
, oldmultibyte
);
1892 message1_nolog ("Garbage collecting...done");
1895 return Fcons (Fcons (make_number (total_conses
),
1896 make_number (total_free_conses
)),
1897 Fcons (Fcons (make_number (total_symbols
),
1898 make_number (total_free_symbols
)),
1899 Fcons (Fcons (make_number (total_markers
),
1900 make_number (total_free_markers
)),
1901 Fcons (make_number (total_string_size
),
1902 Fcons (make_number (total_vector_size
),
1904 #ifdef LISP_FLOAT_TYPE
1905 (make_number (total_floats
),
1906 make_number (total_free_floats
)),
1907 #else /* not LISP_FLOAT_TYPE */
1908 (make_number (0), make_number (0)),
1909 #endif /* not LISP_FLOAT_TYPE */
1911 #ifdef USE_TEXT_PROPERTIES
1912 (make_number (total_intervals
),
1913 make_number (total_free_intervals
)),
1914 #else /* not USE_TEXT_PROPERTIES */
1915 (make_number (0), make_number (0)),
1916 #endif /* not USE_TEXT_PROPERTIES */
1924 /* Clear marks on all conses */
1926 register struct cons_block
*cblk
;
1927 register int lim
= cons_block_index
;
1929 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1932 for (i
= 0; i
< lim
; i
++)
1933 XUNMARK (cblk
->conses
[i
].car
);
1934 lim
= CONS_BLOCK_SIZE
;
1937 /* Clear marks on all symbols */
1939 register struct symbol_block
*sblk
;
1940 register int lim
= symbol_block_index
;
1942 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1945 for (i
= 0; i
< lim
; i
++)
1947 XUNMARK (sblk
->symbols
[i
].plist
);
1949 lim
= SYMBOL_BLOCK_SIZE
;
1952 /* Clear marks on all markers */
1954 register struct marker_block
*sblk
;
1955 register int lim
= marker_block_index
;
1957 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1960 for (i
= 0; i
< lim
; i
++)
1961 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1962 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1963 lim
= MARKER_BLOCK_SIZE
;
1966 /* Clear mark bits on all buffers */
1968 register struct buffer
*nextb
= all_buffers
;
1972 XUNMARK (nextb
->name
);
1973 nextb
= nextb
->next
;
1979 /* Mark reference to a Lisp_Object.
1980 If the object referred to has not been seen yet, recursively mark
1981 all the references contained in it.
1983 If the object referenced is a short string, the referencing slot
1984 is threaded into a chain of such slots, pointed to from
1985 the `size' field of the string. The actual string size
1986 lives in the last slot in the chain. We recognize the end
1987 because it is < (unsigned) STRING_BLOCK_SIZE. */
1989 #define LAST_MARKED_SIZE 500
1990 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1991 int last_marked_index
;
1994 mark_object (argptr
)
1995 Lisp_Object
*argptr
;
1997 Lisp_Object
*objptr
= argptr
;
1998 register Lisp_Object obj
;
2005 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
2006 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
2009 last_marked
[last_marked_index
++] = objptr
;
2010 if (last_marked_index
== LAST_MARKED_SIZE
)
2011 last_marked_index
= 0;
2013 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
2017 register struct Lisp_String
*ptr
= XSTRING (obj
);
2019 MARK_INTERVAL_TREE (ptr
->intervals
);
2020 if (ptr
->size
& MARKBIT
)
2021 /* A large string. Just set ARRAY_MARK_FLAG. */
2022 ptr
->size
|= ARRAY_MARK_FLAG
;
2025 /* A small string. Put this reference
2026 into the chain of references to it.
2027 If the address includes MARKBIT, put that bit elsewhere
2028 when we store OBJPTR into the size field. */
2030 if (XMARKBIT (*objptr
))
2032 XSETFASTINT (*objptr
, ptr
->size
);
2036 XSETFASTINT (*objptr
, ptr
->size
);
2038 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
2040 ptr
->size
= (EMACS_INT
) objptr
;
2041 if (ptr
->size
& MARKBIT
)
2042 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
2047 case Lisp_Vectorlike
:
2048 if (GC_BUFFERP (obj
))
2050 if (!XMARKBIT (XBUFFER (obj
)->name
))
2053 else if (GC_SUBRP (obj
))
2055 else if (GC_COMPILEDP (obj
))
2056 /* We could treat this just like a vector, but it is better
2057 to save the COMPILED_CONSTANTS element for last and avoid recursion
2060 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2061 register EMACS_INT size
= ptr
->size
;
2062 /* See comment above under Lisp_Vector. */
2063 struct Lisp_Vector
*volatile ptr1
= ptr
;
2066 if (size
& ARRAY_MARK_FLAG
)
2067 break; /* Already marked */
2068 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2069 size
&= PSEUDOVECTOR_SIZE_MASK
;
2070 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2072 if (i
!= COMPILED_CONSTANTS
)
2073 mark_object (&ptr1
->contents
[i
]);
2075 /* This cast should be unnecessary, but some Mips compiler complains
2076 (MIPS-ABI + SysVR4, DC/OSx, etc). */
2077 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
2080 else if (GC_FRAMEP (obj
))
2082 /* See comment above under Lisp_Vector for why this is volatile. */
2083 register struct frame
*volatile ptr
= XFRAME (obj
);
2084 register EMACS_INT size
= ptr
->size
;
2086 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2087 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2089 mark_object (&ptr
->name
);
2090 mark_object (&ptr
->icon_name
);
2091 mark_object (&ptr
->title
);
2092 mark_object (&ptr
->focus_frame
);
2093 mark_object (&ptr
->selected_window
);
2094 mark_object (&ptr
->minibuffer_window
);
2095 mark_object (&ptr
->param_alist
);
2096 mark_object (&ptr
->scroll_bars
);
2097 mark_object (&ptr
->condemned_scroll_bars
);
2098 mark_object (&ptr
->menu_bar_items
);
2099 mark_object (&ptr
->face_alist
);
2100 mark_object (&ptr
->menu_bar_vector
);
2101 mark_object (&ptr
->buffer_predicate
);
2102 mark_object (&ptr
->buffer_list
);
2104 else if (GC_BOOL_VECTOR_P (obj
))
2106 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2108 if (ptr
->size
& ARRAY_MARK_FLAG
)
2109 break; /* Already marked */
2110 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2114 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2115 register EMACS_INT size
= ptr
->size
;
2116 /* The reason we use ptr1 is to avoid an apparent hardware bug
2117 that happens occasionally on the FSF's HP 300s.
2118 The bug is that a2 gets clobbered by recursive calls to mark_object.
2119 The clobberage seems to happen during function entry,
2120 perhaps in the moveml instruction.
2121 Yes, this is a crock, but we have to do it. */
2122 struct Lisp_Vector
*volatile ptr1
= ptr
;
2125 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2126 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2127 if (size
& PSEUDOVECTOR_FLAG
)
2128 size
&= PSEUDOVECTOR_SIZE_MASK
;
2129 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2130 mark_object (&ptr1
->contents
[i
]);
2136 /* See comment above under Lisp_Vector for why this is volatile. */
2137 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
2138 struct Lisp_Symbol
*ptrx
;
2140 if (XMARKBIT (ptr
->plist
)) break;
2142 mark_object ((Lisp_Object
*) &ptr
->value
);
2143 mark_object (&ptr
->function
);
2144 mark_object (&ptr
->plist
);
2145 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
2146 mark_object (&ptr
->name
);
2147 /* Note that we do not mark the obarray of the symbol.
2148 It is safe not to do so because nothing accesses that
2149 slot except to check whether it is nil. */
2153 /* For the benefit of the last_marked log. */
2154 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
2155 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
2156 XSETSYMBOL (obj
, ptrx
);
2157 /* We can't goto loop here because *objptr doesn't contain an
2158 actual Lisp_Object with valid datatype field. */
2165 switch (XMISCTYPE (obj
))
2167 case Lisp_Misc_Marker
:
2168 XMARK (XMARKER (obj
)->chain
);
2169 /* DO NOT mark thru the marker's chain.
2170 The buffer's markers chain does not preserve markers from gc;
2171 instead, markers are removed from the chain when freed by gc. */
2174 case Lisp_Misc_Buffer_Local_Value
:
2175 case Lisp_Misc_Some_Buffer_Local_Value
:
2177 register struct Lisp_Buffer_Local_Value
*ptr
2178 = XBUFFER_LOCAL_VALUE (obj
);
2179 if (XMARKBIT (ptr
->realvalue
)) break;
2180 XMARK (ptr
->realvalue
);
2181 /* If the cdr is nil, avoid recursion for the car. */
2182 if (EQ (ptr
->cdr
, Qnil
))
2184 objptr
= &ptr
->realvalue
;
2187 mark_object (&ptr
->realvalue
);
2188 mark_object (&ptr
->buffer
);
2189 mark_object (&ptr
->frame
);
2190 /* See comment above under Lisp_Vector for why not use ptr here. */
2191 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
2195 case Lisp_Misc_Intfwd
:
2196 case Lisp_Misc_Boolfwd
:
2197 case Lisp_Misc_Objfwd
:
2198 case Lisp_Misc_Buffer_Objfwd
:
2199 case Lisp_Misc_Kboard_Objfwd
:
2200 /* Don't bother with Lisp_Buffer_Objfwd,
2201 since all markable slots in current buffer marked anyway. */
2202 /* Don't need to do Lisp_Objfwd, since the places they point
2203 are protected with staticpro. */
2206 case Lisp_Misc_Overlay
:
2208 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
2209 if (!XMARKBIT (ptr
->plist
))
2212 mark_object (&ptr
->start
);
2213 mark_object (&ptr
->end
);
2214 objptr
= &ptr
->plist
;
2227 register struct Lisp_Cons
*ptr
= XCONS (obj
);
2228 if (XMARKBIT (ptr
->car
)) break;
2230 /* If the cdr is nil, avoid recursion for the car. */
2231 if (EQ (ptr
->cdr
, Qnil
))
2236 mark_object (&ptr
->car
);
2237 /* See comment above under Lisp_Vector for why not use ptr here. */
2238 objptr
= &XCONS (obj
)->cdr
;
2242 #ifdef LISP_FLOAT_TYPE
2244 XMARK (XFLOAT (obj
)->type
);
2246 #endif /* LISP_FLOAT_TYPE */
2256 /* Mark the pointers in a buffer structure. */
2262 register struct buffer
*buffer
= XBUFFER (buf
);
2263 register Lisp_Object
*ptr
;
2264 Lisp_Object base_buffer
;
2266 /* This is the buffer's markbit */
2267 mark_object (&buffer
->name
);
2268 XMARK (buffer
->name
);
2270 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
2272 if (CONSP (buffer
->undo_list
))
2275 tail
= buffer
->undo_list
;
2277 while (CONSP (tail
))
2279 register struct Lisp_Cons
*ptr
= XCONS (tail
);
2281 if (XMARKBIT (ptr
->car
))
2284 if (GC_CONSP (ptr
->car
)
2285 && ! XMARKBIT (XCONS (ptr
->car
)->car
)
2286 && GC_MARKERP (XCONS (ptr
->car
)->car
))
2288 XMARK (XCONS (ptr
->car
)->car
);
2289 mark_object (&XCONS (ptr
->car
)->cdr
);
2292 mark_object (&ptr
->car
);
2294 if (CONSP (ptr
->cdr
))
2300 mark_object (&XCONS (tail
)->cdr
);
2303 mark_object (&buffer
->undo_list
);
2306 mark_object (buffer
->syntax_table
);
2308 /* Mark the various string-pointers in the buffer object.
2309 Since the strings may be relocated, we must mark them
2310 in their actual slots. So gc_sweep must convert each slot
2311 back to an ordinary C pointer. */
2312 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
2313 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
2314 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
2315 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
2317 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
2318 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
2319 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
2320 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
2323 for (ptr
= &buffer
->name
+ 1;
2324 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
2328 /* If this is an indirect buffer, mark its base buffer. */
2329 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
2331 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2332 mark_buffer (base_buffer
);
2337 /* Mark the pointers in the kboard objects. */
2344 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2346 if (kb
->kbd_macro_buffer
)
2347 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2349 mark_object (&kb
->Voverriding_terminal_local_map
);
2350 mark_object (&kb
->Vlast_command
);
2351 mark_object (&kb
->Vreal_last_command
);
2352 mark_object (&kb
->Vprefix_arg
);
2353 mark_object (&kb
->Vlast_prefix_arg
);
2354 mark_object (&kb
->kbd_queue
);
2355 mark_object (&kb
->defining_kbd_macro
);
2356 mark_object (&kb
->Vlast_kbd_macro
);
2357 mark_object (&kb
->Vsystem_key_alist
);
2358 mark_object (&kb
->system_key_syms
);
2359 mark_object (&kb
->Vdefault_minibuffer_frame
);
2363 /* Sweep: find all structures not marked, and free them. */
2368 total_string_size
= 0;
2371 /* Put all unmarked conses on free list */
2373 register struct cons_block
*cblk
;
2374 struct cons_block
**cprev
= &cons_block
;
2375 register int lim
= cons_block_index
;
2376 register int num_free
= 0, num_used
= 0;
2380 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
2384 for (i
= 0; i
< lim
; i
++)
2385 if (!XMARKBIT (cblk
->conses
[i
].car
))
2388 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
2389 cons_free_list
= &cblk
->conses
[i
];
2394 XUNMARK (cblk
->conses
[i
].car
);
2396 lim
= CONS_BLOCK_SIZE
;
2397 /* If this block contains only free conses and we have already
2398 seen more than two blocks worth of free conses then deallocate
2400 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
2402 *cprev
= cblk
->next
;
2403 /* Unhook from the free list. */
2404 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
2409 num_free
+= this_free
;
2410 cprev
= &cblk
->next
;
2413 total_conses
= num_used
;
2414 total_free_conses
= num_free
;
2417 #ifdef LISP_FLOAT_TYPE
2418 /* Put all unmarked floats on free list */
2420 register struct float_block
*fblk
;
2421 struct float_block
**fprev
= &float_block
;
2422 register int lim
= float_block_index
;
2423 register int num_free
= 0, num_used
= 0;
2425 float_free_list
= 0;
2427 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
2431 for (i
= 0; i
< lim
; i
++)
2432 if (!XMARKBIT (fblk
->floats
[i
].type
))
2435 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
2436 float_free_list
= &fblk
->floats
[i
];
2441 XUNMARK (fblk
->floats
[i
].type
);
2443 lim
= FLOAT_BLOCK_SIZE
;
2444 /* If this block contains only free floats and we have already
2445 seen more than two blocks worth of free floats then deallocate
2447 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
2449 *fprev
= fblk
->next
;
2450 /* Unhook from the free list. */
2451 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
2456 num_free
+= this_free
;
2457 fprev
= &fblk
->next
;
2460 total_floats
= num_used
;
2461 total_free_floats
= num_free
;
2463 #endif /* LISP_FLOAT_TYPE */
2465 #ifdef USE_TEXT_PROPERTIES
2466 /* Put all unmarked intervals on free list */
2468 register struct interval_block
*iblk
;
2469 struct interval_block
**iprev
= &interval_block
;
2470 register int lim
= interval_block_index
;
2471 register int num_free
= 0, num_used
= 0;
2473 interval_free_list
= 0;
2475 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
2480 for (i
= 0; i
< lim
; i
++)
2482 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2484 iblk
->intervals
[i
].parent
= interval_free_list
;
2485 interval_free_list
= &iblk
->intervals
[i
];
2491 XUNMARK (iblk
->intervals
[i
].plist
);
2494 lim
= INTERVAL_BLOCK_SIZE
;
2495 /* If this block contains only free intervals and we have already
2496 seen more than two blocks worth of free intervals then
2497 deallocate this block. */
2498 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
2500 *iprev
= iblk
->next
;
2501 /* Unhook from the free list. */
2502 interval_free_list
= iblk
->intervals
[0].parent
;
2507 num_free
+= this_free
;
2508 iprev
= &iblk
->next
;
2511 total_intervals
= num_used
;
2512 total_free_intervals
= num_free
;
2514 #endif /* USE_TEXT_PROPERTIES */
2516 /* Put all unmarked symbols on free list */
2518 register struct symbol_block
*sblk
;
2519 struct symbol_block
**sprev
= &symbol_block
;
2520 register int lim
= symbol_block_index
;
2521 register int num_free
= 0, num_used
= 0;
2523 symbol_free_list
= 0;
2525 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
2529 for (i
= 0; i
< lim
; i
++)
2530 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2532 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2533 symbol_free_list
= &sblk
->symbols
[i
];
2539 sblk
->symbols
[i
].name
2540 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2541 XUNMARK (sblk
->symbols
[i
].plist
);
2543 lim
= SYMBOL_BLOCK_SIZE
;
2544 /* If this block contains only free symbols and we have already
2545 seen more than two blocks worth of free symbols then deallocate
2547 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
2549 *sprev
= sblk
->next
;
2550 /* Unhook from the free list. */
2551 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
2556 num_free
+= this_free
;
2557 sprev
= &sblk
->next
;
2560 total_symbols
= num_used
;
2561 total_free_symbols
= num_free
;
2565 /* Put all unmarked misc's on free list.
2566 For a marker, first unchain it from the buffer it points into. */
2568 register struct marker_block
*mblk
;
2569 struct marker_block
**mprev
= &marker_block
;
2570 register int lim
= marker_block_index
;
2571 register int num_free
= 0, num_used
= 0;
2573 marker_free_list
= 0;
2575 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
2579 EMACS_INT already_free
= -1;
2581 for (i
= 0; i
< lim
; i
++)
2583 Lisp_Object
*markword
;
2584 switch (mblk
->markers
[i
].u_marker
.type
)
2586 case Lisp_Misc_Marker
:
2587 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2589 case Lisp_Misc_Buffer_Local_Value
:
2590 case Lisp_Misc_Some_Buffer_Local_Value
:
2591 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
2593 case Lisp_Misc_Overlay
:
2594 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2596 case Lisp_Misc_Free
:
2597 /* If the object was already free, keep it
2598 on the free list. */
2599 markword
= (Lisp_Object
*) &already_free
;
2605 if (markword
&& !XMARKBIT (*markword
))
2608 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2610 /* tem1 avoids Sun compiler bug */
2611 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2612 XSETMARKER (tem
, tem1
);
2613 unchain_marker (tem
);
2615 /* Set the type of the freed object to Lisp_Misc_Free.
2616 We could leave the type alone, since nobody checks it,
2617 but this might catch bugs faster. */
2618 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2619 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2620 marker_free_list
= &mblk
->markers
[i
];
2627 XUNMARK (*markword
);
2630 lim
= MARKER_BLOCK_SIZE
;
2631 /* If this block contains only free markers and we have already
2632 seen more than two blocks worth of free markers then deallocate
2634 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
2636 *mprev
= mblk
->next
;
2637 /* Unhook from the free list. */
2638 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
2643 num_free
+= this_free
;
2644 mprev
= &mblk
->next
;
2648 total_markers
= num_used
;
2649 total_free_markers
= num_free
;
2652 /* Free all unmarked buffers */
2654 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2657 if (!XMARKBIT (buffer
->name
))
2660 prev
->next
= buffer
->next
;
2662 all_buffers
= buffer
->next
;
2663 next
= buffer
->next
;
2669 XUNMARK (buffer
->name
);
2670 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2673 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2674 for purposes of marking and relocation.
2675 Turn them back into C pointers now. */
2676 buffer
->upcase_table
2677 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2678 buffer
->downcase_table
2679 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2681 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2682 buffer
->folding_sort_table
2683 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2686 prev
= buffer
, buffer
= buffer
->next
;
2690 #endif /* standalone */
2692 /* Free all unmarked vectors */
2694 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2695 total_vector_size
= 0;
2698 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2701 prev
->next
= vector
->next
;
2703 all_vectors
= vector
->next
;
2704 next
= vector
->next
;
2710 vector
->size
&= ~ARRAY_MARK_FLAG
;
2711 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2712 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2714 total_vector_size
+= vector
->size
;
2715 prev
= vector
, vector
= vector
->next
;
2719 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2721 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2722 struct Lisp_String
*s
;
2726 s
= (struct Lisp_String
*) &sb
->chars
[0];
2727 if (s
->size
& ARRAY_MARK_FLAG
)
2729 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2730 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2731 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2732 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2733 prev
= sb
, sb
= sb
->next
;
2738 prev
->next
= sb
->next
;
2740 large_string_blocks
= sb
->next
;
2749 /* Compactify strings, relocate references, and free empty string blocks. */
2754 /* String block of old strings we are scanning. */
2755 register struct string_block
*from_sb
;
2756 /* A preceding string block (or maybe the same one)
2757 where we are copying the still-live strings to. */
2758 register struct string_block
*to_sb
;
2762 to_sb
= first_string_block
;
2765 /* Scan each existing string block sequentially, string by string. */
2766 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2769 /* POS is the index of the next string in the block. */
2770 while (pos
< from_sb
->pos
)
2772 register struct Lisp_String
*nextstr
2773 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2775 register struct Lisp_String
*newaddr
;
2776 register EMACS_INT size
= nextstr
->size
;
2777 EMACS_INT size_byte
= nextstr
->size_byte
;
2779 /* NEXTSTR is the old address of the next string.
2780 Just skip it if it isn't marked. */
2781 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2783 /* It is marked, so its size field is really a chain of refs.
2784 Find the end of the chain, where the actual size lives. */
2785 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2787 if (size
& DONT_COPY_FLAG
)
2788 size
^= MARKBIT
| DONT_COPY_FLAG
;
2789 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2795 total_string_size
+= size_byte
;
2797 /* If it won't fit in TO_SB, close it out,
2798 and move to the next sb. Keep doing so until
2799 TO_SB reaches a large enough, empty enough string block.
2800 We know that TO_SB cannot advance past FROM_SB here
2801 since FROM_SB is large enough to contain this string.
2802 Any string blocks skipped here
2803 will be patched out and freed later. */
2804 while (to_pos
+ STRING_FULLSIZE (size_byte
)
2805 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2807 to_sb
->pos
= to_pos
;
2808 to_sb
= to_sb
->next
;
2811 /* Compute new address of this string
2812 and update TO_POS for the space being used. */
2813 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2814 to_pos
+= STRING_FULLSIZE (size_byte
);
2816 /* Copy the string itself to the new place. */
2817 if (nextstr
!= newaddr
)
2818 bcopy (nextstr
, newaddr
, STRING_FULLSIZE (size_byte
));
2820 /* Go through NEXTSTR's chain of references
2821 and make each slot in the chain point to
2822 the new address of this string. */
2823 size
= newaddr
->size
;
2824 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2826 register Lisp_Object
*objptr
;
2827 if (size
& DONT_COPY_FLAG
)
2828 size
^= MARKBIT
| DONT_COPY_FLAG
;
2829 objptr
= (Lisp_Object
*)size
;
2831 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2832 if (XMARKBIT (*objptr
))
2834 XSETSTRING (*objptr
, newaddr
);
2838 XSETSTRING (*objptr
, newaddr
);
2840 /* Store the actual size in the size field. */
2841 newaddr
->size
= size
;
2843 #ifdef USE_TEXT_PROPERTIES
2844 /* Now that the string has been relocated, rebalance its
2845 interval tree, and update the tree's parent pointer. */
2846 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2848 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2849 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2852 #endif /* USE_TEXT_PROPERTIES */
2854 else if (size_byte
< 0)
2857 pos
+= STRING_FULLSIZE (size_byte
);
2861 /* Close out the last string block still used and free any that follow. */
2862 to_sb
->pos
= to_pos
;
2863 current_string_block
= to_sb
;
2865 from_sb
= to_sb
->next
;
2869 to_sb
= from_sb
->next
;
2874 /* Free any empty string blocks further back in the chain.
2875 This loop will never free first_string_block, but it is very
2876 unlikely that that one will become empty, so why bother checking? */
2878 from_sb
= first_string_block
;
2879 while (to_sb
= from_sb
->next
)
2881 if (to_sb
->pos
== 0)
2883 if (from_sb
->next
= to_sb
->next
)
2884 from_sb
->next
->prev
= from_sb
;
2892 /* Debugging aids. */
2894 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2895 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2896 This may be helpful in debugging Emacs's memory usage.\n\
2897 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2902 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2907 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2908 "Return a list of counters that measure how much consing there has been.\n\
2909 Each of these counters increments for a certain kind of object.\n\
2910 The counters wrap around from the largest positive integer to zero.\n\
2911 Garbage collection does not decrease them.\n\
2912 The elements of the value are as follows:\n\
2913 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2914 All are in units of 1 = one object consed\n\
2915 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2917 MISCS include overlays, markers, and some internal types.\n\
2918 Frames, windows, buffers, and subprocesses count as vectors\n\
2919 (but the contents of a buffer's text do not count here).")
2922 Lisp_Object lisp_cons_cells_consed
;
2923 Lisp_Object lisp_floats_consed
;
2924 Lisp_Object lisp_vector_cells_consed
;
2925 Lisp_Object lisp_symbols_consed
;
2926 Lisp_Object lisp_string_chars_consed
;
2927 Lisp_Object lisp_misc_objects_consed
;
2928 Lisp_Object lisp_intervals_consed
;
2930 XSETINT (lisp_cons_cells_consed
,
2931 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2932 XSETINT (lisp_floats_consed
,
2933 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2934 XSETINT (lisp_vector_cells_consed
,
2935 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2936 XSETINT (lisp_symbols_consed
,
2937 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2938 XSETINT (lisp_string_chars_consed
,
2939 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2940 XSETINT (lisp_misc_objects_consed
,
2941 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2942 XSETINT (lisp_intervals_consed
,
2943 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2945 return Fcons (lisp_cons_cells_consed
,
2946 Fcons (lisp_floats_consed
,
2947 Fcons (lisp_vector_cells_consed
,
2948 Fcons (lisp_symbols_consed
,
2949 Fcons (lisp_string_chars_consed
,
2950 Fcons (lisp_misc_objects_consed
,
2951 Fcons (lisp_intervals_consed
,
2955 /* Initialization */
2960 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2963 pure_size
= PURESIZE
;
2966 ignore_warnings
= 1;
2967 #ifdef DOUG_LEA_MALLOC
2968 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
2969 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
2970 mallopt (M_MMAP_MAX
, 64); /* max. number of mmap'ed areas */
2976 #ifdef LISP_FLOAT_TYPE
2978 #endif /* LISP_FLOAT_TYPE */
2982 malloc_hysteresis
= 32;
2984 malloc_hysteresis
= 0;
2987 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2989 ignore_warnings
= 0;
2992 consing_since_gc
= 0;
2993 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
2994 #ifdef VIRT_ADDR_VARIES
2995 malloc_sbrk_unused
= 1<<22; /* A large number */
2996 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2997 #endif /* VIRT_ADDR_VARIES */
3009 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
3010 "*Number of bytes of consing between garbage collections.\n\
3011 Garbage collection can happen automatically once this many bytes have been\n\
3012 allocated since the last garbage collection. All data types count.\n\n\
3013 Garbage collection happens automatically only when `eval' is called.\n\n\
3014 By binding this temporarily to a large number, you can effectively\n\
3015 prevent garbage collection during a part of the program.");
3017 DEFVAR_INT ("pure-bytes-used", &pureptr
,
3018 "Number of bytes of sharable Lisp data allocated so far.");
3020 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
3021 "Number of cons cells that have been consed so far.");
3023 DEFVAR_INT ("floats-consed", &floats_consed
,
3024 "Number of floats that have been consed so far.");
3026 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
3027 "Number of vector cells that have been consed so far.");
3029 DEFVAR_INT ("symbols-consed", &symbols_consed
,
3030 "Number of symbols that have been consed so far.");
3032 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
3033 "Number of string characters that have been consed so far.");
3035 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
3036 "Number of miscellaneous objects that have been consed so far.");
3038 DEFVAR_INT ("intervals-consed", &intervals_consed
,
3039 "Number of intervals that have been consed so far.");
3042 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
3043 "Number of bytes of unshared memory allocated in this session.");
3045 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
3046 "Number of bytes of unshared memory remaining available in this session.");
3049 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
3050 "Non-nil means loading Lisp code in order to dump an executable.\n\
3051 This means that certain objects should be allocated in shared (pure) space.");
3053 DEFVAR_INT ("undo-limit", &undo_limit
,
3054 "Keep no more undo information once it exceeds this size.\n\
3055 This limit is applied when garbage collection happens.\n\
3056 The size is counted as the number of bytes occupied,\n\
3057 which includes both saved text and other data.");
3060 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
3061 "Don't keep more than this much size of undo information.\n\
3062 A command which pushes past this size is itself forgotten.\n\
3063 This limit is applied when garbage collection happens.\n\
3064 The size is counted as the number of bytes occupied,\n\
3065 which includes both saved text and other data.");
3066 undo_strong_limit
= 30000;
3068 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
3069 "Non-nil means display messages at start and end of garbage collection.");
3070 garbage_collection_messages
= 0;
3072 /* We build this in advance because if we wait until we need it, we might
3073 not be able to allocate the memory to hold it. */
3075 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
3076 staticpro (&memory_signal_data
);
3078 staticpro (&Qgc_cons_threshold
);
3079 Qgc_cons_threshold
= intern ("gc-cons-threshold");
3081 staticpro (&Qchar_table_extra_slots
);
3082 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
3087 defsubr (&Smake_byte_code
);
3088 defsubr (&Smake_list
);
3089 defsubr (&Smake_vector
);
3090 defsubr (&Smake_char_table
);
3091 defsubr (&Smake_string
);
3092 defsubr (&Smake_bool_vector
);
3093 defsubr (&Smake_symbol
);
3094 defsubr (&Smake_marker
);
3095 defsubr (&Spurecopy
);
3096 defsubr (&Sgarbage_collect
);
3097 defsubr (&Smemory_limit
);
3098 defsubr (&Smemory_use_counts
);