1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
24 #include "intervals.h"
30 #include "blockinput.h"
34 #include "syssignal.h"
38 /* The following come from gmalloc.c. */
40 #if defined (__STDC__) && __STDC__
42 #define __malloc_size_t size_t
44 #define __malloc_size_t unsigned int
46 extern __malloc_size_t _bytes_used
;
47 extern int __malloc_extra_blocks
;
49 #define max(A,B) ((A) > (B) ? (A) : (B))
50 #define min(A,B) ((A) < (B) ? (A) : (B))
52 /* Macro to verify that storage intended for Lisp objects is not
53 out of range to fit in the space for a pointer.
54 ADDRESS is the start of the block, and SIZE
55 is the amount of space within which objects can start. */
56 #define VALIDATE_LISP_STORAGE(address, size) \
60 XSETCONS (val, (char *) address + size); \
61 if ((char *) XCONS (val) != (char *) address + size) \
68 /* Value of _bytes_used, when spare_memory was freed. */
69 static __malloc_size_t bytes_used_when_full
;
71 /* Number of bytes of consing done since the last gc */
74 /* Count the amount of consing of various sorts of space. */
75 int cons_cells_consed
;
77 int vector_cells_consed
;
79 int string_chars_consed
;
80 int misc_objects_consed
;
83 /* Number of bytes of consing since gc before another gc should be done. */
84 int gc_cons_threshold
;
86 /* Nonzero during gc */
89 #ifndef VIRT_ADDR_VARIES
91 #endif /* VIRT_ADDR_VARIES */
94 #ifndef VIRT_ADDR_VARIES
96 #endif /* VIRT_ADDR_VARIES */
97 int malloc_sbrk_unused
;
99 /* Two limits controlling how much undo information to keep. */
101 int undo_strong_limit
;
103 /* Points to memory space allocated as "spare",
104 to be freed if we run out of memory. */
105 static char *spare_memory
;
107 /* Amount of spare memory to keep in reserve. */
108 #define SPARE_MEMORY (1 << 14)
110 /* Number of extra blocks malloc should get when it needs more core. */
111 static int malloc_hysteresis
;
113 /* Nonzero when malloc is called for allocating Lisp object space. */
114 int allocating_for_lisp
;
116 /* Non-nil means defun should do purecopy on the function definition */
117 Lisp_Object Vpurify_flag
;
120 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
121 #define PUREBEG (char *) pure
123 #define pure PURE_SEG_BITS /* Use shared memory segment */
124 #define PUREBEG (char *)PURE_SEG_BITS
126 /* This variable is used only by the XPNTR macro when HAVE_SHM is
127 defined. If we used the PURESIZE macro directly there, that would
128 make most of emacs dependent on puresize.h, which we don't want -
129 you should be able to change that without too much recompilation.
130 So map_in_data initializes pure_size, and the dependencies work
133 #endif /* not HAVE_SHM */
135 /* Index in pure at which next pure object will be allocated. */
138 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
139 char *pending_malloc_warning
;
141 /* Pre-computed signal argument for use when memory is exhausted. */
142 Lisp_Object memory_signal_data
;
144 /* Maximum amount of C stack to save when a GC happens. */
146 #ifndef MAX_SAVE_STACK
147 #define MAX_SAVE_STACK 16000
150 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
151 pointer to a Lisp_Object, when that pointer is viewed as an integer.
152 (On most machines, pointers are even, so we can use the low bit.
153 Word-addressible architectures may need to override this in the m-file.)
154 When linking references to small strings through the size field, we
155 use this slot to hold the bit that would otherwise be interpreted as
157 #ifndef DONT_COPY_FLAG
158 #define DONT_COPY_FLAG 1
159 #endif /* no DONT_COPY_FLAG */
161 /* Buffer in which we save a copy of the C stack at each GC. */
166 /* Non-zero means ignore malloc warnings. Set during initialization. */
169 Lisp_Object Qgc_cons_threshold
;
171 static void mark_object (), mark_buffer (), mark_kboards ();
172 static void clear_marks (), gc_sweep ();
173 static void compact_strings ();
175 /* Versions of malloc and realloc that print warnings as memory gets full. */
178 malloc_warning_1 (str
)
181 Fprinc (str
, Vstandard_output
);
182 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
183 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
184 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
188 /* malloc calls this if it finds we are near exhausting storage */
192 pending_malloc_warning
= str
;
195 display_malloc_warning ()
197 register Lisp_Object val
;
199 val
= build_string (pending_malloc_warning
);
200 pending_malloc_warning
= 0;
201 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
204 /* Called if malloc returns zero */
208 #ifndef SYSTEM_MALLOC
209 bytes_used_when_full
= _bytes_used
;
212 /* The first time we get here, free the spare memory. */
219 /* This used to call error, but if we've run out of memory, we could get
220 infinite recursion trying to build the string. */
222 Fsignal (Qerror
, memory_signal_data
);
225 /* Called if we can't allocate relocatable space for a buffer. */
228 buffer_memory_full ()
230 /* If buffers use the relocating allocator,
231 no need to free spare_memory, because we may have plenty of malloc
232 space left that we could get, and if we don't, the malloc that fails
233 will itself cause spare_memory to be freed.
234 If buffers don't use the relocating allocator,
235 treat this like any other failing malloc. */
241 /* This used to call error, but if we've run out of memory, we could get
242 infinite recursion trying to build the string. */
244 Fsignal (Qerror
, memory_signal_data
);
247 /* like malloc routines but check for no memory and block interrupt input. */
256 val
= (long *) malloc (size
);
259 if (!val
&& size
) memory_full ();
264 xrealloc (block
, size
)
271 /* We must call malloc explicitly when BLOCK is 0, since some
272 reallocs don't do this. */
274 val
= (long *) malloc (size
);
276 val
= (long *) realloc (block
, size
);
279 if (!val
&& size
) memory_full ();
293 /* Arranging to disable input signals while we're in malloc.
295 This only works with GNU malloc. To help out systems which can't
296 use GNU malloc, all the calls to malloc, realloc, and free
297 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
298 pairs; unfortunately, we have no idea what C library functions
299 might call malloc, so we can't really protect them unless you're
300 using GNU malloc. Fortunately, most of the major operating can use
303 #ifndef SYSTEM_MALLOC
304 extern void * (*__malloc_hook
) ();
305 static void * (*old_malloc_hook
) ();
306 extern void * (*__realloc_hook
) ();
307 static void * (*old_realloc_hook
) ();
308 extern void (*__free_hook
) ();
309 static void (*old_free_hook
) ();
311 /* This function is used as the hook for free to call. */
314 emacs_blocked_free (ptr
)
318 __free_hook
= old_free_hook
;
320 /* If we released our reserve (due to running out of memory),
321 and we have a fair amount free once again,
322 try to set aside another reserve in case we run out once more. */
323 if (spare_memory
== 0
324 /* Verify there is enough space that even with the malloc
325 hysteresis this call won't run out again.
326 The code here is correct as long as SPARE_MEMORY
327 is substantially larger than the block size malloc uses. */
328 && (bytes_used_when_full
329 > _bytes_used
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
330 spare_memory
= (char *) malloc (SPARE_MEMORY
);
332 __free_hook
= emacs_blocked_free
;
336 /* If we released our reserve (due to running out of memory),
337 and we have a fair amount free once again,
338 try to set aside another reserve in case we run out once more.
340 This is called when a relocatable block is freed in ralloc.c. */
343 refill_memory_reserve ()
345 if (spare_memory
== 0)
346 spare_memory
= (char *) malloc (SPARE_MEMORY
);
349 /* This function is the malloc hook that Emacs uses. */
352 emacs_blocked_malloc (size
)
358 __malloc_hook
= old_malloc_hook
;
359 __malloc_extra_blocks
= malloc_hysteresis
;
360 value
= (void *) malloc (size
);
361 __malloc_hook
= emacs_blocked_malloc
;
368 emacs_blocked_realloc (ptr
, size
)
375 __realloc_hook
= old_realloc_hook
;
376 value
= (void *) realloc (ptr
, size
);
377 __realloc_hook
= emacs_blocked_realloc
;
384 uninterrupt_malloc ()
386 old_free_hook
= __free_hook
;
387 __free_hook
= emacs_blocked_free
;
389 old_malloc_hook
= __malloc_hook
;
390 __malloc_hook
= emacs_blocked_malloc
;
392 old_realloc_hook
= __realloc_hook
;
393 __realloc_hook
= emacs_blocked_realloc
;
397 /* Interval allocation. */
399 #ifdef USE_TEXT_PROPERTIES
400 #define INTERVAL_BLOCK_SIZE \
401 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
403 struct interval_block
405 struct interval_block
*next
;
406 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
409 struct interval_block
*interval_block
;
410 static int interval_block_index
;
412 INTERVAL interval_free_list
;
417 allocating_for_lisp
= 1;
419 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
420 allocating_for_lisp
= 0;
421 interval_block
->next
= 0;
422 bzero (interval_block
->intervals
, sizeof interval_block
->intervals
);
423 interval_block_index
= 0;
424 interval_free_list
= 0;
427 #define INIT_INTERVALS init_intervals ()
434 if (interval_free_list
)
436 val
= interval_free_list
;
437 interval_free_list
= interval_free_list
->parent
;
441 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
443 register struct interval_block
*newi
;
445 allocating_for_lisp
= 1;
446 newi
= (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
448 allocating_for_lisp
= 0;
449 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
450 newi
->next
= interval_block
;
451 interval_block
= newi
;
452 interval_block_index
= 0;
454 val
= &interval_block
->intervals
[interval_block_index
++];
456 consing_since_gc
+= sizeof (struct interval
);
458 RESET_INTERVAL (val
);
462 static int total_free_intervals
, total_intervals
;
464 /* Mark the pointers of one interval. */
467 mark_interval (i
, dummy
)
471 if (XMARKBIT (i
->plist
))
473 mark_object (&i
->plist
);
478 mark_interval_tree (tree
)
479 register INTERVAL tree
;
481 /* No need to test if this tree has been marked already; this
482 function is always called through the MARK_INTERVAL_TREE macro,
483 which takes care of that. */
485 /* XMARK expands to an assignment; the LHS of an assignment can't be
487 XMARK (* (Lisp_Object
*) &tree
->parent
);
489 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
492 #define MARK_INTERVAL_TREE(i) \
494 if (!NULL_INTERVAL_P (i) \
495 && ! XMARKBIT ((Lisp_Object) i->parent)) \
496 mark_interval_tree (i); \
499 /* The oddity in the call to XUNMARK is necessary because XUNMARK
500 expands to an assignment to its argument, and most C compilers don't
501 support casts on the left operand of `='. */
502 #define UNMARK_BALANCE_INTERVALS(i) \
504 if (! NULL_INTERVAL_P (i)) \
506 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
507 (i) = balance_intervals (i); \
511 #else /* no interval use */
513 #define INIT_INTERVALS
515 #define UNMARK_BALANCE_INTERVALS(i)
516 #define MARK_INTERVAL_TREE(i)
518 #endif /* no interval use */
520 /* Floating point allocation. */
522 #ifdef LISP_FLOAT_TYPE
523 /* Allocation of float cells, just like conses */
524 /* We store float cells inside of float_blocks, allocating a new
525 float_block with malloc whenever necessary. Float cells reclaimed by
526 GC are put on a free list to be reallocated before allocating
527 any new float cells from the latest float_block.
529 Each float_block is just under 1020 bytes long,
530 since malloc really allocates in units of powers of two
531 and uses 4 bytes for its own overhead. */
533 #define FLOAT_BLOCK_SIZE \
534 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
538 struct float_block
*next
;
539 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
542 struct float_block
*float_block
;
543 int float_block_index
;
545 struct Lisp_Float
*float_free_list
;
550 allocating_for_lisp
= 1;
551 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
552 allocating_for_lisp
= 0;
553 float_block
->next
= 0;
554 bzero (float_block
->floats
, sizeof float_block
->floats
);
555 float_block_index
= 0;
559 /* Explicitly free a float cell. */
561 struct Lisp_Float
*ptr
;
563 *(struct Lisp_Float
**)&ptr
->type
= float_free_list
;
564 float_free_list
= ptr
;
568 make_float (float_value
)
571 register Lisp_Object val
;
575 XSETFLOAT (val
, float_free_list
);
576 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->type
;
580 if (float_block_index
== FLOAT_BLOCK_SIZE
)
582 register struct float_block
*new;
584 allocating_for_lisp
= 1;
585 new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
586 allocating_for_lisp
= 0;
587 VALIDATE_LISP_STORAGE (new, sizeof *new);
588 new->next
= float_block
;
590 float_block_index
= 0;
592 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
594 XFLOAT (val
)->data
= float_value
;
595 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
596 consing_since_gc
+= sizeof (struct Lisp_Float
);
601 #endif /* LISP_FLOAT_TYPE */
603 /* Allocation of cons cells */
604 /* We store cons cells inside of cons_blocks, allocating a new
605 cons_block with malloc whenever necessary. Cons cells reclaimed by
606 GC are put on a free list to be reallocated before allocating
607 any new cons cells from the latest cons_block.
609 Each cons_block is just under 1020 bytes long,
610 since malloc really allocates in units of powers of two
611 and uses 4 bytes for its own overhead. */
613 #define CONS_BLOCK_SIZE \
614 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
618 struct cons_block
*next
;
619 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
622 struct cons_block
*cons_block
;
623 int cons_block_index
;
625 struct Lisp_Cons
*cons_free_list
;
630 allocating_for_lisp
= 1;
631 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
632 allocating_for_lisp
= 0;
633 cons_block
->next
= 0;
634 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
635 cons_block_index
= 0;
639 /* Explicitly free a cons cell. */
641 struct Lisp_Cons
*ptr
;
643 *(struct Lisp_Cons
**)&ptr
->car
= cons_free_list
;
644 cons_free_list
= ptr
;
647 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
648 "Create a new cons, give it CAR and CDR as components, and return it.")
650 Lisp_Object car
, cdr
;
652 register Lisp_Object val
;
656 XSETCONS (val
, cons_free_list
);
657 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->car
;
661 if (cons_block_index
== CONS_BLOCK_SIZE
)
663 register struct cons_block
*new;
664 allocating_for_lisp
= 1;
665 new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
666 allocating_for_lisp
= 0;
667 VALIDATE_LISP_STORAGE (new, sizeof *new);
668 new->next
= cons_block
;
670 cons_block_index
= 0;
672 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
674 XCONS (val
)->car
= car
;
675 XCONS (val
)->cdr
= cdr
;
676 consing_since_gc
+= sizeof (struct Lisp_Cons
);
681 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
682 "Return a newly created list with specified arguments as elements.\n\
683 Any number of arguments, even zero arguments, are allowed.")
686 register Lisp_Object
*args
;
688 register Lisp_Object val
= Qnil
;
691 val
= Fcons (args
[nargs
], val
);
695 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
696 "Return a newly created list of length LENGTH, with each element being INIT.")
698 register Lisp_Object length
, init
;
700 register Lisp_Object val
;
703 CHECK_NATNUM (length
, 0);
704 size
= XFASTINT (length
);
708 val
= Fcons (init
, val
);
712 /* Allocation of vectors */
714 struct Lisp_Vector
*all_vectors
;
717 allocate_vectorlike (len
)
720 struct Lisp_Vector
*p
;
722 allocating_for_lisp
= 1;
723 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
724 + (len
- 1) * sizeof (Lisp_Object
));
725 allocating_for_lisp
= 0;
726 VALIDATE_LISP_STORAGE (p
, 0);
727 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
728 + (len
- 1) * sizeof (Lisp_Object
));
729 vector_cells_consed
+= len
;
731 p
->next
= all_vectors
;
736 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
737 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
738 See also the function `vector'.")
740 register Lisp_Object length
, init
;
743 register EMACS_INT sizei
;
745 register struct Lisp_Vector
*p
;
747 CHECK_NATNUM (length
, 0);
748 sizei
= XFASTINT (length
);
750 p
= allocate_vectorlike (sizei
);
752 for (index
= 0; index
< sizei
; index
++)
753 p
->contents
[index
] = init
;
755 XSETVECTOR (vector
, p
);
759 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 0, 2, 0,
760 "Return a newly created char-table, with N \"extra\" slots.\n\
761 Each element is initialized to INIT, which defaults to nil.\n\
762 N may not be more than ten.\n\
763 See `char-table-extra-slot' and `set-char-table-extra-slot'.")
765 register Lisp_Object n
, init
;
769 if (XINT (n
) < 0 || XINT (n
) > 10)
770 args_out_of_range (n
, Qnil
);
771 /* Add 2 to the size for the defalt and parent slots. */
772 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
774 XCHAR_TABLE (vector
)->parent
= Qnil
;
775 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
779 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
780 "Return a newly created vector with specified arguments as elements.\n\
781 Any number of arguments, even zero arguments, are allowed.")
786 register Lisp_Object len
, val
;
788 register struct Lisp_Vector
*p
;
790 XSETFASTINT (len
, nargs
);
791 val
= Fmake_vector (len
, Qnil
);
793 for (index
= 0; index
< nargs
; index
++)
794 p
->contents
[index
] = args
[index
];
798 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
799 "Create a byte-code object with specified arguments as elements.\n\
800 The arguments should be the arglist, bytecode-string, constant vector,\n\
801 stack size, (optional) doc string, and (optional) interactive spec.\n\
802 The first four arguments are required; at most six have any\n\
808 register Lisp_Object len
, val
;
810 register struct Lisp_Vector
*p
;
812 XSETFASTINT (len
, nargs
);
813 if (!NILP (Vpurify_flag
))
814 val
= make_pure_vector (len
);
816 val
= Fmake_vector (len
, Qnil
);
818 for (index
= 0; index
< nargs
; index
++)
820 if (!NILP (Vpurify_flag
))
821 args
[index
] = Fpurecopy (args
[index
]);
822 p
->contents
[index
] = args
[index
];
824 XSETCOMPILED (val
, val
);
828 /* Allocation of symbols.
829 Just like allocation of conses!
831 Each symbol_block is just under 1020 bytes long,
832 since malloc really allocates in units of powers of two
833 and uses 4 bytes for its own overhead. */
835 #define SYMBOL_BLOCK_SIZE \
836 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
840 struct symbol_block
*next
;
841 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
844 struct symbol_block
*symbol_block
;
845 int symbol_block_index
;
847 struct Lisp_Symbol
*symbol_free_list
;
852 allocating_for_lisp
= 1;
853 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
854 allocating_for_lisp
= 0;
855 symbol_block
->next
= 0;
856 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
857 symbol_block_index
= 0;
858 symbol_free_list
= 0;
861 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
862 "Return a newly allocated uninterned symbol whose name is NAME.\n\
863 Its value and function definition are void, and its property list is nil.")
867 register Lisp_Object val
;
868 register struct Lisp_Symbol
*p
;
870 CHECK_STRING (str
, 0);
872 if (symbol_free_list
)
874 XSETSYMBOL (val
, symbol_free_list
);
875 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
879 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
881 struct symbol_block
*new;
882 allocating_for_lisp
= 1;
883 new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
884 allocating_for_lisp
= 0;
885 VALIDATE_LISP_STORAGE (new, sizeof *new);
886 new->next
= symbol_block
;
888 symbol_block_index
= 0;
890 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
893 p
->name
= XSTRING (str
);
896 p
->function
= Qunbound
;
898 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
903 /* Allocation of markers and other objects that share that structure.
904 Works like allocation of conses. */
906 #define MARKER_BLOCK_SIZE \
907 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
911 struct marker_block
*next
;
912 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
915 struct marker_block
*marker_block
;
916 int marker_block_index
;
918 union Lisp_Misc
*marker_free_list
;
923 allocating_for_lisp
= 1;
924 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
925 allocating_for_lisp
= 0;
926 marker_block
->next
= 0;
927 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
928 marker_block_index
= 0;
929 marker_free_list
= 0;
932 /* Return a newly allocated Lisp_Misc object, with no substructure. */
938 if (marker_free_list
)
940 XSETMISC (val
, marker_free_list
);
941 marker_free_list
= marker_free_list
->u_free
.chain
;
945 if (marker_block_index
== MARKER_BLOCK_SIZE
)
947 struct marker_block
*new;
948 allocating_for_lisp
= 1;
949 new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
950 allocating_for_lisp
= 0;
951 VALIDATE_LISP_STORAGE (new, sizeof *new);
952 new->next
= marker_block
;
954 marker_block_index
= 0;
956 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
958 consing_since_gc
+= sizeof (union Lisp_Misc
);
959 misc_objects_consed
++;
963 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
964 "Return a newly allocated marker which does not point at any place.")
967 register Lisp_Object val
;
968 register struct Lisp_Marker
*p
;
970 val
= allocate_misc ();
971 XMISCTYPE (val
) = Lisp_Misc_Marker
;
976 p
->insertion_type
= 0;
980 /* Allocation of strings */
982 /* Strings reside inside of string_blocks. The entire data of the string,
983 both the size and the contents, live in part of the `chars' component of a string_block.
984 The `pos' component is the index within `chars' of the first free byte.
986 first_string_block points to the first string_block ever allocated.
987 Each block points to the next one with its `next' field.
988 The `prev' fields chain in reverse order.
989 The last one allocated is the one currently being filled.
990 current_string_block points to it.
992 The string_blocks that hold individual large strings
993 go in a separate chain, started by large_string_blocks. */
996 /* String blocks contain this many useful bytes.
997 8188 is power of 2, minus 4 for malloc overhead. */
998 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
1000 /* A string bigger than this gets its own specially-made string block
1001 if it doesn't fit in the current one. */
1002 #define STRING_BLOCK_OUTSIZE 1024
1004 struct string_block_head
1006 struct string_block
*next
, *prev
;
1012 struct string_block
*next
, *prev
;
1014 char chars
[STRING_BLOCK_SIZE
];
1017 /* This points to the string block we are now allocating strings. */
1019 struct string_block
*current_string_block
;
1021 /* This points to the oldest string block, the one that starts the chain. */
1023 struct string_block
*first_string_block
;
1025 /* Last string block in chain of those made for individual large strings. */
1027 struct string_block
*large_string_blocks
;
1029 /* If SIZE is the length of a string, this returns how many bytes
1030 the string occupies in a string_block (including padding). */
1032 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
1034 #define PAD (sizeof (EMACS_INT))
1037 #define STRING_FULLSIZE(SIZE) \
1038 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
1044 allocating_for_lisp
= 1;
1045 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
1046 allocating_for_lisp
= 0;
1047 first_string_block
= current_string_block
;
1048 consing_since_gc
+= sizeof (struct string_block
);
1049 current_string_block
->next
= 0;
1050 current_string_block
->prev
= 0;
1051 current_string_block
->pos
= 0;
1052 large_string_blocks
= 0;
1055 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1056 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1057 Both LENGTH and INIT must be numbers.")
1059 Lisp_Object length
, init
;
1061 register Lisp_Object val
;
1062 register unsigned char *p
, *end
, c
;
1064 CHECK_NATNUM (length
, 0);
1065 CHECK_NUMBER (init
, 1);
1066 val
= make_uninit_string (XFASTINT (length
));
1068 p
= XSTRING (val
)->data
;
1069 end
= p
+ XSTRING (val
)->size
;
1076 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1077 "Return a newly created bitstring of length LENGTH, with INIT as each element.\n\
1078 Both LENGTH and INIT must be numbers. INIT matters only in whether it is t or nil.")
1080 Lisp_Object length
, init
;
1082 register Lisp_Object val
;
1083 struct Lisp_Bool_Vector
*p
;
1085 int length_in_chars
, length_in_elts
, bits_per_value
;
1087 CHECK_NATNUM (length
, 0);
1089 bits_per_value
= sizeof (EMACS_INT
) * INTBITS
/ sizeof (int);
1091 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1092 length_in_chars
= length_in_elts
* sizeof (EMACS_INT
);
1094 val
= Fmake_vector (make_number (length_in_elts
), Qnil
);
1095 p
= XBOOL_VECTOR (val
);
1096 /* Get rid of any bits that would cause confusion. */
1098 XSETBOOL_VECTOR (val
, p
);
1099 p
->size
= XFASTINT (length
);
1101 real_init
= (NILP (init
) ? 0 : -1);
1102 for (i
= 0; i
< length_in_chars
; i
++)
1103 p
->data
[i
] = real_init
;
1109 make_string (contents
, length
)
1113 register Lisp_Object val
;
1114 val
= make_uninit_string (length
);
1115 bcopy (contents
, XSTRING (val
)->data
, length
);
1123 return make_string (str
, strlen (str
));
1127 make_uninit_string (length
)
1130 register Lisp_Object val
;
1131 register int fullsize
= STRING_FULLSIZE (length
);
1133 if (length
< 0) abort ();
1135 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1136 /* This string can fit in the current string block */
1139 ((struct Lisp_String
*)
1140 (current_string_block
->chars
+ current_string_block
->pos
)));
1141 current_string_block
->pos
+= fullsize
;
1143 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1144 /* This string gets its own string block */
1146 register struct string_block
*new;
1147 allocating_for_lisp
= 1;
1148 new = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
1149 allocating_for_lisp
= 0;
1150 VALIDATE_LISP_STORAGE (new, 0);
1151 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1152 new->pos
= fullsize
;
1153 new->next
= large_string_blocks
;
1154 large_string_blocks
= new;
1156 ((struct Lisp_String
*)
1157 ((struct string_block_head
*)new + 1)));
1160 /* Make a new current string block and start it off with this string */
1162 register struct string_block
*new;
1163 allocating_for_lisp
= 1;
1164 new = (struct string_block
*) xmalloc (sizeof (struct string_block
));
1165 allocating_for_lisp
= 0;
1166 VALIDATE_LISP_STORAGE (new, sizeof *new);
1167 consing_since_gc
+= sizeof (struct string_block
);
1168 current_string_block
->next
= new;
1169 new->prev
= current_string_block
;
1171 current_string_block
= new;
1172 new->pos
= fullsize
;
1174 (struct Lisp_String
*) current_string_block
->chars
);
1177 string_chars_consed
+= fullsize
;
1178 XSTRING (val
)->size
= length
;
1179 XSTRING (val
)->data
[length
] = 0;
1180 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1185 /* Return a newly created vector or string with specified arguments as
1186 elements. If all the arguments are characters that can fit
1187 in a string of events, make a string; otherwise, make a vector.
1189 Any number of arguments, even zero arguments, are allowed. */
1192 make_event_array (nargs
, args
)
1198 for (i
= 0; i
< nargs
; i
++)
1199 /* The things that fit in a string
1200 are characters that are in 0...127,
1201 after discarding the meta bit and all the bits above it. */
1202 if (!INTEGERP (args
[i
])
1203 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1204 return Fvector (nargs
, args
);
1206 /* Since the loop exited, we know that all the things in it are
1207 characters, so we can make a string. */
1211 result
= Fmake_string (nargs
, make_number (0));
1212 for (i
= 0; i
< nargs
; i
++)
1214 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1215 /* Move the meta bit to the right place for a string char. */
1216 if (XINT (args
[i
]) & CHAR_META
)
1217 XSTRING (result
)->data
[i
] |= 0x80;
1224 /* Pure storage management. */
1226 /* Must get an error if pure storage is full,
1227 since if it cannot hold a large string
1228 it may be able to hold conses that point to that string;
1229 then the string is not protected from gc. */
1232 make_pure_string (data
, length
)
1236 register Lisp_Object
new;
1237 register int size
= sizeof (EMACS_INT
) + INTERVAL_PTR_SIZE
+ length
+ 1;
1239 if (pureptr
+ size
> PURESIZE
)
1240 error ("Pure Lisp storage exhausted");
1241 XSETSTRING (new, PUREBEG
+ pureptr
);
1242 XSTRING (new)->size
= length
;
1243 bcopy (data
, XSTRING (new)->data
, length
);
1244 XSTRING (new)->data
[length
] = 0;
1246 /* We must give strings in pure storage some kind of interval. So we
1247 give them a null one. */
1248 #if defined (USE_TEXT_PROPERTIES)
1249 XSTRING (new)->intervals
= NULL_INTERVAL
;
1251 pureptr
+= (size
+ sizeof (EMACS_INT
) - 1)
1252 / sizeof (EMACS_INT
) * sizeof (EMACS_INT
);
1257 pure_cons (car
, cdr
)
1258 Lisp_Object car
, cdr
;
1260 register Lisp_Object
new;
1262 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1263 error ("Pure Lisp storage exhausted");
1264 XSETCONS (new, PUREBEG
+ pureptr
);
1265 pureptr
+= sizeof (struct Lisp_Cons
);
1266 XCONS (new)->car
= Fpurecopy (car
);
1267 XCONS (new)->cdr
= Fpurecopy (cdr
);
1271 #ifdef LISP_FLOAT_TYPE
1274 make_pure_float (num
)
1277 register Lisp_Object
new;
1279 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1280 (double) boundary. Some architectures (like the sparc) require
1281 this, and I suspect that floats are rare enough that it's no
1282 tragedy for those that do. */
1285 char *p
= PUREBEG
+ pureptr
;
1289 alignment
= __alignof (struct Lisp_Float
);
1291 alignment
= sizeof (struct Lisp_Float
);
1294 alignment
= sizeof (struct Lisp_Float
);
1296 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1297 pureptr
= p
- PUREBEG
;
1300 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1301 error ("Pure Lisp storage exhausted");
1302 XSETFLOAT (new, PUREBEG
+ pureptr
);
1303 pureptr
+= sizeof (struct Lisp_Float
);
1304 XFLOAT (new)->data
= num
;
1305 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1309 #endif /* LISP_FLOAT_TYPE */
1312 make_pure_vector (len
)
1315 register Lisp_Object
new;
1316 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1318 if (pureptr
+ size
> PURESIZE
)
1319 error ("Pure Lisp storage exhausted");
1321 XSETVECTOR (new, PUREBEG
+ pureptr
);
1323 XVECTOR (new)->size
= len
;
1327 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1328 "Make a copy of OBJECT in pure storage.\n\
1329 Recursively copies contents of vectors and cons cells.\n\
1330 Does not copy symbols.")
1332 register Lisp_Object obj
;
1334 if (NILP (Vpurify_flag
))
1337 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1338 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1342 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1343 #ifdef LISP_FLOAT_TYPE
1344 else if (FLOATP (obj
))
1345 return make_pure_float (XFLOAT (obj
)->data
);
1346 #endif /* LISP_FLOAT_TYPE */
1347 else if (STRINGP (obj
))
1348 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1349 else if (COMPILEDP (obj
) || VECTORP (obj
))
1351 register struct Lisp_Vector
*vec
;
1352 register int i
, size
;
1354 size
= XVECTOR (obj
)->size
;
1355 if (size
& PSEUDOVECTOR_FLAG
)
1356 size
&= PSEUDOVECTOR_SIZE_MASK
;
1357 vec
= XVECTOR (make_pure_vector (size
));
1358 for (i
= 0; i
< size
; i
++)
1359 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1360 if (COMPILEDP (obj
))
1361 XSETCOMPILED (obj
, vec
);
1363 XSETVECTOR (obj
, vec
);
1366 else if (MARKERP (obj
))
1367 error ("Attempt to copy a marker to pure storage");
1372 /* Recording what needs to be marked for gc. */
1374 struct gcpro
*gcprolist
;
1376 #define NSTATICS 768
1378 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1382 /* Put an entry in staticvec, pointing at the variable whose address is given */
1385 staticpro (varaddress
)
1386 Lisp_Object
*varaddress
;
1388 staticvec
[staticidx
++] = varaddress
;
1389 if (staticidx
>= NSTATICS
)
1397 struct catchtag
*next
;
1398 /* jmp_buf jmp; /* We don't need this for GC purposes */
1403 struct backtrace
*next
;
1404 Lisp_Object
*function
;
1405 Lisp_Object
*args
; /* Points to vector of args. */
1406 int nargs
; /* length of vector */
1407 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1411 /* Garbage collection! */
1413 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1414 int total_free_conses
, total_free_markers
, total_free_symbols
;
1415 #ifdef LISP_FLOAT_TYPE
1416 int total_free_floats
, total_floats
;
1417 #endif /* LISP_FLOAT_TYPE */
1419 /* Temporarily prevent garbage collection. */
1422 inhibit_garbage_collection ()
1424 int count
= specpdl_ptr
- specpdl
;
1426 int nbits
= min (VALBITS
, INTBITS
);
1428 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1430 specbind (Qgc_cons_threshold
, number
);
1435 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1436 "Reclaim storage for Lisp objects no longer needed.\n\
1437 Returns info on amount of space in use:\n\
1438 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1439 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1440 (USED-FLOATS . FREE-FLOATS))\n\
1441 Garbage collection happens automatically if you cons more than\n\
1442 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1445 register struct gcpro
*tail
;
1446 register struct specbinding
*bind
;
1447 struct catchtag
*catch;
1448 struct handler
*handler
;
1449 register struct backtrace
*backlist
;
1450 register Lisp_Object tem
;
1451 char *omessage
= echo_area_glyphs
;
1452 int omessage_length
= echo_area_glyphs_length
;
1453 char stack_top_variable
;
1456 /* In case user calls debug_print during GC,
1457 don't let that cause a recursive GC. */
1458 consing_since_gc
= 0;
1460 /* Save a copy of the contents of the stack, for debugging. */
1461 #if MAX_SAVE_STACK > 0
1462 if (NILP (Vpurify_flag
))
1464 i
= &stack_top_variable
- stack_bottom
;
1466 if (i
< MAX_SAVE_STACK
)
1468 if (stack_copy
== 0)
1469 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1470 else if (stack_copy_size
< i
)
1471 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1474 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1475 bcopy (stack_bottom
, stack_copy
, i
);
1477 bcopy (&stack_top_variable
, stack_copy
, i
);
1481 #endif /* MAX_SAVE_STACK > 0 */
1483 if (!noninteractive
)
1484 message1_nolog ("Garbage collecting...");
1486 /* Don't keep command history around forever */
1487 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1489 XCONS (tem
)->cdr
= Qnil
;
1491 /* Likewise for undo information. */
1493 register struct buffer
*nextb
= all_buffers
;
1497 /* If a buffer's undo list is Qt, that means that undo is
1498 turned off in that buffer. Calling truncate_undo_list on
1499 Qt tends to return NULL, which effectively turns undo back on.
1500 So don't call truncate_undo_list if undo_list is Qt. */
1501 if (! EQ (nextb
->undo_list
, Qt
))
1503 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1505 nextb
= nextb
->next
;
1511 /* clear_marks (); */
1513 /* In each "large string", set the MARKBIT of the size field.
1514 That enables mark_object to recognize them. */
1516 register struct string_block
*b
;
1517 for (b
= large_string_blocks
; b
; b
= b
->next
)
1518 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1521 /* Mark all the special slots that serve as the roots of accessibility.
1523 Usually the special slots to mark are contained in particular structures.
1524 Then we know no slot is marked twice because the structures don't overlap.
1525 In some cases, the structures point to the slots to be marked.
1526 For these, we use MARKBIT to avoid double marking of the slot. */
1528 for (i
= 0; i
< staticidx
; i
++)
1529 mark_object (staticvec
[i
]);
1530 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1531 for (i
= 0; i
< tail
->nvars
; i
++)
1532 if (!XMARKBIT (tail
->var
[i
]))
1534 mark_object (&tail
->var
[i
]);
1535 XMARK (tail
->var
[i
]);
1537 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1539 mark_object (&bind
->symbol
);
1540 mark_object (&bind
->old_value
);
1542 for (catch = catchlist
; catch; catch = catch->next
)
1544 mark_object (&catch->tag
);
1545 mark_object (&catch->val
);
1547 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1549 mark_object (&handler
->handler
);
1550 mark_object (&handler
->var
);
1552 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1554 if (!XMARKBIT (*backlist
->function
))
1556 mark_object (backlist
->function
);
1557 XMARK (*backlist
->function
);
1559 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1562 i
= backlist
->nargs
- 1;
1564 if (!XMARKBIT (backlist
->args
[i
]))
1566 mark_object (&backlist
->args
[i
]);
1567 XMARK (backlist
->args
[i
]);
1574 /* Clear the mark bits that we set in certain root slots. */
1576 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1577 for (i
= 0; i
< tail
->nvars
; i
++)
1578 XUNMARK (tail
->var
[i
]);
1579 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1581 XUNMARK (*backlist
->function
);
1582 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1585 i
= backlist
->nargs
- 1;
1587 XUNMARK (backlist
->args
[i
]);
1589 XUNMARK (buffer_defaults
.name
);
1590 XUNMARK (buffer_local_symbols
.name
);
1592 /* clear_marks (); */
1595 consing_since_gc
= 0;
1596 if (gc_cons_threshold
< 10000)
1597 gc_cons_threshold
= 10000;
1599 if (omessage
|| minibuf_level
> 0)
1600 message2_nolog (omessage
, omessage_length
);
1601 else if (!noninteractive
)
1602 message1_nolog ("Garbage collecting...done");
1604 return Fcons (Fcons (make_number (total_conses
),
1605 make_number (total_free_conses
)),
1606 Fcons (Fcons (make_number (total_symbols
),
1607 make_number (total_free_symbols
)),
1608 Fcons (Fcons (make_number (total_markers
),
1609 make_number (total_free_markers
)),
1610 Fcons (make_number (total_string_size
),
1611 Fcons (make_number (total_vector_size
),
1613 #ifdef LISP_FLOAT_TYPE
1614 Fcons (Fcons (make_number (total_floats
),
1615 make_number (total_free_floats
)),
1617 #else /* not LISP_FLOAT_TYPE */
1619 #endif /* not LISP_FLOAT_TYPE */
1627 /* Clear marks on all conses */
1629 register struct cons_block
*cblk
;
1630 register int lim
= cons_block_index
;
1632 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1635 for (i
= 0; i
< lim
; i
++)
1636 XUNMARK (cblk
->conses
[i
].car
);
1637 lim
= CONS_BLOCK_SIZE
;
1640 /* Clear marks on all symbols */
1642 register struct symbol_block
*sblk
;
1643 register int lim
= symbol_block_index
;
1645 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1648 for (i
= 0; i
< lim
; i
++)
1650 XUNMARK (sblk
->symbols
[i
].plist
);
1652 lim
= SYMBOL_BLOCK_SIZE
;
1655 /* Clear marks on all markers */
1657 register struct marker_block
*sblk
;
1658 register int lim
= marker_block_index
;
1660 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1663 for (i
= 0; i
< lim
; i
++)
1664 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1665 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1666 lim
= MARKER_BLOCK_SIZE
;
1669 /* Clear mark bits on all buffers */
1671 register struct buffer
*nextb
= all_buffers
;
1675 XUNMARK (nextb
->name
);
1676 nextb
= nextb
->next
;
1682 /* Mark reference to a Lisp_Object.
1683 If the object referred to has not been seen yet, recursively mark
1684 all the references contained in it.
1686 If the object referenced is a short string, the referencing slot
1687 is threaded into a chain of such slots, pointed to from
1688 the `size' field of the string. The actual string size
1689 lives in the last slot in the chain. We recognize the end
1690 because it is < (unsigned) STRING_BLOCK_SIZE. */
1692 #define LAST_MARKED_SIZE 500
1693 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1694 int last_marked_index
;
1697 mark_object (objptr
)
1698 Lisp_Object
*objptr
;
1700 register Lisp_Object obj
;
1707 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1708 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1711 last_marked
[last_marked_index
++] = objptr
;
1712 if (last_marked_index
== LAST_MARKED_SIZE
)
1713 last_marked_index
= 0;
1715 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
1719 register struct Lisp_String
*ptr
= XSTRING (obj
);
1721 MARK_INTERVAL_TREE (ptr
->intervals
);
1722 if (ptr
->size
& MARKBIT
)
1723 /* A large string. Just set ARRAY_MARK_FLAG. */
1724 ptr
->size
|= ARRAY_MARK_FLAG
;
1727 /* A small string. Put this reference
1728 into the chain of references to it.
1729 If the address includes MARKBIT, put that bit elsewhere
1730 when we store OBJPTR into the size field. */
1732 if (XMARKBIT (*objptr
))
1734 XSETFASTINT (*objptr
, ptr
->size
);
1738 XSETFASTINT (*objptr
, ptr
->size
);
1740 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
1742 ptr
->size
= (EMACS_INT
) objptr
;
1743 if (ptr
->size
& MARKBIT
)
1744 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
1749 case Lisp_Vectorlike
:
1750 if (GC_BUFFERP (obj
))
1752 if (!XMARKBIT (XBUFFER (obj
)->name
))
1755 else if (GC_SUBRP (obj
))
1757 else if (GC_COMPILEDP (obj
))
1758 /* We could treat this just like a vector, but it is better
1759 to save the COMPILED_CONSTANTS element for last and avoid recursion
1762 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1763 register EMACS_INT size
= ptr
->size
;
1764 /* See comment above under Lisp_Vector. */
1765 struct Lisp_Vector
*volatile ptr1
= ptr
;
1768 if (size
& ARRAY_MARK_FLAG
)
1769 break; /* Already marked */
1770 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1771 size
&= PSEUDOVECTOR_SIZE_MASK
;
1772 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1774 if (i
!= COMPILED_CONSTANTS
)
1775 mark_object (&ptr1
->contents
[i
]);
1777 /* This cast should be unnecessary, but some Mips compiler complains
1778 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1779 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1783 else if (GC_FRAMEP (obj
))
1785 /* See comment above under Lisp_Vector for why this is volatile. */
1786 register struct frame
*volatile ptr
= XFRAME (obj
);
1787 register EMACS_INT size
= ptr
->size
;
1789 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1790 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1792 mark_object (&ptr
->name
);
1793 mark_object (&ptr
->icon_name
);
1794 mark_object (&ptr
->focus_frame
);
1795 mark_object (&ptr
->selected_window
);
1796 mark_object (&ptr
->minibuffer_window
);
1797 mark_object (&ptr
->param_alist
);
1798 mark_object (&ptr
->scroll_bars
);
1799 mark_object (&ptr
->condemned_scroll_bars
);
1800 mark_object (&ptr
->menu_bar_items
);
1801 mark_object (&ptr
->face_alist
);
1802 mark_object (&ptr
->menu_bar_vector
);
1803 mark_object (&ptr
->buffer_predicate
);
1805 #endif /* MULTI_FRAME */
1806 else if (GC_BOOL_VECTOR_P (obj
))
1810 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1811 register EMACS_INT size
= ptr
->size
;
1812 /* The reason we use ptr1 is to avoid an apparent hardware bug
1813 that happens occasionally on the FSF's HP 300s.
1814 The bug is that a2 gets clobbered by recursive calls to mark_object.
1815 The clobberage seems to happen during function entry,
1816 perhaps in the moveml instruction.
1817 Yes, this is a crock, but we have to do it. */
1818 struct Lisp_Vector
*volatile ptr1
= ptr
;
1821 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1822 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1823 if (size
& PSEUDOVECTOR_FLAG
)
1824 size
&= PSEUDOVECTOR_SIZE_MASK
;
1825 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1826 mark_object (&ptr1
->contents
[i
]);
1832 /* See comment above under Lisp_Vector for why this is volatile. */
1833 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1834 struct Lisp_Symbol
*ptrx
;
1836 if (XMARKBIT (ptr
->plist
)) break;
1838 mark_object ((Lisp_Object
*) &ptr
->value
);
1839 mark_object (&ptr
->function
);
1840 mark_object (&ptr
->plist
);
1841 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1842 mark_object (&ptr
->name
);
1846 /* For the benefit of the last_marked log. */
1847 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1848 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1849 XSETSYMBOL (obj
, ptrx
);
1850 /* We can't goto loop here because *objptr doesn't contain an
1851 actual Lisp_Object with valid datatype field. */
1858 switch (XMISCTYPE (obj
))
1860 case Lisp_Misc_Marker
:
1861 XMARK (XMARKER (obj
)->chain
);
1862 /* DO NOT mark thru the marker's chain.
1863 The buffer's markers chain does not preserve markers from gc;
1864 instead, markers are removed from the chain when freed by gc. */
1867 case Lisp_Misc_Buffer_Local_Value
:
1868 case Lisp_Misc_Some_Buffer_Local_Value
:
1870 register struct Lisp_Buffer_Local_Value
*ptr
1871 = XBUFFER_LOCAL_VALUE (obj
);
1872 if (XMARKBIT (ptr
->car
)) break;
1874 /* If the cdr is nil, avoid recursion for the car. */
1875 if (EQ (ptr
->cdr
, Qnil
))
1880 mark_object (&ptr
->car
);
1881 /* See comment above under Lisp_Vector for why not use ptr here. */
1882 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
1886 case Lisp_Misc_Intfwd
:
1887 case Lisp_Misc_Boolfwd
:
1888 case Lisp_Misc_Objfwd
:
1889 case Lisp_Misc_Buffer_Objfwd
:
1890 case Lisp_Misc_Kboard_Objfwd
:
1891 /* Don't bother with Lisp_Buffer_Objfwd,
1892 since all markable slots in current buffer marked anyway. */
1893 /* Don't need to do Lisp_Objfwd, since the places they point
1894 are protected with staticpro. */
1897 case Lisp_Misc_Overlay
:
1899 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
1900 if (!XMARKBIT (ptr
->plist
))
1903 mark_object (&ptr
->start
);
1904 mark_object (&ptr
->end
);
1905 objptr
= &ptr
->plist
;
1918 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1919 if (XMARKBIT (ptr
->car
)) break;
1921 /* If the cdr is nil, avoid recursion for the car. */
1922 if (EQ (ptr
->cdr
, Qnil
))
1927 mark_object (&ptr
->car
);
1928 /* See comment above under Lisp_Vector for why not use ptr here. */
1929 objptr
= &XCONS (obj
)->cdr
;
1933 #ifdef LISP_FLOAT_TYPE
1935 XMARK (XFLOAT (obj
)->type
);
1937 #endif /* LISP_FLOAT_TYPE */
1947 /* Mark the pointers in a buffer structure. */
1953 register struct buffer
*buffer
= XBUFFER (buf
);
1954 register Lisp_Object
*ptr
;
1955 Lisp_Object base_buffer
;
1957 /* This is the buffer's markbit */
1958 mark_object (&buffer
->name
);
1959 XMARK (buffer
->name
);
1961 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
1964 mark_object (buffer
->syntax_table
);
1966 /* Mark the various string-pointers in the buffer object.
1967 Since the strings may be relocated, we must mark them
1968 in their actual slots. So gc_sweep must convert each slot
1969 back to an ordinary C pointer. */
1970 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
1971 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1972 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
1973 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1975 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
1976 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1977 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
1978 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1981 for (ptr
= &buffer
->name
+ 1;
1982 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1986 /* If this is an indirect buffer, mark its base buffer. */
1987 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
1989 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
1990 mark_buffer (base_buffer
);
1995 /* Mark the pointers in the kboard objects. */
2002 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2004 if (kb
->kbd_macro_buffer
)
2005 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2007 mark_object (&kb
->Vprefix_arg
);
2008 mark_object (&kb
->kbd_queue
);
2009 mark_object (&kb
->Vlast_kbd_macro
);
2010 mark_object (&kb
->Vsystem_key_alist
);
2011 mark_object (&kb
->system_key_syms
);
2015 /* Sweep: find all structures not marked, and free them. */
2020 total_string_size
= 0;
2023 /* Put all unmarked conses on free list */
2025 register struct cons_block
*cblk
;
2026 register int lim
= cons_block_index
;
2027 register int num_free
= 0, num_used
= 0;
2031 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
2034 for (i
= 0; i
< lim
; i
++)
2035 if (!XMARKBIT (cblk
->conses
[i
].car
))
2038 *(struct Lisp_Cons
**)&cblk
->conses
[i
].car
= cons_free_list
;
2039 cons_free_list
= &cblk
->conses
[i
];
2044 XUNMARK (cblk
->conses
[i
].car
);
2046 lim
= CONS_BLOCK_SIZE
;
2048 total_conses
= num_used
;
2049 total_free_conses
= num_free
;
2052 #ifdef LISP_FLOAT_TYPE
2053 /* Put all unmarked floats on free list */
2055 register struct float_block
*fblk
;
2056 register int lim
= float_block_index
;
2057 register int num_free
= 0, num_used
= 0;
2059 float_free_list
= 0;
2061 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
2064 for (i
= 0; i
< lim
; i
++)
2065 if (!XMARKBIT (fblk
->floats
[i
].type
))
2068 *(struct Lisp_Float
**)&fblk
->floats
[i
].type
= float_free_list
;
2069 float_free_list
= &fblk
->floats
[i
];
2074 XUNMARK (fblk
->floats
[i
].type
);
2076 lim
= FLOAT_BLOCK_SIZE
;
2078 total_floats
= num_used
;
2079 total_free_floats
= num_free
;
2081 #endif /* LISP_FLOAT_TYPE */
2083 #ifdef USE_TEXT_PROPERTIES
2084 /* Put all unmarked intervals on free list */
2086 register struct interval_block
*iblk
;
2087 register int lim
= interval_block_index
;
2088 register int num_free
= 0, num_used
= 0;
2090 interval_free_list
= 0;
2092 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
2096 for (i
= 0; i
< lim
; i
++)
2098 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2100 iblk
->intervals
[i
].parent
= interval_free_list
;
2101 interval_free_list
= &iblk
->intervals
[i
];
2107 XUNMARK (iblk
->intervals
[i
].plist
);
2110 lim
= INTERVAL_BLOCK_SIZE
;
2112 total_intervals
= num_used
;
2113 total_free_intervals
= num_free
;
2115 #endif /* USE_TEXT_PROPERTIES */
2117 /* Put all unmarked symbols on free list */
2119 register struct symbol_block
*sblk
;
2120 register int lim
= symbol_block_index
;
2121 register int num_free
= 0, num_used
= 0;
2123 symbol_free_list
= 0;
2125 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
2128 for (i
= 0; i
< lim
; i
++)
2129 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2131 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2132 symbol_free_list
= &sblk
->symbols
[i
];
2138 sblk
->symbols
[i
].name
2139 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2140 XUNMARK (sblk
->symbols
[i
].plist
);
2142 lim
= SYMBOL_BLOCK_SIZE
;
2144 total_symbols
= num_used
;
2145 total_free_symbols
= num_free
;
2149 /* Put all unmarked markers on free list.
2150 Dechain each one first from the buffer it points into,
2151 but only if it's a real marker. */
2153 register struct marker_block
*mblk
;
2154 register int lim
= marker_block_index
;
2155 register int num_free
= 0, num_used
= 0;
2157 marker_free_list
= 0;
2159 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
2162 EMACS_INT already_free
= -1;
2164 for (i
= 0; i
< lim
; i
++)
2166 Lisp_Object
*markword
;
2167 switch (mblk
->markers
[i
].u_marker
.type
)
2169 case Lisp_Misc_Marker
:
2170 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2172 case Lisp_Misc_Buffer_Local_Value
:
2173 case Lisp_Misc_Some_Buffer_Local_Value
:
2174 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
2176 case Lisp_Misc_Overlay
:
2177 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2179 case Lisp_Misc_Free
:
2180 /* If the object was already free, keep it
2181 on the free list. */
2182 markword
= &already_free
;
2188 if (markword
&& !XMARKBIT (*markword
))
2191 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2193 /* tem1 avoids Sun compiler bug */
2194 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2195 XSETMARKER (tem
, tem1
);
2196 unchain_marker (tem
);
2198 /* Set the type of the freed object to Lisp_Misc_Free.
2199 We could leave the type alone, since nobody checks it,
2200 but this might catch bugs faster. */
2201 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2202 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2203 marker_free_list
= &mblk
->markers
[i
];
2210 XUNMARK (*markword
);
2213 lim
= MARKER_BLOCK_SIZE
;
2216 total_markers
= num_used
;
2217 total_free_markers
= num_free
;
2220 /* Free all unmarked buffers */
2222 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2225 if (!XMARKBIT (buffer
->name
))
2228 prev
->next
= buffer
->next
;
2230 all_buffers
= buffer
->next
;
2231 next
= buffer
->next
;
2237 XUNMARK (buffer
->name
);
2238 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2241 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2242 for purposes of marking and relocation.
2243 Turn them back into C pointers now. */
2244 buffer
->upcase_table
2245 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2246 buffer
->downcase_table
2247 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2249 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2250 buffer
->folding_sort_table
2251 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2254 prev
= buffer
, buffer
= buffer
->next
;
2258 #endif /* standalone */
2260 /* Free all unmarked vectors */
2262 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2263 total_vector_size
= 0;
2266 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2269 prev
->next
= vector
->next
;
2271 all_vectors
= vector
->next
;
2272 next
= vector
->next
;
2278 vector
->size
&= ~ARRAY_MARK_FLAG
;
2279 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2280 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2282 total_vector_size
+= vector
->size
;
2283 prev
= vector
, vector
= vector
->next
;
2287 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2289 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2290 struct Lisp_String
*s
;
2294 s
= (struct Lisp_String
*) &sb
->chars
[0];
2295 if (s
->size
& ARRAY_MARK_FLAG
)
2297 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2298 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2299 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2300 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2301 prev
= sb
, sb
= sb
->next
;
2306 prev
->next
= sb
->next
;
2308 large_string_blocks
= sb
->next
;
2317 /* Compactify strings, relocate references, and free empty string blocks. */
2322 /* String block of old strings we are scanning. */
2323 register struct string_block
*from_sb
;
2324 /* A preceding string block (or maybe the same one)
2325 where we are copying the still-live strings to. */
2326 register struct string_block
*to_sb
;
2330 to_sb
= first_string_block
;
2333 /* Scan each existing string block sequentially, string by string. */
2334 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2337 /* POS is the index of the next string in the block. */
2338 while (pos
< from_sb
->pos
)
2340 register struct Lisp_String
*nextstr
2341 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2343 register struct Lisp_String
*newaddr
;
2344 register EMACS_INT size
= nextstr
->size
;
2346 /* NEXTSTR is the old address of the next string.
2347 Just skip it if it isn't marked. */
2348 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2350 /* It is marked, so its size field is really a chain of refs.
2351 Find the end of the chain, where the actual size lives. */
2352 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2354 if (size
& DONT_COPY_FLAG
)
2355 size
^= MARKBIT
| DONT_COPY_FLAG
;
2356 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2359 total_string_size
+= size
;
2361 /* If it won't fit in TO_SB, close it out,
2362 and move to the next sb. Keep doing so until
2363 TO_SB reaches a large enough, empty enough string block.
2364 We know that TO_SB cannot advance past FROM_SB here
2365 since FROM_SB is large enough to contain this string.
2366 Any string blocks skipped here
2367 will be patched out and freed later. */
2368 while (to_pos
+ STRING_FULLSIZE (size
)
2369 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2371 to_sb
->pos
= to_pos
;
2372 to_sb
= to_sb
->next
;
2375 /* Compute new address of this string
2376 and update TO_POS for the space being used. */
2377 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2378 to_pos
+= STRING_FULLSIZE (size
);
2380 /* Copy the string itself to the new place. */
2381 if (nextstr
!= newaddr
)
2382 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2383 + INTERVAL_PTR_SIZE
);
2385 /* Go through NEXTSTR's chain of references
2386 and make each slot in the chain point to
2387 the new address of this string. */
2388 size
= newaddr
->size
;
2389 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2391 register Lisp_Object
*objptr
;
2392 if (size
& DONT_COPY_FLAG
)
2393 size
^= MARKBIT
| DONT_COPY_FLAG
;
2394 objptr
= (Lisp_Object
*)size
;
2396 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2397 if (XMARKBIT (*objptr
))
2399 XSETSTRING (*objptr
, newaddr
);
2403 XSETSTRING (*objptr
, newaddr
);
2405 /* Store the actual size in the size field. */
2406 newaddr
->size
= size
;
2408 #ifdef USE_TEXT_PROPERTIES
2409 /* Now that the string has been relocated, rebalance its
2410 interval tree, and update the tree's parent pointer. */
2411 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2413 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2414 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2417 #endif /* USE_TEXT_PROPERTIES */
2419 pos
+= STRING_FULLSIZE (size
);
2423 /* Close out the last string block still used and free any that follow. */
2424 to_sb
->pos
= to_pos
;
2425 current_string_block
= to_sb
;
2427 from_sb
= to_sb
->next
;
2431 to_sb
= from_sb
->next
;
2436 /* Free any empty string blocks further back in the chain.
2437 This loop will never free first_string_block, but it is very
2438 unlikely that that one will become empty, so why bother checking? */
2440 from_sb
= first_string_block
;
2441 while (to_sb
= from_sb
->next
)
2443 if (to_sb
->pos
== 0)
2445 if (from_sb
->next
= to_sb
->next
)
2446 from_sb
->next
->prev
= from_sb
;
2454 /* Debugging aids. */
2456 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2457 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2458 This may be helpful in debugging Emacs's memory usage.\n\
2459 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2464 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2469 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2470 "Return a list of counters that measure how much consing there has been.\n\
2471 Each of these counters increments for a certain kind of object.\n\
2472 The counters wrap around from the largest positive integer to zero.\n\
2473 Garbage collection does not decrease them.\n\
2474 The elements of the value are as follows:\n\
2475 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2476 All are in units of 1 = one object consed\n\
2477 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2479 MISCS include overlays, markers, and some internal types.\n\
2480 Frames, windows, buffers, and subprocesses count as vectors\n\
2481 (but the contents of a buffer's text do not count here).")
2484 Lisp_Object lisp_cons_cells_consed
;
2485 Lisp_Object lisp_floats_consed
;
2486 Lisp_Object lisp_vector_cells_consed
;
2487 Lisp_Object lisp_symbols_consed
;
2488 Lisp_Object lisp_string_chars_consed
;
2489 Lisp_Object lisp_misc_objects_consed
;
2490 Lisp_Object lisp_intervals_consed
;
2492 XSETINT (lisp_cons_cells_consed
,
2493 cons_cells_consed
& ~(1 << (VALBITS
- 1)));
2494 XSETINT (lisp_floats_consed
,
2495 floats_consed
& ~(1 << (VALBITS
- 1)));
2496 XSETINT (lisp_vector_cells_consed
,
2497 vector_cells_consed
& ~(1 << (VALBITS
- 1)));
2498 XSETINT (lisp_symbols_consed
,
2499 symbols_consed
& ~(1 << (VALBITS
- 1)));
2500 XSETINT (lisp_string_chars_consed
,
2501 string_chars_consed
& ~(1 << (VALBITS
- 1)));
2502 XSETINT (lisp_misc_objects_consed
,
2503 misc_objects_consed
& ~(1 << (VALBITS
- 1)));
2504 XSETINT (lisp_intervals_consed
,
2505 intervals_consed
& ~(1 << (VALBITS
- 1)));
2507 return Fcons (lisp_cons_cells_consed
,
2508 Fcons (lisp_floats_consed
,
2509 Fcons (lisp_vector_cells_consed
,
2510 Fcons (lisp_symbols_consed
,
2511 Fcons (lisp_string_chars_consed
,
2512 Fcons (lisp_misc_objects_consed
,
2513 Fcons (lisp_intervals_consed
,
2517 /* Initialization */
2521 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2524 pure_size
= PURESIZE
;
2527 ignore_warnings
= 1;
2532 #ifdef LISP_FLOAT_TYPE
2534 #endif /* LISP_FLOAT_TYPE */
2538 malloc_hysteresis
= 32;
2540 malloc_hysteresis
= 0;
2543 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2545 ignore_warnings
= 0;
2548 consing_since_gc
= 0;
2549 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
2550 #ifdef VIRT_ADDR_VARIES
2551 malloc_sbrk_unused
= 1<<22; /* A large number */
2552 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2553 #endif /* VIRT_ADDR_VARIES */
2564 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2565 "*Number of bytes of consing between garbage collections.\n\
2566 Garbage collection can happen automatically once this many bytes have been\n\
2567 allocated since the last garbage collection. All data types count.\n\n\
2568 Garbage collection happens automatically only when `eval' is called.\n\n\
2569 By binding this temporarily to a large number, you can effectively\n\
2570 prevent garbage collection during a part of the program.");
2572 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2573 "Number of bytes of sharable Lisp data allocated so far.");
2576 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2577 "Number of bytes of unshared memory allocated in this session.");
2579 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2580 "Number of bytes of unshared memory remaining available in this session.");
2583 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2584 "Non-nil means loading Lisp code in order to dump an executable.\n\
2585 This means that certain objects should be allocated in shared (pure) space.");
2587 DEFVAR_INT ("undo-limit", &undo_limit
,
2588 "Keep no more undo information once it exceeds this size.\n\
2589 This limit is applied when garbage collection happens.\n\
2590 The size is counted as the number of bytes occupied,\n\
2591 which includes both saved text and other data.");
2594 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2595 "Don't keep more than this much size of undo information.\n\
2596 A command which pushes past this size is itself forgotten.\n\
2597 This limit is applied when garbage collection happens.\n\
2598 The size is counted as the number of bytes occupied,\n\
2599 which includes both saved text and other data.");
2600 undo_strong_limit
= 30000;
2602 /* We build this in advance because if we wait until we need it, we might
2603 not be able to allocate the memory to hold it. */
2605 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
2606 staticpro (&memory_signal_data
);
2608 staticpro (&Qgc_cons_threshold
);
2609 Qgc_cons_threshold
= intern ("gc-cons-threshold");
2614 defsubr (&Smake_byte_code
);
2615 defsubr (&Smake_list
);
2616 defsubr (&Smake_vector
);
2617 defsubr (&Smake_char_table
);
2618 defsubr (&Smake_string
);
2619 defsubr (&Smake_bool_vector
);
2620 defsubr (&Smake_symbol
);
2621 defsubr (&Smake_marker
);
2622 defsubr (&Spurecopy
);
2623 defsubr (&Sgarbage_collect
);
2624 defsubr (&Smemory_limit
);
2625 defsubr (&Smemory_use_counts
);