Commit 9d8d0658 authored by Daniel Colascione's avatar Daniel Colascione

Add support for finalizers

+2015-03-02  Daniel Colascione  <dancol@dancol.org>
+
+	* NEWS: Mention finalizers.
+
 2015-02-09  Gareth Rees  <gdr@garethrees.org>  (tiny change)

 	* NEWS.24: Fix typo (bug#19820)
diff --git a/src/ChangeLog b/src/ChangeLog
index 4aa64c1..2f04d0b 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,21 @@
+2015-03-02  Daniel Colascione  <dancol@dancol.org>
+
+	* print.c (print_object): Print finalizers.
+
+	* alloc.c:
+	(finalizers, doomed_finalizers): New variables.
+	(init_finalizer_list, finalizer_insert, unchain_finalizer)
+	(mark_finalizer_list, queue_doomed_finalizers)
+	(run_finalizer_handler, run_finalizer_function, run_finalizers):
+	New functions.
+	(garbage_collect_1, mark_object, sweep_misc)
+	(init_alloc_once, syms_of_alloc): Support finalizers.
+	(gc-precise-p): New Lisp variable.
+
+	* lisp.h (Lisp_Misc_Type): New value Lisp_Misc_Finalizer.
+	(FINALIZERP, XFINALIZER): New functions.
+	(Lisp_Finalizer): New structure.
+
 2015-02-28  Paul Eggert  <eggert@cs.ucla.edu>

 	* character.c (alphabeticp, decimalnump): Avoid undefined behavior
diff --git a/test/ChangeLog b/test/ChangeLog
index cf1b2c1..684e98f 100644
--- a/test/ChangeLog
+++ b/test/ChangeLog
@@ -1,3 +1,9 @@
+2015-03-02  Daniel Colascione  <dancol@dancol.org>
+
+	* automated/finalizer-tests.el (finalizer-basic)
+	(finalizer-circular-reference, finalizer-cross-reference)
+	(finalizer-error): New tests.
+
 2015-03-01  Michael Albinus  <michael.albinus@gmx.de>

 	* automated/vc-tests.el (vc-test--create-repo): Add check for
parent b149ecd8
2015-03-02 Daniel Colascione <dancol@dancol.org>
* NEWS: Mention finalizers.
2015-02-09 Gareth Rees <gdr@garethrees.org> (tiny change)
* NEWS.24: Fix typo (bug#19820)
......
......@@ -621,6 +621,9 @@ word syntax, use `\sw' instead.
* Lisp Changes in Emacs 25.1
** New finalizer facility for running code when objects
become unreachable.
** lexical closures can use (:documentation <form>) to build their docstring.
It should be placed right where the docstring would be, and <form> is then
evaluated (and should return a string) when the closure is built.
......
2015-03-02 Daniel Colascione <dancol@dancol.org>
* print.c (print_object): Print finalizers.
* alloc.c:
(finalizers, doomed_finalizers): New variables.
(init_finalizer_list, finalizer_insert, unchain_finalizer)
(mark_finalizer_list, queue_doomed_finalizers)
(run_finalizer_handler, run_finalizer_function, run_finalizers):
New functions.
(garbage_collect_1, mark_object, sweep_misc)
(init_alloc_once, syms_of_alloc): Support finalizers.
(gc-precise-p): New Lisp variable.
* lisp.h (Lisp_Misc_Type): New value Lisp_Misc_Finalizer.
(FINALIZERP, XFINALIZER): New functions.
(Lisp_Finalizer): New structure.
2015-02-28 Paul Eggert <eggert@cs.ucla.edu>
* character.c (alphabeticp, decimalnump): Avoid undefined behavior
......
......@@ -441,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
......@@ -3695,6 +3704,131 @@ 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 = 1;
mark_object (finalizer->function);
}
}
/* Move doomed finalizers in list SRC onto list DEST. A doomed
finalizer is one that is not GC-reachable and whose
finalizer->function is non-nil. (We reset finalizer->function to
before attempting to run it.) */
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;
struct gcpro gcpro1;
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;
struct Lisp_Finalizer *finalizer;
val = allocate_misc (Lisp_Misc_Finalizer);
finalizer = XFINALIZER (val);
finalizer->function = function;
finalizer->prev = finalizer->next = NULL;
finalizer_insert (&finalizers, finalizer);
return val;
}
/************************************************************************
......@@ -5613,9 +5747,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 ();
......@@ -5628,6 +5762,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. */
......@@ -5728,6 +5872,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 ();
......@@ -6364,7 +6511,12 @@ mark_object (Lisp_Object arg)
case Lisp_Misc_Overlay:
mark_overlay (XOVERLAY (obj));
break;
break;
case Lisp_Misc_Finalizer:
XMISCANY (obj)->gcmarkbit = 1;
mark_object (XFINALIZER (obj)->function);
break;
default:
emacs_abort ();
......@@ -6746,6 +6898,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. */
......@@ -7115,11 +7269,14 @@ init_alloc_once (void)
{
/* Even though Qt's contents are not set up, its address is known. */
Vpurify_flag = Qt;
gc_precise_p = (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 ();
......@@ -7254,7 +7411,11 @@ 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-p", gc_precise_p,
doc: /* Non-nil means GC stack marking is precise.
Useful mainly for automated GC tests. Build time constant.*/);
defsubr (&Scons);
defsubr (&Slist);
......@@ -7267,6 +7428,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);
......
......@@ -488,6 +488,7 @@ enum Lisp_Misc_Type
Lisp_Misc_Marker,
Lisp_Misc_Overlay,
Lisp_Misc_Save_Value,
Lisp_Misc_Finalizer,
/* Currently floats are not a misc type,
but let's define this in case we want to change that. */
Lisp_Misc_Float,
......@@ -600,6 +601,7 @@ INLINE bool OVERLAYP (Lisp_Object);
INLINE bool PROCESSP (Lisp_Object);
INLINE bool PSEUDOVECTORP (Lisp_Object, int);
INLINE bool SAVE_VALUEP (Lisp_Object);
INLINE bool FINALIZERP (Lisp_Object);
INLINE void set_sub_char_table_contents (Lisp_Object, ptrdiff_t,
Lisp_Object);
INLINE bool STRINGP (Lisp_Object);
......@@ -610,6 +612,7 @@ INLINE bool (VECTORLIKEP) (Lisp_Object);
INLINE bool WINDOWP (Lisp_Object);
INLINE bool TERMINALP (Lisp_Object);
INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object);
INLINE struct Lisp_Finalizer *XFINALIZER (Lisp_Object);
INLINE struct Lisp_Symbol *(XSYMBOL) (Lisp_Object);
INLINE void *(XUNTAG) (Lisp_Object, int);
......@@ -2183,6 +2186,21 @@ XSAVE_OBJECT (Lisp_Object obj, int n)
return XSAVE_VALUE (obj)->data[n].object;
}
/* A finalizer sentinel. We run FUNCTION when this value becomes
unreachable. We treat these values specially in the GC to ensure
that we still run the finalizer even if FUNCTION contains a
reference to the finalizer; i.e., we run a finalizer's function
when FUNCTION is reachable _only_ through finalizers. */
struct Lisp_Finalizer
{
struct Lisp_Misc_Any base;
/* Circular list of all active weak references */
struct Lisp_Finalizer *prev;
struct Lisp_Finalizer *next;
/* Called when this object becomes unreachable */
Lisp_Object function;
};
/* A miscellaneous object, when it's on the free list. */
struct Lisp_Free
{
......@@ -2202,6 +2220,7 @@ union Lisp_Misc
struct Lisp_Marker u_marker;
struct Lisp_Overlay u_overlay;
struct Lisp_Save_Value u_save_value;
struct Lisp_Finalizer u_finalizer;
};
INLINE union Lisp_Misc *
......@@ -2243,6 +2262,14 @@ XSAVE_VALUE (Lisp_Object a)
eassert (SAVE_VALUEP (a));
return & XMISC (a)->u_save_value;
}
INLINE struct Lisp_Finalizer *
XFINALIZER (Lisp_Object a)
{
eassert (FINALIZERP (a));
return & XMISC (a)->u_finalizer;
}
/* Forwarding pointer to an int variable.
This is allowed only in the value cell of a symbol,
......@@ -2489,6 +2516,12 @@ SAVE_VALUEP (Lisp_Object x)
return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Save_Value;
}
INLINE bool
FINALIZERP (Lisp_Object x)
{
return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Finalizer;
}
INLINE bool
AUTOLOADP (Lisp_Object x)
{
......
......@@ -2043,7 +2043,11 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
printcharfun);
}
PRINTCHAR ('>');
break;
break;
case Lisp_Misc_Finalizer:
strout ("#<finalizer>", -1, -1, printcharfun);
break;
/* Remaining cases shouldn't happen in normal usage, but let's
print them anyway for the benefit of the debugger. */
......
2015-03-02 Daniel Colascione <dancol@dancol.org>
* automated/finalizer-tests.el (finalizer-basic)
(finalizer-circular-reference, finalizer-cross-reference)
(finalizer-error): New tests.
2015-03-01 Michael Albinus <michael.albinus@gmx.de>
* automated/vc-tests.el (vc-test--create-repo): Add check for
......
;;; finalizer-tests.el --- Finalizer tests -*- lexical-binding: t -*-
;; Copyright (C) 2015 Free Software Foundation, Inc.
;; Author: Daniel Colascione <dancol@dancol.org>
;; Keywords:
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;;; Code:
(require 'ert)
(require 'cl-lib)
(ert-deftest finalizer-basic ()
"Test that finalizers run at all."
(skip-unless gc-precise-p)
(let* ((finalized nil)
(finalizer (make-finalizer (lambda () (setf finalized t)))))
(garbage-collect)
(should (equal finalized nil))
(setf finalizer nil)
(garbage-collect)
(should (equal finalized t))))
(ert-deftest finalizer-circular-reference ()
"Test references from a callback to a finalizer."
(skip-unless gc-precise-p)
(let ((finalized nil))
(let* ((value nil)
(finalizer (make-finalizer (lambda () (setf finalized value)))))
(setf value finalizer)
(setf finalizer nil))
(garbage-collect)
(should finalized)))
(ert-deftest finalizer-cross-reference ()
"Test that between-finalizer references do not prevent collection."
(skip-unless gc-precise-p)
(let ((d nil) (fc 0))
(let* ((f1-data (cons nil nil))
(f2-data (cons nil nil))
(f1 (make-finalizer
(lambda () (cl-incf fc) (setf d f1-data))))
(f2 (make-finalizer
(lambda () (cl-incf fc) (setf d f2-data)))))
(setcar f1-data f2)
(setcar f2-data f1))
(garbage-collect)
(should (equal fc 2))))
(ert-deftest finalizer-error ()
"Test that finalizer errors are suppressed"
(skip-unless gc-precise-p)
(make-finalizer (lambda () (error "ABCDEF")))
(garbage-collect)
(with-current-buffer "*Messages*"
(save-excursion
(goto-char (point-max))
(forward-line -1)
(should (equal
(buffer-substring (point) (point-at-eol))
"finalizer failed: (error \"ABCDEF\")")))))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment