commit 8ee367fe864d131a9d7f87677b9418ac78c922fa (HEAD, refs/remotes/origin/master) Author: Paul Eggert Date: Thu Jun 4 18:46:11 2020 -0700 Streamline live_*_holding (live_string_holding, live_cons_holding, live_symbol_holding) (live_float_p, live_vector_holding): Assert that m->type is correct, instead of testing this at runtime. All callers changed. (live_large_vector_holding, live_small_vector_holding): Now two functions instead of the old live_vector_holding. All callers changed. (live_large_vector_p, live_small_vector_p): Now two functions instead of the old live_vector_p. All callers changed. (mark_maybe_object): Ignore Lisp_Type_Unused0 quickly too, since that cannot possibly be an object. (CHECK_LIVE, CHECK_ALLOCATED_AND_LIVE): New arg MEM_TYPE. All callers changed. (CHECK_ALLOCATED_AND_LIVE_SYMBOL): Simplify by combining GC_CHECK_MARKED_OBJECTS code. diff --git a/src/alloc.c b/src/alloc.c index 5cb754d237..ed30c44978 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -4449,21 +4449,19 @@ mem_delete_fixup (struct mem_node *x) static struct Lisp_String * live_string_holding (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_STRING) + eassert (m->type == MEM_TYPE_STRING); + struct string_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->strings[0]; + + /* P must point into a Lisp_String structure, and it + must not be on the free-list. */ + if (0 <= offset && offset < sizeof b->strings) { - struct string_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->strings[0]; - - /* P must point into a Lisp_String structure, and it - must not be on the free-list. */ - if (0 <= offset && offset < sizeof b->strings) - { - cp = ptr_bounds_copy (cp, b); - struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0]; - if (s->u.s.data) - return s; - } + cp = ptr_bounds_copy (cp, b); + struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0]; + if (s->u.s.data) + return s; } return NULL; } @@ -4481,24 +4479,22 @@ live_string_p (struct mem_node *m, void *p) static struct Lisp_Cons * live_cons_holding (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_CONS) + eassert (m->type == MEM_TYPE_CONS); + struct cons_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->conses[0]; + + /* P must point into a Lisp_Cons, not be + one of the unused cells in the current cons block, + and not be on the free-list. */ + if (0 <= offset && offset < sizeof b->conses + && (b != cons_block + || offset / sizeof b->conses[0] < cons_block_index)) { - struct cons_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->conses[0]; - - /* P must point into a Lisp_Cons, not be - one of the unused cells in the current cons block, - and not be on the free-list. */ - if (0 <= offset && offset < sizeof b->conses - && (b != cons_block - || offset / sizeof b->conses[0] < cons_block_index)) - { - cp = ptr_bounds_copy (cp, b); - struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0]; - if (!deadp (s->u.s.car)) - return s; - } + cp = ptr_bounds_copy (cp, b); + struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0]; + if (!deadp (s->u.s.car)) + return s; } return NULL; } @@ -4517,24 +4513,22 @@ live_cons_p (struct mem_node *m, void *p) static struct Lisp_Symbol * live_symbol_holding (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_SYMBOL) + eassert (m->type == MEM_TYPE_SYMBOL); + struct symbol_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->symbols[0]; + + /* P must point into the Lisp_Symbol, not be + one of the unused cells in the current symbol block, + and not be on the free-list. */ + if (0 <= offset && offset < sizeof b->symbols + && (b != symbol_block + || offset / sizeof b->symbols[0] < symbol_block_index)) { - struct symbol_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->symbols[0]; - - /* P must point into the Lisp_Symbol, not be - one of the unused cells in the current symbol block, - and not be on the free-list. */ - if (0 <= offset && offset < sizeof b->symbols - && (b != symbol_block - || offset / sizeof b->symbols[0] < symbol_block_index)) - { - cp = ptr_bounds_copy (cp, b); - struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0]; - if (!deadp (s->u.s.function)) - return s; - } + cp = ptr_bounds_copy (cp, b); + struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0]; + if (!deadp (s->u.s.function)) + return s; } return NULL; } @@ -4552,66 +4546,70 @@ live_symbol_p (struct mem_node *m, void *p) static bool live_float_p (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_FLOAT) - { - struct float_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->floats[0]; - - /* P must point to the start of a Lisp_Float and not be - one of the unused cells in the current float block. */ - return (0 <= offset && offset < sizeof b->floats - && offset % sizeof b->floats[0] == 0 - && (b != float_block - || offset / sizeof b->floats[0] < float_block_index)); - } - else - return 0; + eassert (m->type == MEM_TYPE_FLOAT); + struct float_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->floats[0]; + + /* P must point to the start of a Lisp_Float and not be + one of the unused cells in the current float block. */ + return (0 <= offset && offset < sizeof b->floats + && offset % sizeof b->floats[0] == 0 + && (b != float_block + || offset / sizeof b->floats[0] < float_block_index)); } -/* If P is a pointer to a live vector-like object, return the object. +/* If P is a pointer to a live, large vector-like object, return the object. Otherwise, return nil. M is a pointer to the mem_block for P. */ static struct Lisp_Vector * -live_vector_holding (struct mem_node *m, void *p) +live_large_vector_holding (struct mem_node *m, void *p) { + eassert (m->type == MEM_TYPE_VECTORLIKE); struct Lisp_Vector *vp = p; + struct Lisp_Vector *vector = large_vector_vec (m->start); + struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); + return vector <= vp && vp < next ? vector : NULL; +} - if (m->type == MEM_TYPE_VECTOR_BLOCK) - { - /* This memory node corresponds to a vector block. */ - struct vector_block *block = m->start; - struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data; - - /* P is in the block's allocation range. Scan the block - up to P and see whether P points to the start of some - vector which is not on a free list. FIXME: check whether - some allocation patterns (probably a lot of short vectors) - may cause a substantial overhead of this loop. */ - while (VECTOR_IN_BLOCK (vector, block) && vector <= vp) - { - struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); - if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE)) - return vector; - vector = next; - } - } - else if (m->type == MEM_TYPE_VECTORLIKE) +static bool +live_large_vector_p (struct mem_node *m, void *p) +{ + return live_large_vector_holding (m, p) == p; +} + +/* If P is a pointer to a live, small vector-like object, return the object. + Otherwise, return NULL. + M is a pointer to the mem_block for P. */ + +static struct Lisp_Vector * +live_small_vector_holding (struct mem_node *m, void *p) +{ + eassert (m->type == MEM_TYPE_VECTOR_BLOCK); + struct Lisp_Vector *vp = p; + struct vector_block *block = m->start; + struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data; + + /* P is in the block's allocation range. Scan the block + up to P and see whether P points to the start of some + vector which is not on a free list. FIXME: check whether + some allocation patterns (probably a lot of short vectors) + may cause a substantial overhead of this loop. */ + while (VECTOR_IN_BLOCK (vector, block) && vector <= vp) { - /* This memory node corresponds to a large vector. */ - struct Lisp_Vector *vector = large_vector_vec (m->start); struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); - if (vector <= vp && vp < next) + if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE)) return vector; + vector = next; } return NULL; } static bool -live_vector_p (struct mem_node *m, void *p) +live_small_vector_p (struct mem_node *m, void *p) { - return live_vector_holding (m, p) == p; + return live_small_vector_holding (m, p) == p; } /* Mark OBJ if we can prove it's a Lisp_Object. */ @@ -4623,10 +4621,24 @@ mark_maybe_object (Lisp_Object obj) VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj)); #endif - if (FIXNUMP (obj)) - return; + int type_tag = XTYPE (obj); + intptr_t offset; - void *po = XPNTR (obj); + switch (type_tag) + { + case_Lisp_Int: case Lisp_Type_Unused0: + return; + + case Lisp_Symbol: + offset = (intptr_t) lispsym; + break; + + default: + offset = 0; + break; + } + + void *po = (char *) XLP (obj) + (offset - LISP_WORD_TAG (type_tag)); /* If the pointer is in the dump image and the dump has a record of the object starting at the place where the pointer points, we @@ -4638,7 +4650,7 @@ mark_maybe_object (Lisp_Object obj) /* Don't use pdumper_object_p_precise here! It doesn't check the tag bits. OBJ here might be complete garbage, so we need to verify both the pointer and the tag. */ - if (XTYPE (obj) == pdumper_find_object_type (po)) + if (pdumper_find_object_type (po) == type_tag) mark_object (obj); return; } @@ -4649,30 +4661,33 @@ mark_maybe_object (Lisp_Object obj) { bool mark_p = false; - switch (XTYPE (obj)) + switch (type_tag) { case Lisp_String: - mark_p = live_string_p (m, po); + mark_p = m->type == MEM_TYPE_STRING && live_string_p (m, po); break; case Lisp_Cons: - mark_p = live_cons_p (m, po); + mark_p = m->type == MEM_TYPE_CONS && live_cons_p (m, po); break; case Lisp_Symbol: - mark_p = live_symbol_p (m, po); + mark_p = m->type == MEM_TYPE_SYMBOL && live_symbol_p (m, po); break; case Lisp_Float: - mark_p = live_float_p (m, po); + mark_p = m->type == MEM_TYPE_FLOAT && live_float_p (m, po); break; case Lisp_Vectorlike: - mark_p = live_vector_p (m, po); + mark_p = (m->type == MEM_TYPE_VECTOR_BLOCK + ? live_small_vector_p (m, po) + : (m->type == MEM_TYPE_VECTORLIKE + && live_large_vector_p (m, po))); break; default: - break; + eassume (false); } if (mark_p) @@ -4756,9 +4771,17 @@ mark_maybe_pointer (void *p) break; case MEM_TYPE_VECTORLIKE: + { + struct Lisp_Vector *h = live_large_vector_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_Vectorlike); + } + break; + case MEM_TYPE_VECTOR_BLOCK: { - struct Lisp_Vector *h = live_vector_holding (m, p); + struct Lisp_Vector *h = live_small_vector_holding (m, p); if (!h) return; obj = make_lisp_ptr (h, Lisp_Vectorlike); @@ -5176,8 +5199,10 @@ valid_lisp_object_p (Lisp_Object obj) return live_float_p (m, p); case MEM_TYPE_VECTORLIKE: + return live_large_vector_p (m, p); + case MEM_TYPE_VECTOR_BLOCK: - return live_vector_p (m, p); + return live_small_vector_p (m, p); default: break; @@ -6551,19 +6576,19 @@ mark_object (Lisp_Object arg) /* Check that the object pointed to by PO is live, using predicate function LIVEP. */ -#define CHECK_LIVE(LIVEP) \ +#define CHECK_LIVE(LIVEP, MEM_TYPE) \ do { \ if (pdumper_object_p (po)) \ break; \ - if (!LIVEP (m, po)) \ + if (! (m->type == MEM_TYPE && LIVEP (m, po))) \ emacs_abort (); \ } while (0) /* Check both of the above conditions, for non-symbols. */ -#define CHECK_ALLOCATED_AND_LIVE(LIVEP) \ +#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) \ do { \ CHECK_ALLOCATED (); \ - CHECK_LIVE (LIVEP); \ + CHECK_LIVE (LIVEP, MEM_TYPE); \ } while (false) /* Check both of the above conditions, for symbols. */ @@ -6572,15 +6597,14 @@ mark_object (Lisp_Object arg) if (!c_symbol_p (ptr)) \ { \ CHECK_ALLOCATED (); \ - CHECK_LIVE (live_symbol_p); \ + CHECK_LIVE (live_symbol_p, MEM_TYPE_SYMBOL); \ } \ } while (false) #else /* not GC_CHECK_MARKED_OBJECTS */ -#define CHECK_LIVE(LIVEP) ((void) 0) -#define CHECK_ALLOCATED_AND_LIVE(LIVEP) ((void) 0) -#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0) +#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) ((void) 0) +#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0) #endif /* not GC_CHECK_MARKED_OBJECTS */ @@ -6591,7 +6615,7 @@ mark_object (Lisp_Object arg) register struct Lisp_String *ptr = XSTRING (obj); if (string_marked_p (ptr)) break; - CHECK_ALLOCATED_AND_LIVE (live_string_p); + CHECK_ALLOCATED_AND_LIVE (live_string_p, MEM_TYPE_STRING); set_string_marked (ptr); mark_interval_tree (ptr->u.s.intervals); #ifdef GC_CHECK_STRING_BYTES @@ -6609,21 +6633,21 @@ mark_object (Lisp_Object arg) if (vector_marked_p (ptr)) break; + enum pvec_type pvectype + = PSEUDOVECTOR_TYPE (ptr); + #ifdef GC_CHECK_MARKED_OBJECTS - if (!pdumper_object_p (po)) + if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po)) { m = mem_find (po); - if (m == MEM_NIL && !SUBRP (obj) && !main_thread_p (po)) + if (m == MEM_NIL) emacs_abort (); + if (m->type == MEM_TYPE_VECTORLIKE) + CHECK_LIVE (live_large_vector_p, MEM_TYPE_VECTORLIKE); + else + CHECK_LIVE (live_small_vector_p, MEM_TYPE_VECTOR_BLOCK); } -#endif /* GC_CHECK_MARKED_OBJECTS */ - - enum pvec_type pvectype - = PSEUDOVECTOR_TYPE (ptr); - - if (pvectype != PVEC_SUBR && - !main_thread_p (po)) - CHECK_LIVE (live_vector_p); +#endif switch (pvectype) { @@ -6734,7 +6758,7 @@ mark_object (Lisp_Object arg) struct Lisp_Cons *ptr = XCONS (obj); if (cons_marked_p (ptr)) break; - CHECK_ALLOCATED_AND_LIVE (live_cons_p); + CHECK_ALLOCATED_AND_LIVE (live_cons_p, MEM_TYPE_CONS); set_cons_marked (ptr); /* If the cdr is nil, avoid recursion for the car. */ if (NILP (ptr->u.s.u.cdr)) @@ -6752,7 +6776,7 @@ mark_object (Lisp_Object arg) } case Lisp_Float: - CHECK_ALLOCATED_AND_LIVE (live_float_p); + CHECK_ALLOCATED_AND_LIVE (live_float_p, MEM_TYPE_FLOAT); /* Do not mark floats stored in a dump image: these floats are "cold" and do not have mark bits. */ if (pdumper_object_p (XFLOAT (obj))) commit 4dcf8f2205fcfb45b460a2256569e64a03f93b4a Author: Paul Eggert Date: Thu Jun 4 18:46:10 2020 -0700 Make live_*_p more accurate * src/alloc.c (live_string_holding, live_cons_holding) (live_symbol_holding, live_vector_holding): Return a C pointer, not a Lisp_Object. All callers changed. This helps the compiler a bit. (live_string_p, live_cons_p, live_symbol_p, live_vector_p): Require that P point directly at the object, rather than somewhere within the object. This fixes some false positives with valid_lisp_object_p (used only in debugging). (mark_maybe_object): Rely on the new accuracy. diff --git a/src/alloc.c b/src/alloc.c index f44f22be1a..5cb754d237 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -4438,7 +4438,7 @@ mem_delete_fixup (struct mem_node *x) /* If P is a pointer into a live Lisp string object on the heap, - return the object. Otherwise, return nil. M is a pointer to the + return the object's address. Otherwise, return NULL. M points to the mem_block for P. This and other *_holding functions look for a pointer anywhere into @@ -4446,7 +4446,7 @@ mem_delete_fixup (struct mem_node *x) because some compilers sometimes optimize away the latter. See Bug#28213. */ -static Lisp_Object +static struct Lisp_String * live_string_holding (struct mem_node *m, void *p) { if (m->type == MEM_TYPE_STRING) @@ -4462,23 +4462,23 @@ live_string_holding (struct mem_node *m, void *p) cp = ptr_bounds_copy (cp, b); struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0]; if (s->u.s.data) - return make_lisp_ptr (s, Lisp_String); + return s; } } - return Qnil; + return NULL; } static bool live_string_p (struct mem_node *m, void *p) { - return !NILP (live_string_holding (m, p)); + return live_string_holding (m, p) == p; } /* If P is a pointer into a live Lisp cons object on the heap, return - the object. Otherwise, return nil. M is a pointer to the + the object's address. Otherwise, return NULL. M points to the mem_block for P. */ -static Lisp_Object +static struct Lisp_Cons * live_cons_holding (struct mem_node *m, void *p) { if (m->type == MEM_TYPE_CONS) @@ -4497,24 +4497,24 @@ live_cons_holding (struct mem_node *m, void *p) cp = ptr_bounds_copy (cp, b); struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0]; if (!deadp (s->u.s.car)) - return make_lisp_ptr (s, Lisp_Cons); + return s; } } - return Qnil; + return NULL; } static bool live_cons_p (struct mem_node *m, void *p) { - return !NILP (live_cons_holding (m, p)); + return live_cons_holding (m, p) == p; } /* If P is a pointer into a live Lisp symbol object on the heap, - return the object. Otherwise, return nil. M is a pointer to the + return the object's address. Otherwise, return NULL. M points to the mem_block for P. */ -static Lisp_Object +static struct Lisp_Symbol * live_symbol_holding (struct mem_node *m, void *p) { if (m->type == MEM_TYPE_SYMBOL) @@ -4533,16 +4533,16 @@ live_symbol_holding (struct mem_node *m, void *p) cp = ptr_bounds_copy (cp, b); struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0]; if (!deadp (s->u.s.function)) - return make_lisp_symbol (s); + return s; } } - return Qnil; + return NULL; } static bool live_symbol_p (struct mem_node *m, void *p) { - return !NILP (live_symbol_holding (m, p)); + return live_symbol_holding (m, p) == p; } @@ -4573,7 +4573,7 @@ live_float_p (struct mem_node *m, void *p) Otherwise, return nil. M is a pointer to the mem_block for P. */ -static Lisp_Object +static struct Lisp_Vector * live_vector_holding (struct mem_node *m, void *p) { struct Lisp_Vector *vp = p; @@ -4593,7 +4593,7 @@ live_vector_holding (struct mem_node *m, void *p) { struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE)) - return make_lisp_ptr (vector, Lisp_Vectorlike); + return vector; vector = next; } } @@ -4603,15 +4603,15 @@ live_vector_holding (struct mem_node *m, void *p) struct Lisp_Vector *vector = large_vector_vec (m->start); struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); if (vector <= vp && vp < next) - return make_lisp_ptr (vector, Lisp_Vectorlike); + return vector; } - return Qnil; + return NULL; } static bool live_vector_p (struct mem_node *m, void *p) { - return !NILP (live_vector_holding (m, p)); + return live_vector_holding (m, p) == p; } /* Mark OBJ if we can prove it's a Lisp_Object. */ @@ -4652,15 +4652,15 @@ mark_maybe_object (Lisp_Object obj) switch (XTYPE (obj)) { case Lisp_String: - mark_p = EQ (obj, live_string_holding (m, po)); + mark_p = live_string_p (m, po); break; case Lisp_Cons: - mark_p = EQ (obj, live_cons_holding (m, po)); + mark_p = live_cons_p (m, po); break; case Lisp_Symbol: - mark_p = EQ (obj, live_symbol_holding (m, po)); + mark_p = live_symbol_p (m, po); break; case Lisp_Float: @@ -4668,7 +4668,7 @@ mark_maybe_object (Lisp_Object obj) break; case Lisp_Vectorlike: - mark_p = (EQ (obj, live_vector_holding (m, po))); + mark_p = live_vector_p (m, po); break; default: @@ -4713,43 +4713,63 @@ mark_maybe_pointer (void *p) m = mem_find (p); if (m != MEM_NIL) { - Lisp_Object obj = Qnil; + Lisp_Object obj; switch (m->type) { case MEM_TYPE_NON_LISP: case MEM_TYPE_SPARE: /* Nothing to do; not a pointer to Lisp memory. */ - break; + return; case MEM_TYPE_CONS: - obj = live_cons_holding (m, p); + { + struct Lisp_Cons *h = live_cons_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_Cons); + } break; case MEM_TYPE_STRING: - obj = live_string_holding (m, p); + { + struct Lisp_String *h = live_string_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_String); + } break; case MEM_TYPE_SYMBOL: - obj = live_symbol_holding (m, p); + { + struct Lisp_Symbol *h = live_symbol_holding (m, p); + if (!h) + return; + obj = make_lisp_symbol (h); + } break; case MEM_TYPE_FLOAT: - if (live_float_p (m, p)) - obj = make_lisp_ptr (p, Lisp_Float); + if (! live_float_p (m, p)) + return; + obj = make_lisp_ptr (p, Lisp_Float); break; case MEM_TYPE_VECTORLIKE: case MEM_TYPE_VECTOR_BLOCK: - obj = live_vector_holding (m, p); + { + struct Lisp_Vector *h = live_vector_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_Vectorlike); + } break; default: emacs_abort (); } - if (!NILP (obj)) - mark_object (obj); + mark_object (obj); } } @@ -5679,7 +5699,7 @@ compact_font_cache_entry (Lisp_Object entry) struct font *font = GC_XFONT_OBJECT (val); if (!NILP (AREF (val, FONT_TYPE_INDEX)) - && vectorlike_marked_p(&font->header)) + && vectorlike_marked_p (&font->header)) break; } if (CONSP (objlist)) @@ -6518,7 +6538,7 @@ mark_object (Lisp_Object arg) structure allocated from the heap. */ #define CHECK_ALLOCATED() \ do { \ - if (pdumper_object_p(po)) \ + if (pdumper_object_p (po)) \ { \ if (!pdumper_object_p_precise (po)) \ emacs_abort (); \ @@ -6533,7 +6553,7 @@ mark_object (Lisp_Object arg) function LIVEP. */ #define CHECK_LIVE(LIVEP) \ do { \ - if (pdumper_object_p(po)) \ + if (pdumper_object_p (po)) \ break; \ if (!LIVEP (m, po)) \ emacs_abort (); \ @@ -6590,7 +6610,7 @@ mark_object (Lisp_Object arg) break; #ifdef GC_CHECK_MARKED_OBJECTS - if (!pdumper_object_p(po)) + if (!pdumper_object_p (po)) { m = mem_find (po); if (m == MEM_NIL && !SUBRP (obj) && !main_thread_p (po)) @@ -6642,7 +6662,7 @@ mark_object (Lisp_Object arg) /* bool vectors in a dump are permanently "marked", since they're in the old section and don't have mark bits. If we're looking at a dumped bool vector, we should - have aborted above when we called vector_marked_p(), so + have aborted above when we called vector_marked_p, so we should never get here. */ eassert (!pdumper_object_p (ptr)); set_vector_marked (ptr); @@ -6673,7 +6693,7 @@ mark_object (Lisp_Object arg) if (symbol_marked_p (ptr)) break; CHECK_ALLOCATED_AND_LIVE_SYMBOL (); - set_symbol_marked(ptr); + set_symbol_marked (ptr); /* Attempt to catch bogus objects. */ eassert (valid_lisp_object_p (ptr->u.s.function)); mark_object (ptr->u.s.function); commit f51f9634788323b3bf2dde59d0d20a8ca8fbfeaf Author: Basil L. Contovounesios Date: Thu Jun 4 23:08:28 2020 +0100 Fix some side-effecting uses of make-text-button For discussion, see the following thread: https://lists.gnu.org/archive/html/emacs-devel/2020-06/msg00117.html * lisp/apropos.el (apropos-library-button): * lisp/help-fns.el (help-fns--first-release): Return result of make-text-button instead of relying on its side effects. * lisp/ibuf-ext.el (ibuffer-old-saved-filters-warning): Avoid modifying an immutable string. diff --git a/lisp/apropos.el b/lisp/apropos.el index 7cbda3cb67..22866cd2cc 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -665,8 +665,7 @@ Return list of symbols and documentation found." (make-text-button name nil 'type 'apropos-library 'face 'apropos-symbol - 'apropos-symbol name) - name))) + 'apropos-symbol name)))) ;;;###autoload (defun apropos-library (file) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 63b066f3b8..b953647063 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -647,8 +647,7 @@ FILE is the file where FUNCTION was probably defined." (setq place (list f pos)) (setq first version))))))))) (when first - (make-text-button first nil 'type 'help-news 'help-args place)) - first)) + (make-text-button first nil 'type 'help-news 'help-args place)))) (add-hook 'help-fns-describe-function-functions #'help-fns--mention-first-release) diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index bfb9787a96..c39000b488 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -202,7 +202,7 @@ The format has been repaired and the variable modified accordingly. You can save the current value through the customize system by either clicking or hitting return " (make-text-button - "here" nil + (copy-sequence "here") nil 'face '(:weight bold :inherit button) 'mouse-face '(:weight normal :background "gray50" :inherit button) 'follow-link t commit 25390b28c43401caee749554871217d3436ea9bd Author: Juri Linkov Date: Fri Jun 5 01:17:30 2020 +0300 * lisp/dired.el (dired-toggle-marks): Use region for non-nil dired-mark-region (dired-mark--region-use-p, dired-mark--region-beginning) (dired-mark--region-end): New internal functions. (dired-mark-if): Use new functions. (Bug#39902) diff --git a/lisp/dired.el b/lisp/dired.el index aad44a6d69..1792250ac9 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -648,24 +648,10 @@ of the region if `dired-mark-region' is non-nil. Otherwise, operate on the whole buffer. Return value is the number of files marked, or nil if none were marked." - `(let* ((inhibit-read-only t) count - (use-region-p (and dired-mark-region - (region-active-p) - (> (region-end) (region-beginning)))) - (beg (if use-region-p - (save-excursion - (goto-char (region-beginning)) - (line-beginning-position)) - (point-min))) - (end (if use-region-p - (save-excursion - (goto-char (region-end)) - (if (if (eq dired-mark-region 'line) - (not (bolp)) - (get-text-property (1- (point)) 'dired-filename)) - (line-end-position) - (line-beginning-position))) - (point-max)))) + `(let ((inhibit-read-only t) count + (use-region-p (dired-mark--region-use-p)) + (beg (dired-mark--region-beginning)) + (end (dired-mark--region-end))) (save-excursion (setq count 0) (when ,msg @@ -817,6 +803,32 @@ ERROR can be a string with the error message." (user-error (if (stringp error) error "No files specified"))) result)) +(defun dired-mark--region-use-p () + "Whether Dired marking commands should act on region." + (and dired-mark-region + (region-active-p) + (> (region-end) (region-beginning)))) + +(defun dired-mark--region-beginning () + "Return the value of the region beginning aligned to Dired file lines." + (if (dired-mark--region-use-p) + (save-excursion + (goto-char (region-beginning)) + (line-beginning-position)) + (point-min))) + +(defun dired-mark--region-end () + "Return the value of the region end aligned to Dired file lines." + (if (dired-mark--region-use-p) + (save-excursion + (goto-char (region-end)) + (if (if (eq dired-mark-region 'line) + (not (bolp)) + (get-text-property (1- (point)) 'dired-filename)) + (line-end-position) + (line-beginning-position))) + (point-max))) + ;; The dired command @@ -3719,12 +3731,18 @@ in the active region." "Toggle marks: marked files become unmarked, and vice versa. Flagged files (indicated with flags such as `C' and `D', not with `*') are not affected, and `.' and `..' are never toggled. -As always, hidden subdirs are not affected." +As always, hidden subdirs are not affected. + +In Transient Mark mode, if the mark is active, operate on the contents +of the region if `dired-mark-region' is non-nil. Otherwise, operate +on the whole buffer." (interactive) (save-excursion - (goto-char (point-min)) - (let ((inhibit-read-only t)) - (while (not (eobp)) + (let ((inhibit-read-only t) + (beg (dired-mark--region-beginning)) + (end (dired-mark--region-end))) + (goto-char beg) + (while (< (point) end) (or (dired-between-files) (looking-at-p dired-re-dot) ;; use subst instead of insdel because it does not move commit f4568bac56968c2d7837d6f5be561f3cf4430388 Author: Simen Heggestøyl Date: Thu Jun 4 19:58:36 2020 +0200 Change default project list filename to "projects" * lisp/progmodes/project.el (project-list-file): Change the default filename to "projects". diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index ad0bb6763a..4d57fb25fd 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -747,7 +747,7 @@ Arguments the same as in `compile'." ;;; Project list -(defcustom project-list-file (locate-user-emacs-file "project-list") +(defcustom project-list-file (locate-user-emacs-file "projects") "File to save the list of known projects." :type 'file :version "28.1" commit e7fb0a48a65c986e75d39848cac3c4d2435f4baa Author: Simen Heggestøyl Date: Thu Jun 4 19:56:32 2020 +0200 Use characters for keys in project-switch-commands * lisp/progmodes/project.el (project-switch-commands): Use characters for keys instead of string for better future compatibility with 'read-multiple-choice'. (project-switch-project): Adjust to above change. diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index c5b6209d9b..ad0bb6763a 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -824,12 +824,12 @@ It's also possible to enter an arbitrary directory." ;;;###autoload (defvar project-switch-commands - '(("f" "Find file" project-find-file) - ("r" "Find regexp" project-find-regexp) - ("d" "Dired" project-dired) - ("v" "VC-Dir" project-vc-dir) - ("s" "Shell" project-shell) - ("e" "Eshell" project-eshell)) + '((?f "Find file" project-find-file) + (?r "Find regexp" project-find-regexp) + (?d "Dired" project-dired) + (?v "VC-Dir" project-vc-dir) + (?s "Shell" project-shell) + (?e "Eshell" project-eshell)) "Alist mapping keys to project switching menu entries. Used by `project-switch-project' to construct a dispatch menu of commands available upon \"switching\" to another project. @@ -856,16 +856,12 @@ and presented in a dispatch menu." (interactive) (let ((dir (project-prompt-project-dir)) (choice nil)) - (while (not (and choice - (or (equal choice (kbd "C-g")) - (assoc choice project-switch-commands)))) - (setq choice (read-key-sequence (project--keymap-prompt)))) - (if (equal choice (kbd "C-g")) - (message "Quit") - (let ((default-directory dir) - (project-current-inhibit-prompt t)) - (call-interactively - (nth 2 (assoc choice project-switch-commands))))))) + (while (not choice) + (setq choice (assq (read-event (project--keymap-prompt)) + project-switch-commands))) + (let ((default-directory dir) + (project-current-inhibit-prompt t)) + (call-interactively (nth 2 choice))))) (provide 'project) ;;; project.el ends here commit b41be0ee83bdcc7882b360b66105f192503f0dc7 Author: Simen Heggestøyl Date: Thu Jun 4 19:29:10 2020 +0200 ; Small cleanup in project.el * lisp/progmodes/project.el (project--add-to-project-list-front): Minor simplification after recent changes. diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index c701b80159..c5b6209d9b 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -787,9 +787,8 @@ Arguments the same as in `compile'." "Add project PR to the front of the project list. Save the result to disk if the project list was changed." (project--ensure-read-project-list) - (let* ((dir (project-root pr)) - (do-write (not (equal (car project--list) dir)))) - (when do-write + (let ((dir (project-root pr))) + (unless (equal (car project--list) dir) (setq project--list (delete dir project--list)) (push dir project--list) (project--write-project-list)))) commit cdadb7a97cbed523af9f52705d8b03e91d17313f Author: Stefan Monnier Date: Thu Jun 4 09:58:22 2020 -0400 * lisp/font-lock.el (font-lock--syntax-table-affects-ppss): New var This tries to make `font-lock-syntax-table` work correctly even when it changes the parsing of strings and comments, as was the case in `font-latex.el`. We should probably deprecate the use of `font-lock-syntax-table` since the present fix is still not 100% and since it comes with performance problems in large files. (font-lock-set-defaults): Set it. (font-lock-fontify-syntactically-region): Don't use `syntax-ppss` when we think that `font-lock-syntax-table` would interfere. diff --git a/lisp/font-lock.el b/lisp/font-lock.el index e0955b74ab..5cda4a693d 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -575,6 +575,7 @@ This is normally set via `font-lock-defaults'.") "Non-nil means use this syntax table for fontifying. If this is nil, the major mode's syntax table is used. This is normally set via `font-lock-defaults'.") +(defvar-local font-lock--syntax-table-affects-ppss nil) (defvar font-lock-mark-block-function nil "Non-nil means use this function to mark a block of text. @@ -1610,7 +1611,15 @@ START should be at the beginning of a line." (regexp-quote (replace-regexp-in-string "^ *" "" comment-end)))) ;; Find the `start' state. - (state (syntax-ppss start)) + (state (if (or syntax-ppss-table + (not font-lock--syntax-table-affects-ppss)) + (syntax-ppss start) + ;; If `syntax-ppss' doesn't have its own syntax-table and + ;; we have installed our own syntax-table which + ;; differs from the standard one in ways which affects PPSS, + ;; then we can't use `syntax-ppss' since that would pollute + ;; and be polluted by its cache. + (parse-partial-sexp (point-min) start))) face beg) (if loudly (message "Fontifying %s... (syntactically...)" (buffer-name))) ;; @@ -1907,6 +1916,7 @@ Sets various variables using `font-lock-defaults' and ;; Case fold during regexp fontification? (setq-local font-lock-keywords-case-fold-search (nth 2 defaults)) ;; Syntax table for regexp and syntactic fontification? + (kill-local-variable 'font-lock--syntax-table-affects-ppss) (if (null (nth 3 defaults)) (setq-local font-lock-syntax-table nil) (setq-local font-lock-syntax-table (copy-syntax-table (syntax-table))) @@ -1916,7 +1926,14 @@ Sets various variables using `font-lock-defaults' and (dolist (char (if (numberp (car selem)) (list (car selem)) (mapcar #'identity (car selem)))) - (modify-syntax-entry char syntax font-lock-syntax-table))))) + (unless (memq (car (aref font-lock-syntax-table char)) + '(1 2 3)) ;"." "w" "_" + (setq font-lock--syntax-table-affects-ppss t)) + (modify-syntax-entry char syntax font-lock-syntax-table) + (unless (memq (car (aref font-lock-syntax-table char)) + '(1 2 3)) ;"." "w" "_" + (setq font-lock--syntax-table-affects-ppss t)) + )))) ;; (nth 4 defaults) used to hold `font-lock-beginning-of-syntax-function', ;; but that was removed in 25.1, so if it's a cons cell, we assume that ;; it's part of the variable alist. commit 4fff6502368e87b3c031589a1a96267243f868b0 Author: Mattias Engdegård Date: Thu Jun 4 10:55:16 2020 +0200 ; * test/src/xfaces-tests.el (xfaces-color-distance): Fix bug id diff --git a/test/src/xfaces-tests.el b/test/src/xfaces-tests.el index f08a87a518..5ed16c9e51 100644 --- a/test/src/xfaces-tests.el +++ b/test/src/xfaces-tests.el @@ -20,7 +20,7 @@ (require 'ert) (ert-deftest xfaces-color-distance () - ;; Check symmetry (bug#51455). + ;; Check symmetry (bug#41544). (should (equal (color-distance "#222222" "#ffffff") (color-distance "#ffffff" "#222222"))))