/[cmucl]/src/code/final.lisp
ViewVC logotype

Contents of /src/code/final.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Mon Apr 19 02:18:03 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.4: +3 -3 lines
Remove _N"" reader macro from docstrings when possible.
1 ;;; -*- Package: EXTENSIONS -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/final.lisp,v 1.5 2010/04/19 02:18:03 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Finalization based on weak pointers. Written by William Lott, but
13 ;;; the idea really was Chris Hoover's.
14 ;;;
15
16 (in-package "EXTENSIONS")
17
18 (intl:textdomain "cmucl")
19
20 (export '(finalize cancel-finalization))
21
22 (defvar *objects-pending-finalization* nil)
23
24 (defun finalize (object function)
25 "Arrange for FUNCTION to be called when there are no more references to
26 OBJECT. FUNCTION takes no arguments."
27 (declare (type function function))
28 (system:without-gcing
29 (push (cons (make-weak-pointer object) function)
30 *objects-pending-finalization*))
31 object)
32
33 (defun cancel-finalization (object)
34 "Cancel any finalization registers for OBJECT."
35 (when object
36 ;; We check to make sure object isn't nil because if there are any
37 ;; broken weak pointers, their value will show up as nil. Therefore,
38 ;; they would be deleted from the list, but not finalized. Broken
39 ;; weak pointers shouldn't be left in the list, but why take chances?
40 (system:without-gcing
41 (setf *objects-pending-finalization*
42 (delete object *objects-pending-finalization*
43 :key #'(lambda (pair)
44 (values (weak-pointer-value (car pair))))))))
45 nil)
46
47 (defun finalize-corpses ()
48 (setf *objects-pending-finalization*
49 (delete-if #'(lambda (pair)
50 (multiple-value-bind
51 (object valid)
52 (weak-pointer-value (car pair))
53 (declare (ignore object))
54 (unless valid
55 (funcall (cdr pair))
56 t)))
57 *objects-pending-finalization*))
58 nil)
59
60 (pushnew 'finalize-corpses *after-gc-hooks*)

  ViewVC Help
Powered by ViewVC 1.1.5