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
2015-03-02 02:23:09 -08:00 · 2015-03-02 02:23:09 -08:00 · 9d8d065814
commit 9d8d065814
parent b149ecd8aa
8 changed files with 314 additions and 6 deletions
--- a/etc/ChangeLog
+++ b/etc/ChangeLog
@ -1,3 +1,7 @@
+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)
--- a/etc/NEWS
+++ b/etc/NEWS
@ -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.
--- 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
--- a/src/alloc.c
+++ b/src/alloc.c
@ -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);
--- a/src/lisp.h
+++ b/src/lisp.h
@ -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)
 {
--- a/src/print.c
+++ b/src/print.c
@ -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.  */
--- 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
--- a/test/automated/finalizer-tests.el
+++ b/test/automated/finalizer-tests.el
@ -0,0 +1,78 @@
+;;; 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\")")))))