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 /* Don't keep undo information around forever. */
1735 register struct buffer
*nextb
= all_buffers
;
1739 /* If a buffer's undo list is Qt, that means that undo is
1740 turned off in that buffer. Calling truncate_undo_list on
1741 Qt tends to return NULL, which effectively turns undo back on.
1742 So don't call truncate_undo_list if undo_list is Qt. */
1743 if (! EQ (nextb
->undo_list
, Qt
))
1745 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1747 nextb
= nextb
->next
;
1753 /* clear_marks (); */
1755 /* In each "large string", set the MARKBIT of the size field.
1756 That enables mark_object to recognize them. */
1758 register struct string_block
*b
;
1759 for (b
= large_string_blocks
; b
; b
= b
->next
)
1760 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1763 /* Mark all the special slots that serve as the roots of accessibility.
1765 Usually the special slots to mark are contained in particular structures.
1766 Then we know no slot is marked twice because the structures don't overlap.
1767 In some cases, the structures point to the slots to be marked.
1768 For these, we use MARKBIT to avoid double marking of the slot. */
1770 for (i
= 0; i
< staticidx
; i
++)
1771 mark_object (staticvec
[i
]);
1772 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1773 for (i
= 0; i
< tail
->nvars
; i
++)
1774 if (!XMARKBIT (tail
->var
[i
]))
1776 mark_object (&tail
->var
[i
]);
1777 XMARK (tail
->var
[i
]);
1779 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1781 mark_object (&bind
->symbol
);
1782 mark_object (&bind
->old_value
);
1784 for (catch = catchlist
; catch; catch = catch->next
)
1786 mark_object (&catch->tag
);
1787 mark_object (&catch->val
);
1789 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1791 mark_object (&handler
->handler
);
1792 mark_object (&handler
->var
);
1794 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1796 if (!XMARKBIT (*backlist
->function
))
1798 mark_object (backlist
->function
);
1799 XMARK (*backlist
->function
);
1801 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1804 i
= backlist
->nargs
- 1;
1806 if (!XMARKBIT (backlist
->args
[i
]))
1808 mark_object (&backlist
->args
[i
]);
1809 XMARK (backlist
->args
[i
]);
1814 /* Look thru every buffer's undo list
1815 for elements that update markers that were not marked,
1818 register struct buffer
*nextb
= all_buffers
;
1822 /* If a buffer's undo list is Qt, that means that undo is
1823 turned off in that buffer. Calling truncate_undo_list on
1824 Qt tends to return NULL, which effectively turns undo back on.
1825 So don't call truncate_undo_list if undo_list is Qt. */
1826 if (! EQ (nextb
->undo_list
, Qt
))
1828 Lisp_Object tail
, prev
;
1829 tail
= nextb
->undo_list
;
1831 while (CONSP (tail
))
1833 if (GC_CONSP (XCONS (tail
)->car
)
1834 && GC_MARKERP (XCONS (XCONS (tail
)->car
)->car
)
1835 && ! XMARKBIT (XMARKER (XCONS (XCONS (tail
)->car
)->car
)->chain
))
1838 nextb
->undo_list
= tail
= XCONS (tail
)->cdr
;
1840 tail
= XCONS (prev
)->cdr
= XCONS (tail
)->cdr
;
1845 tail
= XCONS (tail
)->cdr
;
1850 nextb
= nextb
->next
;
1856 /* Clear the mark bits that we set in certain root slots. */
1858 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1859 for (i
= 0; i
< tail
->nvars
; i
++)
1860 XUNMARK (tail
->var
[i
]);
1861 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1863 XUNMARK (*backlist
->function
);
1864 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1867 i
= backlist
->nargs
- 1;
1869 XUNMARK (backlist
->args
[i
]);
1871 XUNMARK (buffer_defaults
.name
);
1872 XUNMARK (buffer_local_symbols
.name
);
1874 /* clear_marks (); */
1877 consing_since_gc
= 0;
1878 if (gc_cons_threshold
< 10000)
1879 gc_cons_threshold
= 10000;
1881 if (garbage_collection_messages
)
1883 if (omessage
|| minibuf_level
> 0)
1884 message2_nolog (omessage
, omessage_length
, oldmultibyte
);
1886 message1_nolog ("Garbage collecting...done");
1889 return Fcons (Fcons (make_number (total_conses
),
1890 make_number (total_free_conses
)),
1891 Fcons (Fcons (make_number (total_symbols
),
1892 make_number (total_free_symbols
)),
1893 Fcons (Fcons (make_number (total_markers
),
1894 make_number (total_free_markers
)),
1895 Fcons (make_number (total_string_size
),
1896 Fcons (make_number (total_vector_size
),
1898 #ifdef LISP_FLOAT_TYPE
1899 (make_number (total_floats
),
1900 make_number (total_free_floats
)),
1901 #else /* not LISP_FLOAT_TYPE */
1902 (make_number (0), make_number (0)),
1903 #endif /* not LISP_FLOAT_TYPE */
1905 #ifdef USE_TEXT_PROPERTIES
1906 (make_number (total_intervals
),
1907 make_number (total_free_intervals
)),
1908 #else /* not USE_TEXT_PROPERTIES */
1909 (make_number (0), make_number (0)),
1910 #endif /* not USE_TEXT_PROPERTIES */
1918 /* Clear marks on all conses */
1920 register struct cons_block
*cblk
;
1921 register int lim
= cons_block_index
;
1923 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1926 for (i
= 0; i
< lim
; i
++)
1927 XUNMARK (cblk
->conses
[i
].car
);
1928 lim
= CONS_BLOCK_SIZE
;
1931 /* Clear marks on all symbols */
1933 register struct symbol_block
*sblk
;
1934 register int lim
= symbol_block_index
;
1936 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1939 for (i
= 0; i
< lim
; i
++)
1941 XUNMARK (sblk
->symbols
[i
].plist
);
1943 lim
= SYMBOL_BLOCK_SIZE
;
1946 /* Clear marks on all markers */
1948 register struct marker_block
*sblk
;
1949 register int lim
= marker_block_index
;
1951 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1954 for (i
= 0; i
< lim
; i
++)
1955 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1956 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1957 lim
= MARKER_BLOCK_SIZE
;
1960 /* Clear mark bits on all buffers */
1962 register struct buffer
*nextb
= all_buffers
;
1966 XUNMARK (nextb
->name
);
1967 nextb
= nextb
->next
;
1973 /* Mark reference to a Lisp_Object.
1974 If the object referred to has not been seen yet, recursively mark
1975 all the references contained in it.
1977 If the object referenced is a short string, the referencing slot
1978 is threaded into a chain of such slots, pointed to from
1979 the `size' field of the string. The actual string size
1980 lives in the last slot in the chain. We recognize the end
1981 because it is < (unsigned) STRING_BLOCK_SIZE. */
1983 #define LAST_MARKED_SIZE 500
1984 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1985 int last_marked_index
;
1988 mark_object (argptr
)
1989 Lisp_Object
*argptr
;
1991 Lisp_Object
*objptr
= argptr
;
1992 register Lisp_Object obj
;
1999 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
2000 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
2003 last_marked
[last_marked_index
++] = objptr
;
2004 if (last_marked_index
== LAST_MARKED_SIZE
)
2005 last_marked_index
= 0;
2007 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
2011 register struct Lisp_String
*ptr
= XSTRING (obj
);
2013 MARK_INTERVAL_TREE (ptr
->intervals
);
2014 if (ptr
->size
& MARKBIT
)
2015 /* A large string. Just set ARRAY_MARK_FLAG. */
2016 ptr
->size
|= ARRAY_MARK_FLAG
;
2019 /* A small string. Put this reference
2020 into the chain of references to it.
2021 If the address includes MARKBIT, put that bit elsewhere
2022 when we store OBJPTR into the size field. */
2024 if (XMARKBIT (*objptr
))
2026 XSETFASTINT (*objptr
, ptr
->size
);
2030 XSETFASTINT (*objptr
, ptr
->size
);
2032 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
2034 ptr
->size
= (EMACS_INT
) objptr
;
2035 if (ptr
->size
& MARKBIT
)
2036 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
2041 case Lisp_Vectorlike
:
2042 if (GC_BUFFERP (obj
))
2044 if (!XMARKBIT (XBUFFER (obj
)->name
))
2047 else if (GC_SUBRP (obj
))
2049 else if (GC_COMPILEDP (obj
))
2050 /* We could treat this just like a vector, but it is better
2051 to save the COMPILED_CONSTANTS element for last and avoid recursion
2054 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2055 register EMACS_INT size
= ptr
->size
;
2056 /* See comment above under Lisp_Vector. */
2057 struct Lisp_Vector
*volatile ptr1
= ptr
;
2060 if (size
& ARRAY_MARK_FLAG
)
2061 break; /* Already marked */
2062 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2063 size
&= PSEUDOVECTOR_SIZE_MASK
;
2064 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2066 if (i
!= COMPILED_CONSTANTS
)
2067 mark_object (&ptr1
->contents
[i
]);
2069 /* This cast should be unnecessary, but some Mips compiler complains
2070 (MIPS-ABI + SysVR4, DC/OSx, etc). */
2071 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
2074 else if (GC_FRAMEP (obj
))
2076 /* See comment above under Lisp_Vector for why this is volatile. */
2077 register struct frame
*volatile ptr
= XFRAME (obj
);
2078 register EMACS_INT size
= ptr
->size
;
2080 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2081 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2083 mark_object (&ptr
->name
);
2084 mark_object (&ptr
->icon_name
);
2085 mark_object (&ptr
->title
);
2086 mark_object (&ptr
->focus_frame
);
2087 mark_object (&ptr
->selected_window
);
2088 mark_object (&ptr
->minibuffer_window
);
2089 mark_object (&ptr
->param_alist
);
2090 mark_object (&ptr
->scroll_bars
);
2091 mark_object (&ptr
->condemned_scroll_bars
);
2092 mark_object (&ptr
->menu_bar_items
);
2093 mark_object (&ptr
->face_alist
);
2094 mark_object (&ptr
->menu_bar_vector
);
2095 mark_object (&ptr
->buffer_predicate
);
2096 mark_object (&ptr
->buffer_list
);
2098 else if (GC_BOOL_VECTOR_P (obj
))
2100 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2102 if (ptr
->size
& ARRAY_MARK_FLAG
)
2103 break; /* Already marked */
2104 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2108 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2109 register EMACS_INT size
= ptr
->size
;
2110 /* The reason we use ptr1 is to avoid an apparent hardware bug
2111 that happens occasionally on the FSF's HP 300s.
2112 The bug is that a2 gets clobbered by recursive calls to mark_object.
2113 The clobberage seems to happen during function entry,
2114 perhaps in the moveml instruction.
2115 Yes, this is a crock, but we have to do it. */
2116 struct Lisp_Vector
*volatile ptr1
= ptr
;
2119 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2120 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2121 if (size
& PSEUDOVECTOR_FLAG
)
2122 size
&= PSEUDOVECTOR_SIZE_MASK
;
2123 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2124 mark_object (&ptr1
->contents
[i
]);
2130 /* See comment above under Lisp_Vector for why this is volatile. */
2131 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
2132 struct Lisp_Symbol
*ptrx
;
2134 if (XMARKBIT (ptr
->plist
)) break;
2136 mark_object ((Lisp_Object
*) &ptr
->value
);
2137 mark_object (&ptr
->function
);
2138 mark_object (&ptr
->plist
);
2139 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
2140 mark_object (&ptr
->name
);
2141 /* Note that we do not mark the obarray of the symbol.
2142 It is safe not to do so because nothing accesses that
2143 slot except to check whether it is nil. */
2147 /* For the benefit of the last_marked log. */
2148 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
2149 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
2150 XSETSYMBOL (obj
, ptrx
);
2151 /* We can't goto loop here because *objptr doesn't contain an
2152 actual Lisp_Object with valid datatype field. */
2159 switch (XMISCTYPE (obj
))
2161 case Lisp_Misc_Marker
:
2162 XMARK (XMARKER (obj
)->chain
);
2163 /* DO NOT mark thru the marker's chain.
2164 The buffer's markers chain does not preserve markers from gc;
2165 instead, markers are removed from the chain when freed by gc. */
2168 case Lisp_Misc_Buffer_Local_Value
:
2169 case Lisp_Misc_Some_Buffer_Local_Value
:
2171 register struct Lisp_Buffer_Local_Value
*ptr
2172 = XBUFFER_LOCAL_VALUE (obj
);
2173 if (XMARKBIT (ptr
->realvalue
)) break;
2174 XMARK (ptr
->realvalue
);
2175 /* If the cdr is nil, avoid recursion for the car. */
2176 if (EQ (ptr
->cdr
, Qnil
))
2178 objptr
= &ptr
->realvalue
;
2181 mark_object (&ptr
->realvalue
);
2182 mark_object (&ptr
->buffer
);
2183 mark_object (&ptr
->frame
);
2184 /* See comment above under Lisp_Vector for why not use ptr here. */
2185 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
2189 case Lisp_Misc_Intfwd
:
2190 case Lisp_Misc_Boolfwd
:
2191 case Lisp_Misc_Objfwd
:
2192 case Lisp_Misc_Buffer_Objfwd
:
2193 case Lisp_Misc_Kboard_Objfwd
:
2194 /* Don't bother with Lisp_Buffer_Objfwd,
2195 since all markable slots in current buffer marked anyway. */
2196 /* Don't need to do Lisp_Objfwd, since the places they point
2197 are protected with staticpro. */
2200 case Lisp_Misc_Overlay
:
2202 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
2203 if (!XMARKBIT (ptr
->plist
))
2206 mark_object (&ptr
->start
);
2207 mark_object (&ptr
->end
);
2208 objptr
= &ptr
->plist
;
2221 register struct Lisp_Cons
*ptr
= XCONS (obj
);
2222 if (XMARKBIT (ptr
->car
)) break;
2224 /* If the cdr is nil, avoid recursion for the car. */
2225 if (EQ (ptr
->cdr
, Qnil
))
2230 mark_object (&ptr
->car
);
2231 /* See comment above under Lisp_Vector for why not use ptr here. */
2232 objptr
= &XCONS (obj
)->cdr
;
2236 #ifdef LISP_FLOAT_TYPE
2238 XMARK (XFLOAT (obj
)->type
);
2240 #endif /* LISP_FLOAT_TYPE */
2250 /* Mark the pointers in a buffer structure. */
2256 register struct buffer
*buffer
= XBUFFER (buf
);
2257 register Lisp_Object
*ptr
;
2258 Lisp_Object base_buffer
;
2260 /* This is the buffer's markbit */
2261 mark_object (&buffer
->name
);
2262 XMARK (buffer
->name
);
2264 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
2266 if (CONSP (buffer
->undo_list
))
2269 tail
= buffer
->undo_list
;
2271 while (CONSP (tail
))
2273 register struct Lisp_Cons
*ptr
= XCONS (tail
);
2275 if (XMARKBIT (ptr
->car
))
2278 if (GC_CONSP (ptr
->car
)
2279 && ! XMARKBIT (XCONS (ptr
->car
)->car
)
2280 && GC_MARKERP (XCONS (ptr
->car
)->car
))
2282 XMARK (XCONS (ptr
->car
)->car
);
2283 mark_object (&XCONS (ptr
->car
)->cdr
);
2286 mark_object (&ptr
->car
);
2288 if (CONSP (ptr
->cdr
))
2294 mark_object (&XCONS (tail
)->cdr
);
2297 mark_object (&buffer
->undo_list
);
2300 mark_object (buffer
->syntax_table
);
2302 /* Mark the various string-pointers in the buffer object.
2303 Since the strings may be relocated, we must mark them
2304 in their actual slots. So gc_sweep must convert each slot
2305 back to an ordinary C pointer. */
2306 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
2307 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
2308 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
2309 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
2311 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
2312 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
2313 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
2314 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
2317 for (ptr
= &buffer
->name
+ 1;
2318 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
2322 /* If this is an indirect buffer, mark its base buffer. */
2323 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
2325 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2326 mark_buffer (base_buffer
);
2331 /* Mark the pointers in the kboard objects. */
2338 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2340 if (kb
->kbd_macro_buffer
)
2341 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2343 mark_object (&kb
->Vprefix_arg
);
2344 mark_object (&kb
->kbd_queue
);
2345 mark_object (&kb
->Vlast_kbd_macro
);
2346 mark_object (&kb
->Vsystem_key_alist
);
2347 mark_object (&kb
->system_key_syms
);
2351 /* Sweep: find all structures not marked, and free them. */
2356 total_string_size
= 0;
2359 /* Put all unmarked conses on free list */
2361 register struct cons_block
*cblk
;
2362 struct cons_block
**cprev
= &cons_block
;
2363 register int lim
= cons_block_index
;
2364 register int num_free
= 0, num_used
= 0;
2368 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
2372 for (i
= 0; i
< lim
; i
++)
2373 if (!XMARKBIT (cblk
->conses
[i
].car
))
2376 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
2377 cons_free_list
= &cblk
->conses
[i
];
2382 XUNMARK (cblk
->conses
[i
].car
);
2384 lim
= CONS_BLOCK_SIZE
;
2385 /* If this block contains only free conses and we have already
2386 seen more than two blocks worth of free conses then deallocate
2388 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
2390 *cprev
= cblk
->next
;
2391 /* Unhook from the free list. */
2392 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
2397 num_free
+= this_free
;
2398 cprev
= &cblk
->next
;
2401 total_conses
= num_used
;
2402 total_free_conses
= num_free
;
2405 #ifdef LISP_FLOAT_TYPE
2406 /* Put all unmarked floats on free list */
2408 register struct float_block
*fblk
;
2409 struct float_block
**fprev
= &float_block
;
2410 register int lim
= float_block_index
;
2411 register int num_free
= 0, num_used
= 0;
2413 float_free_list
= 0;
2415 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
2419 for (i
= 0; i
< lim
; i
++)
2420 if (!XMARKBIT (fblk
->floats
[i
].type
))
2423 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
2424 float_free_list
= &fblk
->floats
[i
];
2429 XUNMARK (fblk
->floats
[i
].type
);
2431 lim
= FLOAT_BLOCK_SIZE
;
2432 /* If this block contains only free floats and we have already
2433 seen more than two blocks worth of free floats then deallocate
2435 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
2437 *fprev
= fblk
->next
;
2438 /* Unhook from the free list. */
2439 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
2444 num_free
+= this_free
;
2445 fprev
= &fblk
->next
;
2448 total_floats
= num_used
;
2449 total_free_floats
= num_free
;
2451 #endif /* LISP_FLOAT_TYPE */
2453 #ifdef USE_TEXT_PROPERTIES
2454 /* Put all unmarked intervals on free list */
2456 register struct interval_block
*iblk
;
2457 struct interval_block
**iprev
= &interval_block
;
2458 register int lim
= interval_block_index
;
2459 register int num_free
= 0, num_used
= 0;
2461 interval_free_list
= 0;
2463 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
2468 for (i
= 0; i
< lim
; i
++)
2470 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2472 iblk
->intervals
[i
].parent
= interval_free_list
;
2473 interval_free_list
= &iblk
->intervals
[i
];
2479 XUNMARK (iblk
->intervals
[i
].plist
);
2482 lim
= INTERVAL_BLOCK_SIZE
;
2483 /* If this block contains only free intervals and we have already
2484 seen more than two blocks worth of free intervals then
2485 deallocate this block. */
2486 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
2488 *iprev
= iblk
->next
;
2489 /* Unhook from the free list. */
2490 interval_free_list
= iblk
->intervals
[0].parent
;
2495 num_free
+= this_free
;
2496 iprev
= &iblk
->next
;
2499 total_intervals
= num_used
;
2500 total_free_intervals
= num_free
;
2502 #endif /* USE_TEXT_PROPERTIES */
2504 /* Put all unmarked symbols on free list */
2506 register struct symbol_block
*sblk
;
2507 struct symbol_block
**sprev
= &symbol_block
;
2508 register int lim
= symbol_block_index
;
2509 register int num_free
= 0, num_used
= 0;
2511 symbol_free_list
= 0;
2513 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
2517 for (i
= 0; i
< lim
; i
++)
2518 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2520 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2521 symbol_free_list
= &sblk
->symbols
[i
];
2527 sblk
->symbols
[i
].name
2528 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2529 XUNMARK (sblk
->symbols
[i
].plist
);
2531 lim
= SYMBOL_BLOCK_SIZE
;
2532 /* If this block contains only free symbols and we have already
2533 seen more than two blocks worth of free symbols then deallocate
2535 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
2537 *sprev
= sblk
->next
;
2538 /* Unhook from the free list. */
2539 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
2544 num_free
+= this_free
;
2545 sprev
= &sblk
->next
;
2548 total_symbols
= num_used
;
2549 total_free_symbols
= num_free
;
2553 /* Put all unmarked misc's on free list.
2554 For a marker, first unchain it from the buffer it points into. */
2556 register struct marker_block
*mblk
;
2557 struct marker_block
**mprev
= &marker_block
;
2558 register int lim
= marker_block_index
;
2559 register int num_free
= 0, num_used
= 0;
2561 marker_free_list
= 0;
2563 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
2567 EMACS_INT already_free
= -1;
2569 for (i
= 0; i
< lim
; i
++)
2571 Lisp_Object
*markword
;
2572 switch (mblk
->markers
[i
].u_marker
.type
)
2574 case Lisp_Misc_Marker
:
2575 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2577 case Lisp_Misc_Buffer_Local_Value
:
2578 case Lisp_Misc_Some_Buffer_Local_Value
:
2579 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
2581 case Lisp_Misc_Overlay
:
2582 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2584 case Lisp_Misc_Free
:
2585 /* If the object was already free, keep it
2586 on the free list. */
2587 markword
= (Lisp_Object
*) &already_free
;
2593 if (markword
&& !XMARKBIT (*markword
))
2596 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2598 /* tem1 avoids Sun compiler bug */
2599 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2600 XSETMARKER (tem
, tem1
);
2601 unchain_marker (tem
);
2603 /* Set the type of the freed object to Lisp_Misc_Free.
2604 We could leave the type alone, since nobody checks it,
2605 but this might catch bugs faster. */
2606 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2607 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2608 marker_free_list
= &mblk
->markers
[i
];
2615 XUNMARK (*markword
);
2618 lim
= MARKER_BLOCK_SIZE
;
2619 /* If this block contains only free markers and we have already
2620 seen more than two blocks worth of free markers then deallocate
2622 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
2624 *mprev
= mblk
->next
;
2625 /* Unhook from the free list. */
2626 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
2631 num_free
+= this_free
;
2632 mprev
= &mblk
->next
;
2636 total_markers
= num_used
;
2637 total_free_markers
= num_free
;
2640 /* Free all unmarked buffers */
2642 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2645 if (!XMARKBIT (buffer
->name
))
2648 prev
->next
= buffer
->next
;
2650 all_buffers
= buffer
->next
;
2651 next
= buffer
->next
;
2657 XUNMARK (buffer
->name
);
2658 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2661 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2662 for purposes of marking and relocation.
2663 Turn them back into C pointers now. */
2664 buffer
->upcase_table
2665 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2666 buffer
->downcase_table
2667 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2669 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2670 buffer
->folding_sort_table
2671 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2674 prev
= buffer
, buffer
= buffer
->next
;
2678 #endif /* standalone */
2680 /* Free all unmarked vectors */
2682 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2683 total_vector_size
= 0;
2686 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2689 prev
->next
= vector
->next
;
2691 all_vectors
= vector
->next
;
2692 next
= vector
->next
;
2698 vector
->size
&= ~ARRAY_MARK_FLAG
;
2699 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2700 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2702 total_vector_size
+= vector
->size
;
2703 prev
= vector
, vector
= vector
->next
;
2707 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2709 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2710 struct Lisp_String
*s
;
2714 s
= (struct Lisp_String
*) &sb
->chars
[0];
2715 if (s
->size
& ARRAY_MARK_FLAG
)
2717 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2718 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2719 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2720 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2721 prev
= sb
, sb
= sb
->next
;
2726 prev
->next
= sb
->next
;
2728 large_string_blocks
= sb
->next
;
2737 /* Compactify strings, relocate references, and free empty string blocks. */
2742 /* String block of old strings we are scanning. */
2743 register struct string_block
*from_sb
;
2744 /* A preceding string block (or maybe the same one)
2745 where we are copying the still-live strings to. */
2746 register struct string_block
*to_sb
;
2750 to_sb
= first_string_block
;
2753 /* Scan each existing string block sequentially, string by string. */
2754 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2757 /* POS is the index of the next string in the block. */
2758 while (pos
< from_sb
->pos
)
2760 register struct Lisp_String
*nextstr
2761 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2763 register struct Lisp_String
*newaddr
;
2764 register EMACS_INT size
= nextstr
->size
;
2765 EMACS_INT size_byte
= nextstr
->size_byte
;
2767 /* NEXTSTR is the old address of the next string.
2768 Just skip it if it isn't marked. */
2769 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2771 /* It is marked, so its size field is really a chain of refs.
2772 Find the end of the chain, where the actual size lives. */
2773 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2775 if (size
& DONT_COPY_FLAG
)
2776 size
^= MARKBIT
| DONT_COPY_FLAG
;
2777 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2783 total_string_size
+= size_byte
;
2785 /* If it won't fit in TO_SB, close it out,
2786 and move to the next sb. Keep doing so until
2787 TO_SB reaches a large enough, empty enough string block.
2788 We know that TO_SB cannot advance past FROM_SB here
2789 since FROM_SB is large enough to contain this string.
2790 Any string blocks skipped here
2791 will be patched out and freed later. */
2792 while (to_pos
+ STRING_FULLSIZE (size_byte
)
2793 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2795 to_sb
->pos
= to_pos
;
2796 to_sb
= to_sb
->next
;
2799 /* Compute new address of this string
2800 and update TO_POS for the space being used. */
2801 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2802 to_pos
+= STRING_FULLSIZE (size_byte
);
2804 /* Copy the string itself to the new place. */
2805 if (nextstr
!= newaddr
)
2806 bcopy (nextstr
, newaddr
, STRING_FULLSIZE (size_byte
));
2808 /* Go through NEXTSTR's chain of references
2809 and make each slot in the chain point to
2810 the new address of this string. */
2811 size
= newaddr
->size
;
2812 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2814 register Lisp_Object
*objptr
;
2815 if (size
& DONT_COPY_FLAG
)
2816 size
^= MARKBIT
| DONT_COPY_FLAG
;
2817 objptr
= (Lisp_Object
*)size
;
2819 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2820 if (XMARKBIT (*objptr
))
2822 XSETSTRING (*objptr
, newaddr
);
2826 XSETSTRING (*objptr
, newaddr
);
2828 /* Store the actual size in the size field. */
2829 newaddr
->size
= size
;
2831 #ifdef USE_TEXT_PROPERTIES
2832 /* Now that the string has been relocated, rebalance its
2833 interval tree, and update the tree's parent pointer. */
2834 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2836 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2837 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2840 #endif /* USE_TEXT_PROPERTIES */
2842 else if (size_byte
< 0)
2845 pos
+= STRING_FULLSIZE (size_byte
);
2849 /* Close out the last string block still used and free any that follow. */
2850 to_sb
->pos
= to_pos
;
2851 current_string_block
= to_sb
;
2853 from_sb
= to_sb
->next
;
2857 to_sb
= from_sb
->next
;
2862 /* Free any empty string blocks further back in the chain.
2863 This loop will never free first_string_block, but it is very
2864 unlikely that that one will become empty, so why bother checking? */
2866 from_sb
= first_string_block
;
2867 while (to_sb
= from_sb
->next
)
2869 if (to_sb
->pos
== 0)
2871 if (from_sb
->next
= to_sb
->next
)
2872 from_sb
->next
->prev
= from_sb
;
2880 /* Debugging aids. */
2882 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2883 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2884 This may be helpful in debugging Emacs's memory usage.\n\
2885 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2890 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2895 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2896 "Return a list of counters that measure how much consing there has been.\n\
2897 Each of these counters increments for a certain kind of object.\n\
2898 The counters wrap around from the largest positive integer to zero.\n\
2899 Garbage collection does not decrease them.\n\
2900 The elements of the value are as follows:\n\
2901 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2902 All are in units of 1 = one object consed\n\
2903 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2905 MISCS include overlays, markers, and some internal types.\n\
2906 Frames, windows, buffers, and subprocesses count as vectors\n\
2907 (but the contents of a buffer's text do not count here).")
2910 Lisp_Object lisp_cons_cells_consed
;
2911 Lisp_Object lisp_floats_consed
;
2912 Lisp_Object lisp_vector_cells_consed
;
2913 Lisp_Object lisp_symbols_consed
;
2914 Lisp_Object lisp_string_chars_consed
;
2915 Lisp_Object lisp_misc_objects_consed
;
2916 Lisp_Object lisp_intervals_consed
;
2918 XSETINT (lisp_cons_cells_consed
,
2919 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2920 XSETINT (lisp_floats_consed
,
2921 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2922 XSETINT (lisp_vector_cells_consed
,
2923 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2924 XSETINT (lisp_symbols_consed
,
2925 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2926 XSETINT (lisp_string_chars_consed
,
2927 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2928 XSETINT (lisp_misc_objects_consed
,
2929 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2930 XSETINT (lisp_intervals_consed
,
2931 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2933 return Fcons (lisp_cons_cells_consed
,
2934 Fcons (lisp_floats_consed
,
2935 Fcons (lisp_vector_cells_consed
,
2936 Fcons (lisp_symbols_consed
,
2937 Fcons (lisp_string_chars_consed
,
2938 Fcons (lisp_misc_objects_consed
,
2939 Fcons (lisp_intervals_consed
,
2943 /* Initialization */
2948 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2951 pure_size
= PURESIZE
;
2954 ignore_warnings
= 1;
2955 #ifdef DOUG_LEA_MALLOC
2956 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
2957 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
2958 mallopt (M_MMAP_MAX
, 64); /* max. number of mmap'ed areas */
2964 #ifdef LISP_FLOAT_TYPE
2966 #endif /* LISP_FLOAT_TYPE */
2970 malloc_hysteresis
= 32;
2972 malloc_hysteresis
= 0;
2975 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2977 ignore_warnings
= 0;
2980 consing_since_gc
= 0;
2981 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
2982 #ifdef VIRT_ADDR_VARIES
2983 malloc_sbrk_unused
= 1<<22; /* A large number */
2984 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2985 #endif /* VIRT_ADDR_VARIES */
2997 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2998 "*Number of bytes of consing between garbage collections.\n\
2999 Garbage collection can happen automatically once this many bytes have been\n\
3000 allocated since the last garbage collection. All data types count.\n\n\
3001 Garbage collection happens automatically only when `eval' is called.\n\n\
3002 By binding this temporarily to a large number, you can effectively\n\
3003 prevent garbage collection during a part of the program.");
3005 DEFVAR_INT ("pure-bytes-used", &pureptr
,
3006 "Number of bytes of sharable Lisp data allocated so far.");
3008 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
3009 "Number of cons cells that have been consed so far.");
3011 DEFVAR_INT ("floats-consed", &floats_consed
,
3012 "Number of floats that have been consed so far.");
3014 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
3015 "Number of vector cells that have been consed so far.");
3017 DEFVAR_INT ("symbols-consed", &symbols_consed
,
3018 "Number of symbols that have been consed so far.");
3020 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
3021 "Number of string characters that have been consed so far.");
3023 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
3024 "Number of miscellaneous objects that have been consed so far.");
3026 DEFVAR_INT ("intervals-consed", &intervals_consed
,
3027 "Number of intervals that have been consed so far.");
3030 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
3031 "Number of bytes of unshared memory allocated in this session.");
3033 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
3034 "Number of bytes of unshared memory remaining available in this session.");
3037 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
3038 "Non-nil means loading Lisp code in order to dump an executable.\n\
3039 This means that certain objects should be allocated in shared (pure) space.");
3041 DEFVAR_INT ("undo-limit", &undo_limit
,
3042 "Keep no more undo information once it exceeds this size.\n\
3043 This limit is applied when garbage collection happens.\n\
3044 The size is counted as the number of bytes occupied,\n\
3045 which includes both saved text and other data.");
3048 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
3049 "Don't keep more than this much size of undo information.\n\
3050 A command which pushes past this size is itself forgotten.\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.");
3054 undo_strong_limit
= 30000;
3056 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
3057 "Non-nil means display messages at start and end of garbage collection.");
3058 garbage_collection_messages
= 0;
3060 /* We build this in advance because if we wait until we need it, we might
3061 not be able to allocate the memory to hold it. */
3063 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
3064 staticpro (&memory_signal_data
);
3066 staticpro (&Qgc_cons_threshold
);
3067 Qgc_cons_threshold
= intern ("gc-cons-threshold");
3069 staticpro (&Qchar_table_extra_slots
);
3070 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
3075 defsubr (&Smake_byte_code
);
3076 defsubr (&Smake_list
);
3077 defsubr (&Smake_vector
);
3078 defsubr (&Smake_char_table
);
3079 defsubr (&Smake_string
);
3080 defsubr (&Smake_bool_vector
);
3081 defsubr (&Smake_symbol
);
3082 defsubr (&Smake_marker
);
3083 defsubr (&Spurecopy
);
3084 defsubr (&Sgarbage_collect
);
3085 defsubr (&Smemory_limit
);
3086 defsubr (&Smemory_use_counts
);