X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/c3c51ec274f423cf8044cd5b9bc0bbc5bda1f6aa..d3155315c85212f224fc5df0239182dafdfd6284:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index eada96c0c1..030c6e06ba 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -1,6 +1,6 @@ /* Storage allocation and gc for GNU Emacs Lisp interpreter. -Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 Free Software +Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2015 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -263,23 +263,6 @@ no_sanitize_memcpy (void *dest, void const *src, size_t size) #endif /* MAX_SAVE_STACK > 0 */ -static Lisp_Object Qconses; -static Lisp_Object Qsymbols; -static Lisp_Object Qmiscs; -static Lisp_Object Qstrings; -static Lisp_Object Qvectors; -static Lisp_Object Qfloats; -static Lisp_Object Qintervals; -static Lisp_Object Qbuffers; -static Lisp_Object Qstring_bytes, Qvector_slots, Qheap; -static Lisp_Object Qgc_cons_threshold; -Lisp_Object Qautomatic_gc; -Lisp_Object Qchar_table_extra_slots; - -/* Hook run after GC has finished. */ - -static Lisp_Object Qpost_gc_hook; - static void mark_terminals (void); static void gc_sweep (void); static Lisp_Object make_pure_vector (ptrdiff_t); @@ -458,6 +441,15 @@ mmap_lisp_allowed_p (void) return pointers_fit_in_lispobj_p () && !might_dump; } +/* Head of a circularly-linked list of extant finalizers. */ +static struct Lisp_Finalizer finalizers; + +/* Head of a circularly-linked list of finalizers that must be invoked + because we deemed them unreachable. This list must be global, and + not a local inside garbage_collect_1, in case we GC again while + running finalizers. */ +static struct Lisp_Finalizer doomed_finalizers; + /************************************************************************ Malloc @@ -3180,20 +3172,19 @@ allocate_vector (EMACS_INT len) /* Allocate other vector-like structures. */ struct Lisp_Vector * -allocate_pseudovector (int memlen, int lisplen, enum pvec_type tag) +allocate_pseudovector (int memlen, int lisplen, + int zerolen, enum pvec_type tag) { struct Lisp_Vector *v = allocate_vectorlike (memlen); - int i; /* Catch bogus values. */ - eassert (tag <= PVEC_FONT); + eassert (0 <= tag && tag <= PVEC_FONT); + eassert (0 <= lisplen && lisplen <= zerolen && zerolen <= memlen); eassert (memlen - lisplen <= (1 << PSEUDOVECTOR_REST_BITS) - 1); eassert (lisplen <= (1 << PSEUDOVECTOR_SIZE_BITS) - 1); - /* Only the first lisplen slots will be traced normally by the GC. */ - for (i = 0; i < lisplen; ++i) - v->contents[i] = Qnil; - + /* Only the first LISPLEN slots will be traced normally by the GC. */ + memclear (v->contents, zerolen * word_size); XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen); return v; } @@ -3211,60 +3202,6 @@ allocate_buffer (void) return b; } -struct Lisp_Hash_Table * -allocate_hash_table (void) -{ - return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table, count, PVEC_HASH_TABLE); -} - -struct window * -allocate_window (void) -{ - struct window *w; - - w = ALLOCATE_PSEUDOVECTOR (struct window, current_matrix, PVEC_WINDOW); - /* Users assumes that non-Lisp data is zeroed. */ - memset (&w->current_matrix, 0, - sizeof (*w) - offsetof (struct window, current_matrix)); - return w; -} - -struct terminal * -allocate_terminal (void) -{ - struct terminal *t; - - t = ALLOCATE_PSEUDOVECTOR (struct terminal, next_terminal, PVEC_TERMINAL); - /* Users assumes that non-Lisp data is zeroed. */ - memset (&t->next_terminal, 0, - sizeof (*t) - offsetof (struct terminal, next_terminal)); - return t; -} - -struct frame * -allocate_frame (void) -{ - struct frame *f; - - f = ALLOCATE_PSEUDOVECTOR (struct frame, face_cache, PVEC_FRAME); - /* Users assumes that non-Lisp data is zeroed. */ - memset (&f->face_cache, 0, - sizeof (*f) - offsetof (struct frame, face_cache)); - return f; -} - -struct Lisp_Process * -allocate_process (void) -{ - struct Lisp_Process *p; - - p = ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS); - /* Users assumes that non-Lisp data is zeroed. */ - memset (&p->pid, 0, - sizeof (*p) - offsetof (struct Lisp_Process, pid)); - return p; -} - DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0, doc: /* Return a newly created vector of length LENGTH, with each element being INIT. See also the function `vector'. */) @@ -3410,13 +3347,29 @@ set_symbol_name (Lisp_Object sym, Lisp_Object name) XSYMBOL (sym)->name = name; } +void +init_symbol (Lisp_Object val, Lisp_Object name) +{ + struct Lisp_Symbol *p = XSYMBOL (val); + set_symbol_name (val, name); + set_symbol_plist (val, Qnil); + p->redirect = SYMBOL_PLAINVAL; + SET_SYMBOL_VAL (p, Qunbound); + set_symbol_function (val, Qnil); + set_symbol_next (val, NULL); + p->gcmarkbit = false; + p->interned = SYMBOL_UNINTERNED; + p->constant = 0; + p->declared_special = false; + p->pinned = false; +} + DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, doc: /* Return a newly allocated uninterned symbol whose name is NAME. Its value is void, and its function definition and property list are nil. */) (Lisp_Object name) { - register Lisp_Object val; - register struct Lisp_Symbol *p; + Lisp_Object val; CHECK_STRING (name); @@ -3444,18 +3397,7 @@ Its value is void, and its function definition and property list are nil. */) MALLOC_UNBLOCK_INPUT; - p = XSYMBOL (val); - set_symbol_name (val, name); - set_symbol_plist (val, Qnil); - p->redirect = SYMBOL_PLAINVAL; - SET_SYMBOL_VAL (p, Qunbound); - set_symbol_function (val, Qnil); - set_symbol_next (val, NULL); - p->gcmarkbit = false; - p->interned = SYMBOL_UNINTERNED; - p->constant = 0; - p->declared_special = false; - p->pinned = false; + init_symbol (val, name); consing_since_gc += sizeof (struct Lisp_Symbol); symbols_consed++; total_free_symbols--; @@ -3481,7 +3423,7 @@ union aligned_Lisp_Misc }; /* Allocation of markers and other objects that share that structure. - Works like allocation of conses. */ + Works like allocation of conses. */ #define MARKER_BLOCK_SIZE \ ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc)) @@ -3762,6 +3704,128 @@ make_event_array (ptrdiff_t nargs, Lisp_Object *args) } } +static void +init_finalizer_list (struct Lisp_Finalizer *head) +{ + head->prev = head->next = head; +} + +/* Insert FINALIZER before ELEMENT. */ + +static void +finalizer_insert (struct Lisp_Finalizer *element, + struct Lisp_Finalizer *finalizer) +{ + eassert (finalizer->prev == NULL); + eassert (finalizer->next == NULL); + finalizer->next = element; + finalizer->prev = element->prev; + finalizer->prev->next = finalizer; + element->prev = finalizer; +} + +static void +unchain_finalizer (struct Lisp_Finalizer *finalizer) +{ + if (finalizer->prev != NULL) + { + eassert (finalizer->next != NULL); + finalizer->prev->next = finalizer->next; + finalizer->next->prev = finalizer->prev; + finalizer->prev = finalizer->next = NULL; + } +} + +static void +mark_finalizer_list (struct Lisp_Finalizer *head) +{ + for (struct Lisp_Finalizer *finalizer = head->next; + finalizer != head; + finalizer = finalizer->next) + { + finalizer->base.gcmarkbit = true; + mark_object (finalizer->function); + } +} + +/* Move doomed finalizers to list DEST from list SRC. A doomed + finalizer is one that is not GC-reachable and whose + finalizer->function is non-nil. */ + +static void +queue_doomed_finalizers (struct Lisp_Finalizer *dest, + struct Lisp_Finalizer *src) +{ + struct Lisp_Finalizer *finalizer = src->next; + while (finalizer != src) + { + struct Lisp_Finalizer *next = finalizer->next; + if (!finalizer->base.gcmarkbit && !NILP (finalizer->function)) + { + unchain_finalizer (finalizer); + finalizer_insert (dest, finalizer); + } + + finalizer = next; + } +} + +static Lisp_Object +run_finalizer_handler (Lisp_Object args) +{ + add_to_log ("finalizer failed: %S", args, Qnil); + return Qnil; +} + +static void +run_finalizer_function (Lisp_Object function) +{ + struct gcpro gcpro1; + ptrdiff_t count = SPECPDL_INDEX (); + + GCPRO1 (function); + specbind (Qinhibit_quit, Qt); + internal_condition_case_1 (call0, function, Qt, run_finalizer_handler); + unbind_to (count, Qnil); + UNGCPRO; +} + +static void +run_finalizers (struct Lisp_Finalizer *finalizers) +{ + struct Lisp_Finalizer *finalizer; + Lisp_Object function; + + while (finalizers->next != finalizers) + { + finalizer = finalizers->next; + eassert (finalizer->base.type == Lisp_Misc_Finalizer); + unchain_finalizer (finalizer); + function = finalizer->function; + if (!NILP (function)) + { + finalizer->function = Qnil; + run_finalizer_function (function); + } + } +} + +DEFUN ("make-finalizer", Fmake_finalizer, Smake_finalizer, 1, 1, 0, + doc: /* Make a finalizer that will run FUNCTION. +FUNCTION will be called after garbage collection when the returned +finalizer object becomes unreachable. If the finalizer object is +reachable only through references from finalizer objects, it does not +count as reachable for the purpose of deciding whether to run +FUNCTION. FUNCTION will be run once per finalizer object. */) + (Lisp_Object function) +{ + Lisp_Object val = allocate_misc (Lisp_Misc_Finalizer); + struct Lisp_Finalizer *finalizer = XFINALIZER (val); + finalizer->function = function; + finalizer->prev = finalizer->next = NULL; + finalizer_insert (&finalizers, finalizer); + return val; +} /************************************************************************ @@ -4432,7 +4496,7 @@ live_buffer_p (struct mem_node *m, void *p) must not have been killed. */ return (m->type == MEM_TYPE_BUFFER && p == m->start - && !NILP (((struct buffer *) p)->INTERNAL_FIELD (name))); + && !NILP (((struct buffer *) p)->name_)); } #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */ @@ -4475,19 +4539,17 @@ DEFUN ("gc-status", Fgc_status, Sgc_status, 0, 0, "", doc: /* Show information about live and zombie objects. */) (void) { - Lisp_Object args[8], zombie_list = Qnil; - EMACS_INT i; - for (i = 0; i < min (MAX_ZOMBIES, nzombies); i++) + Lisp_Object zombie_list = Qnil; + for (int i = 0; i < min (MAX_ZOMBIES, nzombies); i++) zombie_list = Fcons (zombies[i], zombie_list); - args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S"); - args[1] = make_number (ngcs); - args[2] = make_float (avg_live); - args[3] = make_float (avg_zombies); - args[4] = make_float (avg_zombies / avg_live / 100); - args[5] = make_number (max_live); - args[6] = make_number (max_zombies); - args[7] = zombie_list; - return Fmessage (8, args); + return CALLN (Fmessage, + build_string ("%d GCs, avg live/zombies = %.2f/%.2f" + " (%f%%), max %d/%d\nzombies: %S"), + make_number (ngcs), make_float (avg_live), + make_float (avg_zombies), + make_float (avg_zombies / avg_live / 100), + make_number (max_live), make_number (max_zombies), + zombie_list); } #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */ @@ -4682,7 +4744,7 @@ mark_maybe_pointer (void *p) #endif /* Mark Lisp objects referenced from the address range START+OFFSET..END - or END+OFFSET..START. */ + or END+OFFSET..START. */ static void ATTRIBUTE_NO_SANITIZE_ADDRESS mark_memory (void *start, void *end) @@ -4925,6 +4987,14 @@ mark_stack (void *end) #endif /* GC_MARK_STACK != 0 */ +static bool +c_symbol_p (struct Lisp_Symbol *sym) +{ + char *lispsym_ptr = (char *) lispsym; + char *sym_ptr = (char *) sym; + ptrdiff_t lispsym_offset = sym_ptr - lispsym_ptr; + return 0 <= lispsym_offset && lispsym_offset < sizeof lispsym; +} /* Determine whether it is safe to access memory at address P. */ static int @@ -4978,6 +5048,9 @@ valid_lisp_object_p (Lisp_Object obj) if (PURE_POINTER_P (p)) return 1; + if (SYMBOLP (obj) && c_symbol_p (p)) + return ((char *) p - (char *) lispsym) % sizeof lispsym[0] == 0; + if (p == &buffer_defaults || p == &buffer_local_symbols) return 2; @@ -5283,7 +5356,6 @@ make_pure_vector (ptrdiff_t len) return new; } - DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, doc: /* Make a copy of object OBJ in pure storage. Recursively copies contents of vectors and cons cells. @@ -5318,45 +5390,42 @@ purecopy (Lisp_Object obj) else if (FLOATP (obj)) obj = make_pure_float (XFLOAT_DATA (obj)); else if (STRINGP (obj)) - obj = make_pure_string (SSDATA (obj), SCHARS (obj), - SBYTES (obj), - STRING_MULTIBYTE (obj)); - else if (COMPILEDP (obj) || VECTORP (obj)) { - register struct Lisp_Vector *vec; + if (XSTRING (obj)->intervals) + message ("Dropping text-properties when making string pure"); + obj = make_pure_string (SSDATA (obj), SCHARS (obj), + SBYTES (obj), + STRING_MULTIBYTE (obj)); + } + else if (COMPILEDP (obj) || VECTORP (obj) || HASH_TABLE_P (obj)) + { + struct Lisp_Vector *objp = XVECTOR (obj); + ptrdiff_t nbytes = vector_nbytes (objp); + struct Lisp_Vector *vec = pure_alloc (nbytes, Lisp_Vectorlike); register ptrdiff_t i; - ptrdiff_t size; - - size = ASIZE (obj); + ptrdiff_t size = ASIZE (obj); if (size & PSEUDOVECTOR_FLAG) size &= PSEUDOVECTOR_SIZE_MASK; - vec = XVECTOR (make_pure_vector (size)); + memcpy (vec, objp, nbytes); for (i = 0; i < size; i++) - vec->contents[i] = purecopy (AREF (obj, i)); - if (COMPILEDP (obj)) - { - XSETPVECTYPE (vec, PVEC_COMPILED); - XSETCOMPILED (obj, vec); - } - else - XSETVECTOR (obj, vec); + vec->contents[i] = purecopy (vec->contents[i]); + XSETVECTOR (obj, vec); } else if (SYMBOLP (obj)) { - if (!XSYMBOL (obj)->pinned) + if (!XSYMBOL (obj)->pinned && !c_symbol_p (XSYMBOL (obj))) { /* We can't purify them, but they appear in many pure objects. Mark them as `pinned' so we know to mark them at every GC cycle. */ XSYMBOL (obj)->pinned = true; symbol_block_pinned = symbol_block; } + /* Don't hash-cons it. */ return obj; } else { - Lisp_Object args[2]; - args[0] = build_pure_c_string ("Don't know how to purify: %S"); - args[1] = obj; - Fsignal (Qerror, (Fcons (Fformat (2, args), Qnil))); + Lisp_Object fmt = build_pure_c_string ("Don't know how to purify: %S"); + Fsignal (Qerror, list1 (CALLN (Fformat, fmt, obj))); } if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */ @@ -5532,7 +5601,7 @@ mark_pinned_symbols (void) union aligned_Lisp_Symbol *sym = sblk->symbols, *end = sym + lim; for (; sym < end; ++sym) if (sym->s.pinned) - mark_object (make_lisp_ptr (&sym->s, Lisp_Symbol)); + mark_object (make_lisp_symbol (&sym->s)); lim = SYMBOL_BLOCK_SIZE; } @@ -5566,7 +5635,7 @@ garbage_collect_1 (void *end) return Qnil; /* Record this function, so it appears on the profiler's backtraces. */ - record_in_backtrace (Qautomatic_gc, &Qnil, 0); + record_in_backtrace (Qautomatic_gc, 0, 0); check_cons_list (); @@ -5630,6 +5699,9 @@ garbage_collect_1 (void *end) mark_buffer (&buffer_defaults); mark_buffer (&buffer_local_symbols); + for (i = 0; i < ARRAYELTS (lispsym); i++) + mark_object (builtin_lisp_symbol (i)); + for (i = 0; i < staticidx; i++) mark_object (*staticvec[i]); @@ -5670,9 +5742,9 @@ garbage_collect_1 (void *end) mark_stack (end); #endif - /* Everything is now marked, except for the data in font caches - and undo lists. They're compacted by removing an items which - aren't reachable otherwise. */ + /* Everything is now marked, except for the data in font caches, + undo lists, and finalizers. The first two are compacted by + removing an items which aren't reachable otherwise. */ compact_font_caches (); @@ -5685,6 +5757,16 @@ garbage_collect_1 (void *end) mark_object (BVAR (nextb, undo_list)); } + /* Now pre-sweep finalizers. Here, we add any unmarked finalizers + to doomed_finalizers so we can run their associated functions + after GC. It's important to scan finalizers at this stage so + that we can be sure that unmarked finalizers are really + unreachable except for references from their associated functions + and from other finalizers. */ + + queue_doomed_finalizers (&doomed_finalizers, &finalizers); + mark_finalizer_list (&doomed_finalizers); + gc_sweep (); /* Clear the mark bits that we set in certain root slots. */ @@ -5731,56 +5813,44 @@ garbage_collect_1 (void *end) } unbind_to (count, Qnil); - { - Lisp_Object total[11]; - int total_size = 10; - - total[0] = list4 (Qconses, make_number (sizeof (struct Lisp_Cons)), - bounded_number (total_conses), - bounded_number (total_free_conses)); - - total[1] = list4 (Qsymbols, make_number (sizeof (struct Lisp_Symbol)), - bounded_number (total_symbols), - bounded_number (total_free_symbols)); - - total[2] = list4 (Qmiscs, make_number (sizeof (union Lisp_Misc)), - bounded_number (total_markers), - bounded_number (total_free_markers)); - - total[3] = list4 (Qstrings, make_number (sizeof (struct Lisp_String)), - bounded_number (total_strings), - bounded_number (total_free_strings)); - total[4] = list3 (Qstring_bytes, make_number (1), - bounded_number (total_string_bytes)); - - total[5] = list3 (Qvectors, - make_number (header_size + sizeof (Lisp_Object)), - bounded_number (total_vectors)); - - total[6] = list4 (Qvector_slots, make_number (word_size), - bounded_number (total_vector_slots), - bounded_number (total_free_vector_slots)); - - total[7] = list4 (Qfloats, make_number (sizeof (struct Lisp_Float)), - bounded_number (total_floats), - bounded_number (total_free_floats)); - - total[8] = list4 (Qintervals, make_number (sizeof (struct interval)), - bounded_number (total_intervals), - bounded_number (total_free_intervals)); - - total[9] = list3 (Qbuffers, make_number (sizeof (struct buffer)), - bounded_number (total_buffers)); + Lisp_Object total[] = { + list4 (Qconses, make_number (sizeof (struct Lisp_Cons)), + bounded_number (total_conses), + bounded_number (total_free_conses)), + list4 (Qsymbols, make_number (sizeof (struct Lisp_Symbol)), + bounded_number (total_symbols), + bounded_number (total_free_symbols)), + list4 (Qmiscs, make_number (sizeof (union Lisp_Misc)), + bounded_number (total_markers), + bounded_number (total_free_markers)), + list4 (Qstrings, make_number (sizeof (struct Lisp_String)), + bounded_number (total_strings), + bounded_number (total_free_strings)), + list3 (Qstring_bytes, make_number (1), + bounded_number (total_string_bytes)), + list3 (Qvectors, + make_number (header_size + sizeof (Lisp_Object)), + bounded_number (total_vectors)), + list4 (Qvector_slots, make_number (word_size), + bounded_number (total_vector_slots), + bounded_number (total_free_vector_slots)), + list4 (Qfloats, make_number (sizeof (struct Lisp_Float)), + bounded_number (total_floats), + bounded_number (total_free_floats)), + list4 (Qintervals, make_number (sizeof (struct interval)), + bounded_number (total_intervals), + bounded_number (total_free_intervals)), + list3 (Qbuffers, make_number (sizeof (struct buffer)), + bounded_number (total_buffers)), #ifdef DOUG_LEA_MALLOC - total_size++; - total[10] = list4 (Qheap, make_number (1024), - bounded_number ((mallinfo ().uordblks + 1023) >> 10), - bounded_number ((mallinfo ().fordblks + 1023) >> 10)); + list4 (Qheap, make_number (1024), + bounded_number ((mallinfo ().uordblks + 1023) >> 10), + bounded_number ((mallinfo ().fordblks + 1023) >> 10)), #endif - retval = Flist (total_size, total); - } + }; + retval = CALLMANY (Flist, total); #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES { @@ -5797,6 +5867,9 @@ garbage_collect_1 (void *end) } #endif + /* GC is complete: now we can run our finalizer callbacks. */ + run_finalizers (&doomed_finalizers); + if (!NILP (Vpost_gc_hook)) { ptrdiff_t gc_count = inhibit_garbage_collection (); @@ -6154,13 +6227,14 @@ mark_discard_killed_buffers (Lisp_Object list) void mark_object (Lisp_Object arg) { - register Lisp_Object obj = arg; + register Lisp_Object obj; void *po; #ifdef GC_CHECK_MARKED_OBJECTS struct mem_node *m; #endif ptrdiff_t cdr_count = 0; + obj = arg; loop: po = XPNTR (obj); @@ -6193,17 +6267,28 @@ mark_object (Lisp_Object arg) emacs_abort (); \ } while (0) - /* Check both of the above conditions. */ + /* Check both of the above conditions, for non-symbols. */ #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \ do { \ CHECK_ALLOCATED (); \ CHECK_LIVE (LIVEP); \ } while (0) \ + /* Check both of the above conditions, for symbols. */ +#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \ + do { \ + if (!c_symbol_p (ptr)) \ + { \ + CHECK_ALLOCATED (); \ + CHECK_LIVE (live_symbol_p); \ + } \ + } while (0) \ + #else /* not GC_CHECK_MARKED_OBJECTS */ -#define CHECK_LIVE(LIVEP) ((void) 0) -#define CHECK_ALLOCATED_AND_LIVE(LIVEP) ((void) 0) +#define CHECK_LIVE(LIVEP) ((void) 0) +#define CHECK_ALLOCATED_AND_LIVE(LIVEP) ((void) 0) +#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0) #endif /* not GC_CHECK_MARKED_OBJECTS */ @@ -6363,7 +6448,7 @@ mark_object (Lisp_Object arg) nextsym: if (ptr->gcmarkbit) break; - CHECK_ALLOCATED_AND_LIVE (live_symbol_p); + CHECK_ALLOCATED_AND_LIVE_SYMBOL (); ptr->gcmarkbit = 1; /* Attempt to catch bogus objects. */ eassert (valid_lisp_object_p (ptr->function)); @@ -6422,7 +6507,12 @@ mark_object (Lisp_Object arg) case Lisp_Misc_Overlay: mark_overlay (XOVERLAY (obj)); - break; + break; + + case Lisp_Misc_Finalizer: + XMISCANY (obj)->gcmarkbit = true; + mark_object (XFINALIZER (obj)->function); + break; default: emacs_abort (); @@ -6720,13 +6810,16 @@ NO_INLINE /* For better stack traces */ static void sweep_symbols (void) { - register struct symbol_block *sblk; + struct symbol_block *sblk; struct symbol_block **sprev = &symbol_block; - register int lim = symbol_block_index; - EMACS_INT num_free = 0, num_used = 0; + int lim = symbol_block_index; + EMACS_INT num_free = 0, num_used = ARRAYELTS (lispsym); symbol_free_list = NULL; + for (int i = 0; i < ARRAYELTS (lispsym); i++) + lispsym[i].gcmarkbit = 0; + for (sblk = symbol_block; sblk; sblk = *sprev) { int this_free = 0; @@ -6776,7 +6869,7 @@ sweep_symbols (void) total_free_symbols = num_free; } -NO_INLINE /* For better stack traces */ +NO_INLINE /* For better stack traces. */ static void sweep_misc (void) { @@ -6801,6 +6894,8 @@ sweep_misc (void) { if (mblk->markers[i].m.u_any.type == Lisp_Misc_Marker) unchain_marker (&mblk->markers[i].m.u_marker); + if (mblk->markers[i].m.u_any.type == Lisp_Misc_Finalizer) + unchain_finalizer (&mblk->markers[i].m.u_finalizer); /* Set the type of the freed object to Lisp_Misc_Free. We could leave the type alone, since nobody checks it, but this might catch bugs faster. */ @@ -6974,6 +7069,21 @@ Frames, windows, buffers, and subprocesses count as vectors bounded_number (strings_consed)); } +static bool +symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj) +{ + struct Lisp_Symbol *sym = XSYMBOL (symbol); + Lisp_Object val = find_symbol_value (symbol); + return (EQ (val, obj) + || EQ (sym->function, obj) + || (!NILP (sym->function) + && COMPILEDP (sym->function) + && EQ (AREF (sym->function, COMPILED_BYTECODE), obj)) + || (!NILP (val) + && COMPILEDP (val) + && EQ (AREF (val, COMPILED_BYTECODE), obj))); +} + /* Find at most FIND_MAX symbols which have OBJ as their value or function. This is used in gdbinit's `xwhichsymbols' command. */ @@ -6986,6 +7096,17 @@ which_symbols (Lisp_Object obj, EMACS_INT find_max) if (! DEADP (obj)) { + for (int i = 0; i < ARRAYELTS (lispsym); i++) + { + Lisp_Object sym = builtin_lisp_symbol (i); + if (symbol_uses_obj (sym, obj)) + { + found = Fcons (sym, found); + if (--find_max == 0) + goto out; + } + } + for (sblk = symbol_block; sblk; sblk = sblk->next) { union aligned_Lisp_Symbol *aligned_sym = sblk->symbols; @@ -6993,25 +7114,13 @@ which_symbols (Lisp_Object obj, EMACS_INT find_max) for (bn = 0; bn < SYMBOL_BLOCK_SIZE; bn++, aligned_sym++) { - struct Lisp_Symbol *sym = &aligned_sym->s; - Lisp_Object val; - Lisp_Object tem; - if (sblk == symbol_block && bn >= symbol_block_index) break; - XSETSYMBOL (tem, sym); - val = find_symbol_value (tem); - if (EQ (val, obj) - || EQ (sym->function, obj) - || (!NILP (sym->function) - && COMPILEDP (sym->function) - && EQ (AREF (sym->function, COMPILED_BYTECODE), obj)) - || (!NILP (val) - && COMPILEDP (val) - && EQ (AREF (val, COMPILED_BYTECODE), obj))) + Lisp_Object sym = make_lisp_symbol (&aligned_sym->s); + if (symbol_uses_obj (sym, obj)) { - found = Fcons (tem, found); + found = Fcons (sym, found); if (--find_max == 0) goto out; } @@ -7154,11 +7263,16 @@ verify_alloca (void) void init_alloc_once (void) { - /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */ + /* Even though Qt's contents are not set up, its address is known. */ + Vpurify_flag = Qt; + gc_precise = (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE); + purebeg = PUREBEG; pure_size = PURESIZE; verify_alloca (); + init_finalizer_list (&finalizers); + init_finalizer_list (&doomed_finalizers); #if GC_MARK_STACK || defined GC_MALLOC_CHECK mem_init (); @@ -7230,6 +7344,7 @@ If this portion is smaller than `gc-cons-threshold', this is ignored. */); DEFVAR_INT ("symbols-consed", symbols_consed, doc: /* Number of symbols that have been consed so far. */); + symbols_consed += ARRAYELTS (lispsym); DEFVAR_INT ("string-chars-consed", string_chars_consed, doc: /* Number of string characters that have been consed so far. */); @@ -7292,7 +7407,12 @@ do hash-consing of the objects allocated to pure space. */); doc: /* Accumulated time elapsed in garbage collections. The time is in seconds as a floating point value. */); DEFVAR_INT ("gcs-done", gcs_done, - doc: /* Accumulated number of garbage collections done. */); + doc: /* Accumulated number of garbage collections done. */); + + DEFVAR_BOOL ("gc-precise", gc_precise, + doc: /* Non-nil means GC stack marking is precise. +Useful mainly for automated GC tests. Build time constant.*/); + XSYMBOL (intern_c_string ("gc-precise"))->constant = 1; defsubr (&Scons); defsubr (&Slist); @@ -7305,6 +7425,7 @@ The time is in seconds as a floating point value. */); defsubr (&Smake_bool_vector); defsubr (&Smake_symbol); defsubr (&Smake_marker); + defsubr (&Smake_finalizer); defsubr (&Spurecopy); defsubr (&Sgarbage_collect); defsubr (&Smemory_limit);