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;
+
\f
/************************************************************************
Malloc
struct Lisp_Vector *v = allocate_vectorlike (memlen);
/* 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.
- But since Qnil == 0, we can memset Lisp_Object slots as well. */
- memset (v->contents, 0, zerolen * word_size);
-
+ /* 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;
}
};
/* 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))
}
}
+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;
+}
\f
/************************************************************************
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 */
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 */
#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)
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.
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))
{
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. */
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 ();
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. */
}
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
{
}
#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 ();
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);
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 ();
total_free_symbols = num_free;
}
-NO_INLINE /* For better stack traces */
+NO_INLINE /* For better stack traces. */
static void
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. */
{
/* 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 ();
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);
defsubr (&Smake_bool_vector);
defsubr (&Smake_symbol);
defsubr (&Smake_marker);
+ defsubr (&Smake_finalizer);
defsubr (&Spurecopy);
defsubr (&Sgarbage_collect);
defsubr (&Smemory_limit);