aboutsummaryrefslogtreecommitdiffstats
path: root/src/alloc.c
diff options
context:
space:
mode:
authorYuan Fu2022-05-07 01:57:39 -0700
committerYuan Fu2022-05-07 01:57:39 -0700
commit82d5e902af68695481b8809e511a7913ef9a75aa (patch)
treee6a366278590e8906a9282d04e48de2061b6fe3f /src/alloc.c
parent84847cad82e3b667c82f411627cd58d236f55e84 (diff)
parent293a97d61e1977440f96b7fc91f281a06250ea72 (diff)
downloademacs-82d5e902af68695481b8809e511a7913ef9a75aa.tar.gz
emacs-82d5e902af68695481b8809e511a7913ef9a75aa.zip
; Merge from master.
Diffstat (limited to 'src/alloc.c')
-rw-r--r--src/alloc.c691
1 files changed, 402 insertions, 289 deletions
diff --git a/src/alloc.c b/src/alloc.c
index e7603fac37a..40a3e235eab 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -449,26 +449,11 @@ static void compact_small_strings (void);
449static void free_large_strings (void); 449static void free_large_strings (void);
450extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE; 450extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
451 451
452/* Forward declare mark accessor functions: they're used all over the 452static bool vector_marked_p (struct Lisp_Vector const *);
453 place. */ 453static bool vectorlike_marked_p (union vectorlike_header const *);
454 454static void set_vectorlike_marked (union vectorlike_header *);
455inline static bool vector_marked_p (const struct Lisp_Vector *v); 455static bool interval_marked_p (INTERVAL);
456inline static void set_vector_marked (struct Lisp_Vector *v); 456static void set_interval_marked (INTERVAL);
457
458inline static bool vectorlike_marked_p (const union vectorlike_header *v);
459inline static void set_vectorlike_marked (union vectorlike_header *v);
460
461inline static bool cons_marked_p (const struct Lisp_Cons *c);
462inline static void set_cons_marked (struct Lisp_Cons *c);
463
464inline static bool string_marked_p (const struct Lisp_String *s);
465inline static void set_string_marked (struct Lisp_String *s);
466
467inline static bool symbol_marked_p (const struct Lisp_Symbol *s);
468inline static void set_symbol_marked (struct Lisp_Symbol *s);
469
470inline static bool interval_marked_p (INTERVAL i);
471inline static void set_interval_marked (INTERVAL i);
472 457
473/* When scanning the C stack for live Lisp objects, Emacs keeps track of 458/* When scanning the C stack for live Lisp objects, Emacs keeps track of
474 what memory allocated via lisp_malloc and lisp_align_malloc is intended 459 what memory allocated via lisp_malloc and lisp_align_malloc is intended
@@ -4941,7 +4926,7 @@ mark_maybe_pointer (void *p, bool symbol_only)
4941/* Mark Lisp objects referenced from the address range START..END 4926/* Mark Lisp objects referenced from the address range START..END
4942 or END..START. */ 4927 or END..START. */
4943 4928
4944static void ATTRIBUTE_NO_SANITIZE_ADDRESS 4929void ATTRIBUTE_NO_SANITIZE_ADDRESS
4945mark_memory (void const *start, void const *end) 4930mark_memory (void const *start, void const *end)
4946{ 4931{
4947 char const *pp; 4932 char const *pp;
@@ -5010,7 +4995,7 @@ marking. Emacs has determined that the method it uses to do the\n\
5010marking will likely work on your system, but this isn't sure.\n\ 4995marking will likely work on your system, but this isn't sure.\n\
5011\n\ 4996\n\
5012If you are a system-programmer, or can get the help of a local wizard\n\ 4997If you are a system-programmer, or can get the help of a local wizard\n\
5013who is, please take a look at the function mark_stack in alloc.c, and\n\ 4998who is, please take a look at the function mark_c_stack in alloc.c, and\n\
5014verify that the methods used are appropriate for your system.\n\ 4999verify that the methods used are appropriate for your system.\n\
5015\n\ 5000\n\
5016Please mail the result to <emacs-devel@gnu.org>.\n\ 5001Please mail the result to <emacs-devel@gnu.org>.\n\
@@ -5023,7 +5008,7 @@ marking. Emacs has determined that the default method it uses to do the\n\
5023marking will not work on your system. We will need a system-dependent\n\ 5008marking will not work on your system. We will need a system-dependent\n\
5024solution for your system.\n\ 5009solution for your system.\n\
5025\n\ 5010\n\
5026Please take a look at the function mark_stack in alloc.c, and\n\ 5011Please take a look at the function mark_c_stack in alloc.c, and\n\
5027try to find a way to make it work on your system.\n\ 5012try to find a way to make it work on your system.\n\
5028\n\ 5013\n\
5029Note that you may get false negatives, depending on the compiler.\n\ 5014Note that you may get false negatives, depending on the compiler.\n\
@@ -5165,7 +5150,7 @@ typedef union
5165 from the stack start. */ 5150 from the stack start. */
5166 5151
5167void 5152void
5168mark_stack (char const *bottom, char const *end) 5153mark_c_stack (char const *bottom, char const *end)
5169{ 5154{
5170 /* This assumes that the stack is a contiguous region in memory. If 5155 /* This assumes that the stack is a contiguous region in memory. If
5171 that's not the case, something has to be done here to iterate 5156 that's not the case, something has to be done here to iterate
@@ -6113,6 +6098,8 @@ maybe_garbage_collect (void)
6113 garbage_collect (); 6098 garbage_collect ();
6114} 6099}
6115 6100
6101static inline bool mark_stack_empty_p (void);
6102
6116/* Subroutine of Fgarbage_collect that does most of the work. */ 6103/* Subroutine of Fgarbage_collect that does most of the work. */
6117void 6104void
6118garbage_collect (void) 6105garbage_collect (void)
@@ -6128,6 +6115,8 @@ garbage_collect (void)
6128 if (garbage_collection_inhibited) 6115 if (garbage_collection_inhibited)
6129 return; 6116 return;
6130 6117
6118 eassert(mark_stack_empty_p ());
6119
6131 /* Record this function, so it appears on the profiler's backtraces. */ 6120 /* Record this function, so it appears on the profiler's backtraces. */
6132 record_in_backtrace (QAutomatic_GC, 0, 0); 6121 record_in_backtrace (QAutomatic_GC, 0, 0);
6133 6122
@@ -6220,6 +6209,10 @@ garbage_collect (void)
6220 mark_fringe_data (); 6209 mark_fringe_data ();
6221#endif 6210#endif
6222 6211
6212#ifdef HAVE_X_WINDOWS
6213 mark_xterm ();
6214#endif
6215
6223 /* Everything is now marked, except for the data in font caches, 6216 /* Everything is now marked, except for the data in font caches,
6224 undo lists, and finalizers. The first two are compacted by 6217 undo lists, and finalizers. The first two are compacted by
6225 removing an items which aren't reachable otherwise. */ 6218 removing an items which aren't reachable otherwise. */
@@ -6250,6 +6243,8 @@ garbage_collect (void)
6250 mark_and_sweep_weak_table_contents (); 6243 mark_and_sweep_weak_table_contents ();
6251 eassert (weak_hash_tables == NULL); 6244 eassert (weak_hash_tables == NULL);
6252 6245
6246 eassert (mark_stack_empty_p ());
6247
6253 gc_sweep (); 6248 gc_sweep ();
6254 6249
6255 unmark_main_thread (); 6250 unmark_main_thread ();
@@ -6423,15 +6418,25 @@ mark_glyph_matrix (struct glyph_matrix *matrix)
6423 } 6418 }
6424} 6419}
6425 6420
6421/* Whether to remember a few of the last marked values for debugging. */
6422#define GC_REMEMBER_LAST_MARKED 0
6423
6424#if GC_REMEMBER_LAST_MARKED
6426enum { LAST_MARKED_SIZE = 1 << 9 }; /* Must be a power of 2. */ 6425enum { LAST_MARKED_SIZE = 1 << 9 }; /* Must be a power of 2. */
6427Lisp_Object last_marked[LAST_MARKED_SIZE] EXTERNALLY_VISIBLE; 6426Lisp_Object last_marked[LAST_MARKED_SIZE] EXTERNALLY_VISIBLE;
6428static int last_marked_index; 6427static int last_marked_index;
6428#endif
6429
6430/* Whether to enable the mark_object_loop_halt debugging feature. */
6431#define GC_CDR_COUNT 0
6429 6432
6433#if GC_CDR_COUNT
6430/* For debugging--call abort when we cdr down this many 6434/* For debugging--call abort when we cdr down this many
6431 links of a list, in mark_object. In debugging, 6435 links of a list, in mark_object. In debugging,
6432 the call to abort will hit a breakpoint. 6436 the call to abort will hit a breakpoint.
6433 Normally this is zero and the check never goes off. */ 6437 Normally this is zero and the check never goes off. */
6434ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE; 6438ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE;
6439#endif
6435 6440
6436static void 6441static void
6437mark_vectorlike (union vectorlike_header *header) 6442mark_vectorlike (union vectorlike_header *header)
@@ -6485,19 +6490,6 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype)
6485 } 6490 }
6486} 6491}
6487 6492
6488NO_INLINE /* To reduce stack depth in mark_object. */
6489static Lisp_Object
6490mark_compiled (struct Lisp_Vector *ptr)
6491{
6492 int i, size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
6493
6494 set_vector_marked (ptr);
6495 for (i = 0; i < size; i++)
6496 if (i != COMPILED_CONSTANTS)
6497 mark_object (ptr->contents[i]);
6498 return size > COMPILED_CONSTANTS ? ptr->contents[COMPILED_CONSTANTS] : Qnil;
6499}
6500
6501/* Mark the chain of overlays starting at PTR. */ 6493/* Mark the chain of overlays starting at PTR. */
6502 6494
6503static void 6495static void
@@ -6650,110 +6642,160 @@ mark_window (struct Lisp_Vector *ptr)
6650 (w, mark_discard_killed_buffers (w->next_buffers)); 6642 (w, mark_discard_killed_buffers (w->next_buffers));
6651} 6643}
6652 6644
6653static void 6645/* Entry of the mark stack. */
6654mark_hash_table (struct Lisp_Vector *ptr) 6646struct mark_entry
6655{ 6647{
6656 struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *) ptr; 6648 ptrdiff_t n; /* number of values, or 0 if a single value */
6657 6649 union {
6658 mark_vectorlike (&h->header); 6650 Lisp_Object value; /* when n = 0 */
6659 mark_object (h->test.name); 6651 Lisp_Object *values; /* when n > 0 */
6660 mark_object (h->test.user_hash_function); 6652 } u;
6661 mark_object (h->test.user_cmp_function); 6653};
6662 /* If hash table is not weak, mark all keys and values. For weak 6654
6663 tables, mark only the vector and not its contents --- that's what 6655/* This stack is used during marking for traversing data structures without
6664 makes it weak. */ 6656 using C recursion. */
6665 if (NILP (h->weak)) 6657struct mark_stack
6666 mark_object (h->key_and_value); 6658{
6667 else 6659 struct mark_entry *stack; /* base of stack */
6660 ptrdiff_t size; /* allocated size in entries */
6661 ptrdiff_t sp; /* current number of entries */
6662};
6663
6664static struct mark_stack mark_stk = {NULL, 0, 0};
6665
6666static inline bool
6667mark_stack_empty_p (void)
6668{
6669 return mark_stk.sp <= 0;
6670}
6671
6672/* Pop and return a value from the mark stack (which must be nonempty). */
6673static inline Lisp_Object
6674mark_stack_pop (void)
6675{
6676 eassume (!mark_stack_empty_p ());
6677 struct mark_entry *e = &mark_stk.stack[mark_stk.sp - 1];
6678 if (e->n == 0) /* single value */
6668 { 6679 {
6669 eassert (h->next_weak == NULL); 6680 --mark_stk.sp;
6670 h->next_weak = weak_hash_tables; 6681 return e->u.value;
6671 weak_hash_tables = h;
6672 set_vector_marked (XVECTOR (h->key_and_value));
6673 } 6682 }
6683 /* Array of values: pop them left to right, which seems to be slightly
6684 faster than right to left. */
6685 e->n--;
6686 if (e->n == 0)
6687 --mark_stk.sp; /* last value consumed */
6688 return (++e->u.values)[-1];
6674} 6689}
6675 6690
6676void 6691NO_INLINE static void
6677mark_objects (Lisp_Object *obj, ptrdiff_t n) 6692grow_mark_stack (void)
6678{ 6693{
6679 for (ptrdiff_t i = 0; i < n; i++) 6694 struct mark_stack *ms = &mark_stk;
6680 mark_object (obj[i]); 6695 eassert (ms->sp == ms->size);
6696 ptrdiff_t min_incr = ms->sp == 0 ? 8192 : 1;
6697 ms->stack = xpalloc (ms->stack, &ms->size, min_incr, -1, sizeof *ms->stack);
6698 eassert (ms->sp < ms->size);
6681} 6699}
6682 6700
6683/* Determine type of generic Lisp_Object and mark it accordingly. 6701/* Push VALUE onto the mark stack. */
6702static inline void
6703mark_stack_push_value (Lisp_Object value)
6704{
6705 if (mark_stk.sp >= mark_stk.size)
6706 grow_mark_stack ();
6707 mark_stk.stack[mark_stk.sp++] = (struct mark_entry){.n = 0, .u.value = value};
6708}
6709
6710/* Push the N values at VALUES onto the mark stack. */
6711static inline void
6712mark_stack_push_values (Lisp_Object *values, ptrdiff_t n)
6713{
6714 eassume (n >= 0);
6715 if (n == 0)
6716 return;
6717 if (mark_stk.sp >= mark_stk.size)
6718 grow_mark_stack ();
6719 mark_stk.stack[mark_stk.sp++] = (struct mark_entry){.n = n,
6720 .u.values = values};
6721}
6684 6722
6685 This function implements a straightforward depth-first marking 6723/* Traverse and mark objects on the mark stack above BASE_SP.
6686 algorithm and so the recursion depth may be very high (a few
6687 tens of thousands is not uncommon). To minimize stack usage,
6688 a few cold paths are moved out to NO_INLINE functions above.
6689 In general, inlining them doesn't help you to gain more speed. */
6690 6724
6691void 6725 Traversal is depth-first using the mark stack for most common
6692mark_object (Lisp_Object arg) 6726 object types. Recursion is used for other types, in the hope that
6727 they are rare enough that C stack usage is kept low. */
6728static void
6729process_mark_stack (ptrdiff_t base_sp)
6693{ 6730{
6694 register Lisp_Object obj;
6695 void *po;
6696#if GC_CHECK_MARKED_OBJECTS 6731#if GC_CHECK_MARKED_OBJECTS
6697 struct mem_node *m = NULL; 6732 struct mem_node *m = NULL;
6698#endif 6733#endif
6734#if GC_CDR_COUNT
6699 ptrdiff_t cdr_count = 0; 6735 ptrdiff_t cdr_count = 0;
6736#endif
6700 6737
6701 obj = arg; 6738 eassume (mark_stk.sp >= base_sp && base_sp >= 0);
6702 loop:
6703 6739
6704 po = XPNTR (obj); 6740 while (mark_stk.sp > base_sp)
6705 if (PURE_P (po)) 6741 {
6706 return; 6742 Lisp_Object obj = mark_stack_pop ();
6743 mark_obj: ;
6744 void *po = XPNTR (obj);
6745 if (PURE_P (po))
6746 continue;
6707 6747
6708 last_marked[last_marked_index++] = obj; 6748#if GC_REMEMBER_LAST_MARKED
6709 last_marked_index &= LAST_MARKED_SIZE - 1; 6749 last_marked[last_marked_index++] = obj;
6750 last_marked_index &= LAST_MARKED_SIZE - 1;
6751#endif
6710 6752
6711 /* Perform some sanity checks on the objects marked here. Abort if 6753 /* Perform some sanity checks on the objects marked here. Abort if
6712 we encounter an object we know is bogus. This increases GC time 6754 we encounter an object we know is bogus. This increases GC time
6713 by ~80%. */ 6755 by ~80%. */
6714#if GC_CHECK_MARKED_OBJECTS 6756#if GC_CHECK_MARKED_OBJECTS
6715 6757
6716 /* Check that the object pointed to by PO is known to be a Lisp 6758 /* Check that the object pointed to by PO is known to be a Lisp
6717 structure allocated from the heap. */ 6759 structure allocated from the heap. */
6718#define CHECK_ALLOCATED() \ 6760#define CHECK_ALLOCATED() \
6719 do { \ 6761 do { \
6720 if (pdumper_object_p (po)) \ 6762 if (pdumper_object_p (po)) \
6721 { \ 6763 { \
6722 if (!pdumper_object_p_precise (po)) \ 6764 if (!pdumper_object_p_precise (po)) \
6723 emacs_abort (); \ 6765 emacs_abort (); \
6724 break; \ 6766 break; \
6725 } \ 6767 } \
6726 m = mem_find (po); \ 6768 m = mem_find (po); \
6727 if (m == MEM_NIL) \ 6769 if (m == MEM_NIL) \
6728 emacs_abort (); \ 6770 emacs_abort (); \
6729 } while (0) 6771 } while (0)
6730 6772
6731 /* Check that the object pointed to by PO is live, using predicate 6773 /* Check that the object pointed to by PO is live, using predicate
6732 function LIVEP. */ 6774 function LIVEP. */
6733#define CHECK_LIVE(LIVEP, MEM_TYPE) \ 6775#define CHECK_LIVE(LIVEP, MEM_TYPE) \
6734 do { \ 6776 do { \
6735 if (pdumper_object_p (po)) \ 6777 if (pdumper_object_p (po)) \
6736 break; \ 6778 break; \
6737 if (! (m->type == MEM_TYPE && LIVEP (m, po))) \ 6779 if (! (m->type == MEM_TYPE && LIVEP (m, po))) \
6738 emacs_abort (); \ 6780 emacs_abort (); \
6739 } while (0) 6781 } while (0)
6740 6782
6741 /* Check both of the above conditions, for non-symbols. */ 6783 /* Check both of the above conditions, for non-symbols. */
6742#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) \ 6784#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) \
6743 do { \ 6785 do { \
6744 CHECK_ALLOCATED (); \ 6786 CHECK_ALLOCATED (); \
6745 CHECK_LIVE (LIVEP, MEM_TYPE); \ 6787 CHECK_LIVE (LIVEP, MEM_TYPE); \
6746 } while (false) 6788 } while (false)
6747 6789
6748 /* Check both of the above conditions, for symbols. */ 6790 /* Check both of the above conditions, for symbols. */
6749#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \ 6791#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \
6750 do { \ 6792 do { \
6751 if (!c_symbol_p (ptr)) \ 6793 if (!c_symbol_p (ptr)) \
6752 { \ 6794 { \
6753 CHECK_ALLOCATED (); \ 6795 CHECK_ALLOCATED (); \
6754 CHECK_LIVE (live_symbol_p, MEM_TYPE_SYMBOL); \ 6796 CHECK_LIVE (live_symbol_p, MEM_TYPE_SYMBOL); \
6755 } \ 6797 } \
6756 } while (false) 6798 } while (false)
6757 6799
6758#else /* not GC_CHECK_MARKED_OBJECTS */ 6800#else /* not GC_CHECK_MARKED_OBJECTS */
6759 6801
@@ -6762,199 +6804,220 @@ mark_object (Lisp_Object arg)
6762 6804
6763#endif /* not GC_CHECK_MARKED_OBJECTS */ 6805#endif /* not GC_CHECK_MARKED_OBJECTS */
6764 6806
6765 switch (XTYPE (obj)) 6807 switch (XTYPE (obj))
6766 { 6808 {
6767 case Lisp_String: 6809 case Lisp_String:
6768 { 6810 {
6769 register struct Lisp_String *ptr = XSTRING (obj); 6811 register struct Lisp_String *ptr = XSTRING (obj);
6770 if (string_marked_p (ptr)) 6812 if (string_marked_p (ptr))
6771 break; 6813 break;
6772 CHECK_ALLOCATED_AND_LIVE (live_string_p, MEM_TYPE_STRING); 6814 CHECK_ALLOCATED_AND_LIVE (live_string_p, MEM_TYPE_STRING);
6773 set_string_marked (ptr); 6815 set_string_marked (ptr);
6774 mark_interval_tree (ptr->u.s.intervals); 6816 mark_interval_tree (ptr->u.s.intervals);
6775#ifdef GC_CHECK_STRING_BYTES 6817#ifdef GC_CHECK_STRING_BYTES
6776 /* Check that the string size recorded in the string is the 6818 /* Check that the string size recorded in the string is the
6777 same as the one recorded in the sdata structure. */ 6819 same as the one recorded in the sdata structure. */
6778 string_bytes (ptr); 6820 string_bytes (ptr);
6779#endif /* GC_CHECK_STRING_BYTES */ 6821#endif /* GC_CHECK_STRING_BYTES */
6780 } 6822 }
6781 break; 6823 break;
6782 6824
6783 case Lisp_Vectorlike: 6825 case Lisp_Vectorlike:
6784 { 6826 {
6785 register struct Lisp_Vector *ptr = XVECTOR (obj); 6827 register struct Lisp_Vector *ptr = XVECTOR (obj);
6786 6828
6787 if (vector_marked_p (ptr)) 6829 if (vector_marked_p (ptr))
6788 break; 6830 break;
6789 6831
6790 enum pvec_type pvectype 6832 enum pvec_type pvectype
6791 = PSEUDOVECTOR_TYPE (ptr); 6833 = PSEUDOVECTOR_TYPE (ptr);
6792 6834
6793#ifdef GC_CHECK_MARKED_OBJECTS 6835#ifdef GC_CHECK_MARKED_OBJECTS
6794 if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po)) 6836 if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po))
6795 { 6837 {
6796 m = mem_find (po); 6838 m = mem_find (po);
6797 if (m == MEM_NIL) 6839 if (m == MEM_NIL)
6798 emacs_abort (); 6840 emacs_abort ();
6799 if (m->type == MEM_TYPE_VECTORLIKE) 6841 if (m->type == MEM_TYPE_VECTORLIKE)
6800 CHECK_LIVE (live_large_vector_p, MEM_TYPE_VECTORLIKE); 6842 CHECK_LIVE (live_large_vector_p, MEM_TYPE_VECTORLIKE);
6801 else 6843 else
6802 CHECK_LIVE (live_small_vector_p, MEM_TYPE_VECTOR_BLOCK); 6844 CHECK_LIVE (live_small_vector_p, MEM_TYPE_VECTOR_BLOCK);
6803 } 6845 }
6804#endif 6846#endif
6805 6847
6806 switch (pvectype) 6848 switch (pvectype)
6807 {
6808 case PVEC_BUFFER:
6809 mark_buffer ((struct buffer *) ptr);
6810 break;
6811
6812 case PVEC_COMPILED:
6813 /* Although we could treat this just like a vector, mark_compiled
6814 returns the COMPILED_CONSTANTS element, which is marked at the
6815 next iteration of goto-loop here. This is done to avoid a few
6816 recursive calls to mark_object. */
6817 obj = mark_compiled (ptr);
6818 if (!NILP (obj))
6819 goto loop;
6820 break;
6821
6822 case PVEC_FRAME:
6823 mark_frame (ptr);
6824 break;
6825
6826 case PVEC_WINDOW:
6827 mark_window (ptr);
6828 break;
6829
6830 case PVEC_HASH_TABLE:
6831 mark_hash_table (ptr);
6832 break;
6833
6834 case PVEC_CHAR_TABLE:
6835 case PVEC_SUB_CHAR_TABLE:
6836 mark_char_table (ptr, (enum pvec_type) pvectype);
6837 break;
6838
6839 case PVEC_BOOL_VECTOR:
6840 /* bool vectors in a dump are permanently "marked", since
6841 they're in the old section and don't have mark bits.
6842 If we're looking at a dumped bool vector, we should
6843 have aborted above when we called vector_marked_p, so
6844 we should never get here. */
6845 eassert (!pdumper_object_p (ptr));
6846 set_vector_marked (ptr);
6847 break;
6848
6849 case PVEC_OVERLAY:
6850 mark_overlay (XOVERLAY (obj));
6851 break;
6852
6853 case PVEC_SUBR:
6854#ifdef HAVE_NATIVE_COMP
6855 if (SUBR_NATIVE_COMPILEDP (obj))
6856 { 6849 {
6850 case PVEC_BUFFER:
6851 mark_buffer ((struct buffer *) ptr);
6852 break;
6853
6854 case PVEC_FRAME:
6855 mark_frame (ptr);
6856 break;
6857
6858 case PVEC_WINDOW:
6859 mark_window (ptr);
6860 break;
6861
6862 case PVEC_HASH_TABLE:
6863 {
6864 struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *)ptr;
6865 ptrdiff_t size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
6866 set_vector_marked (ptr);
6867 mark_stack_push_values (ptr->contents, size);
6868 mark_stack_push_value (h->test.name);
6869 mark_stack_push_value (h->test.user_hash_function);
6870 mark_stack_push_value (h->test.user_cmp_function);
6871 if (NILP (h->weak))
6872 mark_stack_push_value (h->key_and_value);
6873 else
6874 {
6875 /* For weak tables, mark only the vector and not its
6876 contents --- that's what makes it weak. */
6877 eassert (h->next_weak == NULL);
6878 h->next_weak = weak_hash_tables;
6879 weak_hash_tables = h;
6880 set_vector_marked (XVECTOR (h->key_and_value));
6881 }
6882 break;
6883 }
6884
6885 case PVEC_CHAR_TABLE:
6886 case PVEC_SUB_CHAR_TABLE:
6887 mark_char_table (ptr, (enum pvec_type) pvectype);
6888 break;
6889
6890 case PVEC_BOOL_VECTOR:
6891 /* bool vectors in a dump are permanently "marked", since
6892 they're in the old section and don't have mark bits.
6893 If we're looking at a dumped bool vector, we should
6894 have aborted above when we called vector_marked_p, so
6895 we should never get here. */
6896 eassert (!pdumper_object_p (ptr));
6857 set_vector_marked (ptr); 6897 set_vector_marked (ptr);
6858 struct Lisp_Subr *subr = XSUBR (obj); 6898 break;
6859 mark_object (subr->native_intspec); 6899
6860 mark_object (subr->native_comp_u); 6900 case PVEC_OVERLAY:
6861 mark_object (subr->lambda_list); 6901 mark_overlay (XOVERLAY (obj));
6862 mark_object (subr->type); 6902 break;
6863 } 6903
6904 case PVEC_SUBR:
6905#ifdef HAVE_NATIVE_COMP
6906 if (SUBR_NATIVE_COMPILEDP (obj))
6907 {
6908 set_vector_marked (ptr);
6909 struct Lisp_Subr *subr = XSUBR (obj);
6910 mark_stack_push_value (subr->intspec.native);
6911 mark_stack_push_value (subr->command_modes);
6912 mark_stack_push_value (subr->native_comp_u);
6913 mark_stack_push_value (subr->lambda_list);
6914 mark_stack_push_value (subr->type);
6915 }
6864#endif 6916#endif
6865 break; 6917 break;
6866 6918
6867 case PVEC_FREE: 6919 case PVEC_FREE:
6868 emacs_abort (); 6920 emacs_abort ();
6869 6921
6870 default: 6922 default:
6871 /* A regular vector, or a pseudovector needing no special 6923 {
6872 treatment. */ 6924 /* A regular vector or pseudovector needing no special
6873 mark_vectorlike (&ptr->header); 6925 treatment. */
6926 ptrdiff_t size = ptr->header.size;
6927 if (size & PSEUDOVECTOR_FLAG)
6928 size &= PSEUDOVECTOR_SIZE_MASK;
6929 set_vector_marked (ptr);
6930 mark_stack_push_values (ptr->contents, size);
6931 }
6932 break;
6933 }
6874 } 6934 }
6875 } 6935 break;
6876 break;
6877 6936
6878 case Lisp_Symbol: 6937 case Lisp_Symbol:
6879 {
6880 struct Lisp_Symbol *ptr = XBARE_SYMBOL (obj);
6881 nextsym:
6882 if (symbol_marked_p (ptr))
6883 break;
6884 CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
6885 set_symbol_marked (ptr);
6886 /* Attempt to catch bogus objects. */
6887 eassert (valid_lisp_object_p (ptr->u.s.function));
6888 mark_object (ptr->u.s.function);
6889 mark_object (ptr->u.s.plist);
6890 switch (ptr->u.s.redirect)
6891 { 6938 {
6892 case SYMBOL_PLAINVAL: mark_object (SYMBOL_VAL (ptr)); break; 6939 struct Lisp_Symbol *ptr = XBARE_SYMBOL (obj);
6893 case SYMBOL_VARALIAS: 6940 nextsym:
6894 { 6941 if (symbol_marked_p (ptr))
6895 Lisp_Object tem;
6896 XSETSYMBOL (tem, SYMBOL_ALIAS (ptr));
6897 mark_object (tem);
6898 break; 6942 break;
6899 } 6943 CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
6900 case SYMBOL_LOCALIZED: 6944 set_symbol_marked (ptr);
6901 mark_localized_symbol (ptr); 6945 /* Attempt to catch bogus objects. */
6902 break; 6946 eassert (valid_lisp_object_p (ptr->u.s.function));
6903 case SYMBOL_FORWARDED: 6947 mark_stack_push_value (ptr->u.s.function);
6904 /* If the value is forwarded to a buffer or keyboard field, 6948 mark_stack_push_value (ptr->u.s.plist);
6905 these are marked when we see the corresponding object. 6949 switch (ptr->u.s.redirect)
6906 And if it's forwarded to a C variable, either it's not 6950 {
6907 a Lisp_Object var, or it's staticpro'd already. */ 6951 case SYMBOL_PLAINVAL:
6908 break; 6952 mark_stack_push_value (SYMBOL_VAL (ptr));
6909 default: emacs_abort (); 6953 break;
6954 case SYMBOL_VARALIAS:
6955 {
6956 Lisp_Object tem;
6957 XSETSYMBOL (tem, SYMBOL_ALIAS (ptr));
6958 mark_stack_push_value (tem);
6959 break;
6960 }
6961 case SYMBOL_LOCALIZED:
6962 mark_localized_symbol (ptr);
6963 break;
6964 case SYMBOL_FORWARDED:
6965 /* If the value is forwarded to a buffer or keyboard field,
6966 these are marked when we see the corresponding object.
6967 And if it's forwarded to a C variable, either it's not
6968 a Lisp_Object var, or it's staticpro'd already. */
6969 break;
6970 default: emacs_abort ();
6971 }
6972 if (!PURE_P (XSTRING (ptr->u.s.name)))
6973 set_string_marked (XSTRING (ptr->u.s.name));
6974 mark_interval_tree (string_intervals (ptr->u.s.name));
6975 /* Inner loop to mark next symbol in this bucket, if any. */
6976 po = ptr = ptr->u.s.next;
6977 if (ptr)
6978 goto nextsym;
6910 } 6979 }
6911 if (!PURE_P (XSTRING (ptr->u.s.name)))
6912 set_string_marked (XSTRING (ptr->u.s.name));
6913 mark_interval_tree (string_intervals (ptr->u.s.name));
6914 /* Inner loop to mark next symbol in this bucket, if any. */
6915 po = ptr = ptr->u.s.next;
6916 if (ptr)
6917 goto nextsym;
6918 }
6919 break;
6920
6921 case Lisp_Cons:
6922 {
6923 struct Lisp_Cons *ptr = XCONS (obj);
6924 if (cons_marked_p (ptr))
6925 break; 6980 break;
6926 CHECK_ALLOCATED_AND_LIVE (live_cons_p, MEM_TYPE_CONS); 6981
6927 set_cons_marked (ptr); 6982 case Lisp_Cons:
6928 /* If the cdr is nil, avoid recursion for the car. */
6929 if (NILP (ptr->u.s.u.cdr))
6930 { 6983 {
6984 struct Lisp_Cons *ptr = XCONS (obj);
6985 if (cons_marked_p (ptr))
6986 break;
6987 CHECK_ALLOCATED_AND_LIVE (live_cons_p, MEM_TYPE_CONS);
6988 set_cons_marked (ptr);
6989 /* Avoid growing the stack if the cdr is nil.
6990 In any case, make sure the car is expanded first. */
6991 if (!NILP (ptr->u.s.u.cdr))
6992 {
6993 mark_stack_push_value (ptr->u.s.u.cdr);
6994#if GC_CDR_COUNT
6995 cdr_count++;
6996 if (cdr_count == mark_object_loop_halt)
6997 emacs_abort ();
6998#endif
6999 }
7000 /* Speedup hack for the common case (successive list elements). */
6931 obj = ptr->u.s.car; 7001 obj = ptr->u.s.car;
6932 cdr_count = 0; 7002 goto mark_obj;
6933 goto loop;
6934 } 7003 }
6935 mark_object (ptr->u.s.car);
6936 obj = ptr->u.s.u.cdr;
6937 cdr_count++;
6938 if (cdr_count == mark_object_loop_halt)
6939 emacs_abort ();
6940 goto loop;
6941 }
6942 7004
6943 case Lisp_Float: 7005 case Lisp_Float:
6944 CHECK_ALLOCATED_AND_LIVE (live_float_p, MEM_TYPE_FLOAT); 7006 CHECK_ALLOCATED_AND_LIVE (live_float_p, MEM_TYPE_FLOAT);
6945 /* Do not mark floats stored in a dump image: these floats are 7007 /* Do not mark floats stored in a dump image: these floats are
6946 "cold" and do not have mark bits. */ 7008 "cold" and do not have mark bits. */
6947 if (pdumper_object_p (XFLOAT (obj))) 7009 if (pdumper_object_p (XFLOAT (obj)))
6948 eassert (pdumper_cold_object_p (XFLOAT (obj))); 7010 eassert (pdumper_cold_object_p (XFLOAT (obj)));
6949 else if (!XFLOAT_MARKED_P (XFLOAT (obj))) 7011 else if (!XFLOAT_MARKED_P (XFLOAT (obj)))
6950 XFLOAT_MARK (XFLOAT (obj)); 7012 XFLOAT_MARK (XFLOAT (obj));
6951 break; 7013 break;
6952 7014
6953 case_Lisp_Int: 7015 case_Lisp_Int:
6954 break; 7016 break;
6955 7017
6956 default: 7018 default:
6957 emacs_abort (); 7019 emacs_abort ();
7020 }
6958 } 7021 }
6959 7022
6960#undef CHECK_LIVE 7023#undef CHECK_LIVE
@@ -6962,6 +7025,22 @@ mark_object (Lisp_Object arg)
6962#undef CHECK_ALLOCATED_AND_LIVE 7025#undef CHECK_ALLOCATED_AND_LIVE
6963} 7026}
6964 7027
7028void
7029mark_object (Lisp_Object obj)
7030{
7031 ptrdiff_t sp = mark_stk.sp;
7032 mark_stack_push_value (obj);
7033 process_mark_stack (sp);
7034}
7035
7036void
7037mark_objects (Lisp_Object *objs, ptrdiff_t n)
7038{
7039 ptrdiff_t sp = mark_stk.sp;
7040 mark_stack_push_values (objs, n);
7041 process_mark_stack (sp);
7042}
7043
6965/* Mark the Lisp pointers in the terminal objects. 7044/* Mark the Lisp pointers in the terminal objects.
6966 Called by Fgarbage_collect. */ 7045 Called by Fgarbage_collect. */
6967 7046
@@ -7413,6 +7492,37 @@ arenas. */)
7413} 7492}
7414#endif 7493#endif
7415 7494
7495#ifdef HAVE_MALLOC_TRIM
7496DEFUN ("malloc-trim", Fmalloc_trim, Smalloc_trim, 0, 1, "",
7497 doc: /* Release free heap memory to the OS.
7498This function asks libc to return unused heap memory back to the operating
7499system. This function isn't guaranteed to do anything, and is mainly
7500meant as a debugging tool.
7501
7502If LEAVE_PADDING is given, ask the system to leave that much unused
7503space in the heap of the Emacs process. This should be an integer, and if
7504not given, it defaults to 0.
7505
7506This function returns nil if no memory could be returned to the
7507system, and non-nil if some memory could be returned. */)
7508 (Lisp_Object leave_padding)
7509{
7510 int pad = 0;
7511
7512 if (! NILP (leave_padding))
7513 {
7514 CHECK_FIXNAT (leave_padding);
7515 pad = XFIXNUM (leave_padding);
7516 }
7517
7518 /* 1 means that memory was released to the system. */
7519 if (malloc_trim (pad) == 1)
7520 return Qt;
7521 else
7522 return Qnil;
7523}
7524#endif
7525
7416static bool 7526static bool
7417symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj) 7527symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj)
7418{ 7528{
@@ -7764,6 +7874,9 @@ N should be nonnegative. */);
7764 7874
7765 defsubr (&Smalloc_info); 7875 defsubr (&Smalloc_info);
7766#endif 7876#endif
7877#ifdef HAVE_MALLOC_TRIM
7878 defsubr (&Smalloc_trim);
7879#endif
7767 defsubr (&Ssuspicious_object); 7880 defsubr (&Ssuspicious_object);
7768 7881
7769 Lisp_Object watcher; 7882 Lisp_Object watcher;
@@ -7771,14 +7884,14 @@ N should be nonnegative. */);
7771 static union Aligned_Lisp_Subr Swatch_gc_cons_threshold = 7884 static union Aligned_Lisp_Subr Swatch_gc_cons_threshold =
7772 {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, 7885 {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) },
7773 { .a4 = watch_gc_cons_threshold }, 7886 { .a4 = watch_gc_cons_threshold },
7774 4, 4, "watch_gc_cons_threshold", {0}, 0}}; 7887 4, 4, "watch_gc_cons_threshold", {0}, lisp_h_Qnil}};
7775 XSETSUBR (watcher, &Swatch_gc_cons_threshold.s); 7888 XSETSUBR (watcher, &Swatch_gc_cons_threshold.s);
7776 Fadd_variable_watcher (Qgc_cons_threshold, watcher); 7889 Fadd_variable_watcher (Qgc_cons_threshold, watcher);
7777 7890
7778 static union Aligned_Lisp_Subr Swatch_gc_cons_percentage = 7891 static union Aligned_Lisp_Subr Swatch_gc_cons_percentage =
7779 {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, 7892 {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) },
7780 { .a4 = watch_gc_cons_percentage }, 7893 { .a4 = watch_gc_cons_percentage },
7781 4, 4, "watch_gc_cons_percentage", {0}, 0}}; 7894 4, 4, "watch_gc_cons_percentage", {0}, lisp_h_Qnil}};
7782 XSETSUBR (watcher, &Swatch_gc_cons_percentage.s); 7895 XSETSUBR (watcher, &Swatch_gc_cons_percentage.s);
7783 Fadd_variable_watcher (Qgc_cons_percentage, watcher); 7896 Fadd_variable_watcher (Qgc_cons_percentage, watcher);
7784} 7897}