diff options
| -rw-r--r-- | src/alloc.c | 325 |
1 files changed, 193 insertions, 132 deletions
diff --git a/src/alloc.c b/src/alloc.c index 6e57b2024bc..300f5e420d3 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -2961,25 +2961,23 @@ verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS)); /* Common shortcut to advance vector pointer over a block data. */ -#define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes))) +static struct Lisp_Vector * +ADVANCE (struct Lisp_Vector *v, ptrdiff_t nbytes) +{ + void *vv = v; + char *cv = vv; + void *p = cv + nbytes; + return p; +} /* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */ -#define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size) - -/* Common shortcut to setup vector on a free list. */ - -#define SETUP_ON_FREE_LIST(v, nbytes, tmp) \ - do { \ - (tmp) = ((nbytes - header_size) / word_size); \ - XSETPVECTYPESIZE (v, PVEC_FREE, 0, (tmp)); \ - eassert ((nbytes) % roundup_size == 0); \ - (tmp) = VINDEX (nbytes); \ - eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \ - set_next_vector (v, vector_free_lists[tmp]); \ - vector_free_lists[tmp] = (v); \ - total_free_vector_slots += (nbytes) / word_size; \ - } while (0) +static ptrdiff_t +VINDEX (ptrdiff_t nbytes) +{ + eassume (VBLOCK_BYTES_MIN <= nbytes); + return (nbytes - VBLOCK_BYTES_MIN) / roundup_size; +} /* This internal type is used to maintain the list of large vectors which are allocated at their own, e.g. outside of vector blocks. @@ -3041,6 +3039,22 @@ static EMACS_INT total_vectors; static EMACS_INT total_vector_slots, total_free_vector_slots; +/* Common shortcut to setup vector on a free list. */ + +static void +setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes) +{ + eassume (header_size <= nbytes); + ptrdiff_t nwords = (nbytes - header_size) / word_size; + XSETPVECTYPESIZE (v, PVEC_FREE, 0, nwords); + eassert (nbytes % roundup_size == 0); + ptrdiff_t vindex = VINDEX (nbytes); + eassert (vindex < VECTOR_MAX_FREE_LIST_INDEX); + set_next_vector (v, vector_free_lists[vindex]); + vector_free_lists[vindex] = v; + total_free_vector_slots += nbytes / word_size; +} + /* Get a new vector block. */ static struct vector_block * @@ -3105,7 +3119,7 @@ allocate_vector_from_block (size_t nbytes) which should be set on an appropriate free list. */ restbytes = index * roundup_size + VBLOCK_BYTES_MIN - nbytes; eassert (restbytes % roundup_size == 0); - SETUP_ON_FREE_LIST (ADVANCE (vector, nbytes), restbytes, index); + setup_on_free_list (ADVANCE (vector, nbytes), restbytes); return vector; } @@ -3121,7 +3135,7 @@ allocate_vector_from_block (size_t nbytes) if (restbytes >= VBLOCK_BYTES_MIN) { eassert (restbytes % roundup_size == 0); - SETUP_ON_FREE_LIST (ADVANCE (vector, nbytes), restbytes, index); + setup_on_free_list (ADVANCE (vector, nbytes), restbytes); } return vector; } @@ -3253,10 +3267,7 @@ sweep_vectors (void) space was coalesced into the only free vector. */ free_this_block = 1; else - { - size_t tmp; - SETUP_ON_FREE_LIST (vector, total_bytes, tmp); - } + setup_on_free_list (vector, total_bytes); } } @@ -4171,7 +4182,7 @@ refill_memory_reserve (void) block to the red-black tree with calls to mem_insert, and function lisp_free removes it with mem_delete. Functions live_string_p etc call mem_find to lookup information about a given pointer in the - tree, and use that to determine if the pointer points to a Lisp + tree, and use that to determine if the pointer points into a Lisp object or not. */ /* Initialize this part of alloc.c. */ @@ -4549,82 +4560,113 @@ mem_delete_fixup (struct mem_node *x) } -/* Value is non-zero if P is a pointer to a live Lisp string on - the heap. M is a pointer to the mem_block for P. */ +/* 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 + mem_block for P. -static bool -live_string_p (struct mem_node *m, void *p) + This and other *_holding functions look for a pointer anywhere into + the object, not merely for a pointer to the start of the object, + because some compilers sometimes optimize away the latter. See + Bug#28213. */ + +static Lisp_Object +live_string_holding (struct mem_node *m, void *p) { if (m->type == MEM_TYPE_STRING) { struct string_block *b = m->start; - ptrdiff_t offset = (char *) p - (char *) &b->strings[0]; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->strings[0]; - /* P must point to the start of a Lisp_String structure, and it + /* P must point into a Lisp_String structure, and it must not be on the free-list. */ - return (offset >= 0 - && offset % sizeof b->strings[0] == 0 - && offset < (STRING_BLOCK_SIZE * sizeof b->strings[0]) - && ((struct Lisp_String *) p)->data != NULL); + if (0 <= offset && offset < STRING_BLOCK_SIZE * sizeof b->strings[0]) + { + struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0]; + if (s->data) + return make_lisp_ptr (s, Lisp_String); + } } - else - return 0; + return Qnil; } +static bool +live_string_p (struct mem_node *m, void *p) +{ + return !NILP (live_string_holding (m, p)); +} -/* Value is non-zero if P is a pointer to a live Lisp cons on - the heap. M is a pointer to the mem_block for 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 + mem_block for P. */ -static bool -live_cons_p (struct mem_node *m, void *p) +static Lisp_Object +live_cons_holding (struct mem_node *m, void *p) { if (m->type == MEM_TYPE_CONS) { struct cons_block *b = m->start; - ptrdiff_t offset = (char *) p - (char *) &b->conses[0]; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->conses[0]; - /* P must point to the start of a Lisp_Cons, not be + /* 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. */ - return (offset >= 0 - && offset % sizeof b->conses[0] == 0 - && offset < (CONS_BLOCK_SIZE * sizeof b->conses[0]) - && (b != cons_block - || offset / sizeof b->conses[0] < cons_block_index) - && !EQ (((struct Lisp_Cons *) p)->car, Vdead)); + if (0 <= offset && offset < CONS_BLOCK_SIZE * sizeof b->conses[0] + && (b != cons_block + || offset / sizeof b->conses[0] < cons_block_index)) + { + struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0]; + if (!EQ (s->car, Vdead)) + return make_lisp_ptr (s, Lisp_Cons); + } } - else - return 0; + return Qnil; } +static bool +live_cons_p (struct mem_node *m, void *p) +{ + return !NILP (live_cons_holding (m, p)); +} -/* Value is non-zero if P is a pointer to a live Lisp symbol on - the heap. M is a pointer to the mem_block for P. */ -static bool -live_symbol_p (struct mem_node *m, void *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 + mem_block for P. */ + +static Lisp_Object +live_symbol_holding (struct mem_node *m, void *p) { if (m->type == MEM_TYPE_SYMBOL) { struct symbol_block *b = m->start; - ptrdiff_t offset = (char *) p - (char *) &b->symbols[0]; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->symbols[0]; - /* P must point to the start of a Lisp_Symbol, not be + /* 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. */ - return (offset >= 0 - && offset % sizeof b->symbols[0] == 0 - && offset < (SYMBOL_BLOCK_SIZE * sizeof b->symbols[0]) - && (b != symbol_block - || offset / sizeof b->symbols[0] < symbol_block_index) - && !EQ (((struct Lisp_Symbol *)p)->function, Vdead)); + if (0 <= offset && offset < SYMBOL_BLOCK_SIZE * sizeof b->symbols[0] + && (b != symbol_block + || offset / sizeof b->symbols[0] < symbol_block_index)) + { + struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0]; + if (!EQ (s->function, Vdead)) + return make_lisp_symbol (s); + } } - else - return 0; + return Qnil; } +static bool +live_symbol_p (struct mem_node *m, void *p) +{ + return !NILP (live_symbol_holding (m, p)); +} -/* Value is non-zero if P is a pointer to a live Lisp float on + +/* Return true if P is a pointer to a live Lisp float on the heap. M is a pointer to the mem_block for P. */ static bool @@ -4633,7 +4675,8 @@ live_float_p (struct mem_node *m, void *p) if (m->type == MEM_TYPE_FLOAT) { struct float_block *b = m->start; - ptrdiff_t offset = (char *) p - (char *) &b->floats[0]; + 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. */ @@ -4648,38 +4691,48 @@ live_float_p (struct mem_node *m, void *p) } -/* Value is non-zero if P is a pointer to a live Lisp Misc on - the heap. M is a pointer to the mem_block for P. */ +/* If P is a pointer to a live Lisp Misc on the heap, return the object. + Otherwise, return nil. M is a pointer to the mem_block for P. */ -static bool -live_misc_p (struct mem_node *m, void *p) +static Lisp_Object +live_misc_holding (struct mem_node *m, void *p) { if (m->type == MEM_TYPE_MISC) { struct marker_block *b = m->start; - ptrdiff_t offset = (char *) p - (char *) &b->markers[0]; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->markers[0]; - /* P must point to the start of a Lisp_Misc, not be + /* P must point into a Lisp_Misc, not be one of the unused cells in the current misc block, and not be on the free-list. */ - return (offset >= 0 - && offset % sizeof b->markers[0] == 0 - && offset < (MARKER_BLOCK_SIZE * sizeof b->markers[0]) - && (b != marker_block - || offset / sizeof b->markers[0] < marker_block_index) - && ((union Lisp_Misc *) p)->u_any.type != Lisp_Misc_Free); + if (0 <= offset && offset < MARKER_BLOCK_SIZE * sizeof b->markers[0] + && (b != marker_block + || offset / sizeof b->markers[0] < marker_block_index)) + { + union Lisp_Misc *s = p = cp -= offset % sizeof b->markers[0]; + if (s->u_any.type != Lisp_Misc_Free) + return make_lisp_ptr (s, Lisp_Misc); + } } - else - return 0; + return Qnil; } +static bool +live_misc_p (struct mem_node *m, void *p) +{ + return !NILP (live_misc_holding (m, p)); +} -/* Value is non-zero if P is a pointer to a live vector-like object. +/* If P is a pointer to a live vector-like object, return the object. + Otherwise, return nil. M is a pointer to the mem_block for P. */ -static bool -live_vector_p (struct mem_node *m, void *p) +static Lisp_Object +live_vector_holding (struct mem_node *m, void *p) { + struct Lisp_Vector *vp = p; + if (m->type == MEM_TYPE_VECTOR_BLOCK) { /* This memory node corresponds to a vector block. */ @@ -4691,33 +4744,59 @@ live_vector_p (struct mem_node *m, void *p) 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 <= (struct Lisp_Vector *) p) + while (VECTOR_IN_BLOCK (vector, block) && vector <= vp) { - if (!PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE) && vector == p) - return true; - else - vector = ADVANCE (vector, vector_nbytes (vector)); + 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); + vector = next; } } - else if (m->type == MEM_TYPE_VECTORLIKE && p == large_vector_vec (m->start)) - /* This memory node corresponds to a large vector. */ - return 1; - return 0; + else if (m->type == MEM_TYPE_VECTORLIKE) + { + /* 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) + return make_lisp_ptr (vector, Lisp_Vectorlike); + } + return Qnil; } +static bool +live_vector_p (struct mem_node *m, void *p) +{ + return !NILP (live_vector_holding (m, p)); +} -/* Value is non-zero if P is a pointer to a live buffer. M is a - pointer to the mem_block for P. */ +/* If P is a pointer into a live buffer, return the buffer. + Otherwise, return nil. M is a pointer to the mem_block for P. */ + +static Lisp_Object +live_buffer_holding (struct mem_node *m, void *p) +{ + /* P must point into the block, and the buffer + must not have been killed. */ + if (m->type == MEM_TYPE_BUFFER) + { + struct buffer *b = m->start; + char *cb = m->start; + char *cp = p; + ptrdiff_t offset = cp - cb; + if (0 <= offset && offset < sizeof *b && !NILP (b->name_)) + { + Lisp_Object obj; + XSETBUFFER (obj, b); + return obj; + } + } + return Qnil; +} static bool live_buffer_p (struct mem_node *m, void *p) { - /* P must point to the start of the block, and the buffer - must not have been killed. */ - return (m->type == MEM_TYPE_BUFFER - && p == m->start - && !NILP (((struct buffer *) p)->name_)); + return !NILP (live_buffer_holding (m, p)); } /* Mark OBJ if we can prove it's a Lisp_Object. */ @@ -4743,34 +4822,28 @@ mark_maybe_object (Lisp_Object obj) switch (XTYPE (obj)) { case Lisp_String: - mark_p = (live_string_p (m, po) - && !STRING_MARKED_P ((struct Lisp_String *) po)); + mark_p = EQ (obj, live_string_holding (m, po)); break; case Lisp_Cons: - mark_p = (live_cons_p (m, po) && !CONS_MARKED_P (XCONS (obj))); + mark_p = EQ (obj, live_cons_holding (m, po)); break; case Lisp_Symbol: - mark_p = (live_symbol_p (m, po) && !XSYMBOL (obj)->gcmarkbit); + mark_p = EQ (obj, live_symbol_holding (m, po)); break; case Lisp_Float: - mark_p = (live_float_p (m, po) && !FLOAT_MARKED_P (XFLOAT (obj))); + mark_p = live_float_p (m, po); break; case Lisp_Vectorlike: - /* Note: can't check BUFFERP before we know it's a - buffer because checking that dereferences the pointer - PO which might point anywhere. */ - if (live_vector_p (m, po)) - mark_p = !SUBRP (obj) && !VECTOR_MARKED_P (XVECTOR (obj)); - else if (live_buffer_p (m, po)) - mark_p = BUFFERP (obj) && !VECTOR_MARKED_P (XBUFFER (obj)); + mark_p = (EQ (obj, live_vector_holding (m, po)) + || EQ (obj, live_buffer_holding (m, po))); break; case Lisp_Misc: - mark_p = (live_misc_p (m, po) && !XMISCANY (obj)->gcmarkbit); + mark_p = EQ (obj, live_misc_holding (m, po)); break; default: @@ -4834,45 +4907,33 @@ mark_maybe_pointer (void *p) break; case MEM_TYPE_BUFFER: - if (live_buffer_p (m, p) && !VECTOR_MARKED_P ((struct buffer *)p)) - XSETVECTOR (obj, p); + obj = live_buffer_holding (m, p); break; case MEM_TYPE_CONS: - if (live_cons_p (m, p) && !CONS_MARKED_P ((struct Lisp_Cons *) p)) - XSETCONS (obj, p); + obj = live_cons_holding (m, p); break; case MEM_TYPE_STRING: - if (live_string_p (m, p) - && !STRING_MARKED_P ((struct Lisp_String *) p)) - XSETSTRING (obj, p); + obj = live_string_holding (m, p); break; case MEM_TYPE_MISC: - if (live_misc_p (m, p) && !((struct Lisp_Free *) p)->gcmarkbit) - XSETMISC (obj, p); + obj = live_misc_holding (m, p); break; case MEM_TYPE_SYMBOL: - if (live_symbol_p (m, p) && !((struct Lisp_Symbol *) p)->gcmarkbit) - XSETSYMBOL (obj, p); + obj = live_symbol_holding (m, p); break; case MEM_TYPE_FLOAT: - if (live_float_p (m, p) && !FLOAT_MARKED_P (p)) - XSETFLOAT (obj, p); + if (live_float_p (m, p)) + obj = make_lisp_ptr (p, Lisp_Float); break; case MEM_TYPE_VECTORLIKE: case MEM_TYPE_VECTOR_BLOCK: - if (live_vector_p (m, p)) - { - Lisp_Object tem; - XSETVECTOR (tem, p); - if (!SUBRP (tem) && !VECTOR_MARKED_P (XVECTOR (tem))) - obj = tem; - } + obj = live_vector_holding (m, p); break; default: |