From: Daniel Colascione Date: Mon, 2 Mar 2015 10:23:09 +0000 (-0800) Subject: Add support for finalizers X-Git-Tag: emacs-25.0.90~2564^2~261 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=9d8d0658147dfe5a90e2fb07ff666f35b1162d6e;p=emacs.git Add support for finalizers +2015-03-02 Daniel Colascione + + * NEWS: Mention finalizers. + 2015-02-09 Gareth Rees (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 + + * 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 * 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 + + * automated/finalizer-tests.el (finalizer-basic) + (finalizer-circular-reference, finalizer-cross-reference) + (finalizer-error): New tests. + 2015-03-01 Michael Albinus * automated/vc-tests.el (vc-test--create-repo): Add check for --- diff --git a/etc/ChangeLog b/etc/ChangeLog index 24cb6f24d22..99a74f942f2 100644 --- a/etc/ChangeLog +++ b/etc/ChangeLog @@ -1,3 +1,7 @@ +2015-03-02 Daniel Colascione + + * NEWS: Mention finalizers. + 2015-02-09 Gareth Rees (tiny change) * NEWS.24: Fix typo (bug#19820) diff --git a/etc/NEWS b/etc/NEWS index 3be820e0d5f..6c94a587ad5 100644 --- 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
) to build their docstring. It should be placed right where the docstring would be, and is then evaluated (and should return a string) when the closure is built. diff --git a/src/ChangeLog b/src/ChangeLog index 4aa64c1d6f9..2f04d0b040a 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,21 @@ +2015-03-02 Daniel Colascione + + * 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 * character.c (alphabeticp, decimalnump): Avoid undefined behavior diff --git a/src/alloc.c b/src/alloc.c index 9aa94b8a559..eec53e7d844 100644 --- 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); diff --git a/src/lisp.h b/src/lisp.h index fb436776121..37f3b28242b 100644 --- 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) { diff --git a/src/print.c b/src/print.c index 1a0aebbeba7..d391fd5f7a3 100644 --- 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 ("#", -1, -1, printcharfun); + break; /* Remaining cases shouldn't happen in normal usage, but let's print them anyway for the benefit of the debugger. */ diff --git a/test/ChangeLog b/test/ChangeLog index cf1b2c13d7e..684e98f880e 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,9 @@ +2015-03-02 Daniel Colascione + + * automated/finalizer-tests.el (finalizer-basic) + (finalizer-circular-reference, finalizer-cross-reference) + (finalizer-error): New tests. + 2015-03-01 Michael Albinus * automated/vc-tests.el (vc-test--create-repo): Add check for diff --git a/test/automated/finalizer-tests.el b/test/automated/finalizer-tests.el new file mode 100644 index 00000000000..5308f01085b --- /dev/null +++ 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 +;; 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 . + +;;; 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\")")))))