diff options
| -rw-r--r-- | objcl.lisp | 70 |
1 files changed, 53 insertions, 17 deletions
@@ -51,23 +51,49 @@ (objcl-invoke-class-method condition "reason") "UTF8String"))))) -(defvar *skip-finalization* nil) -(defvar *skip-retaining* nil) -(defvar *id-objects* - (trivial-garbage:make-weak-hash-table :weakness :value - :test 'eql)) +#+cmu +(progn + (declaim (inline make-weak-value-hash-table)) + + (defun make-weak-value-hash-table () + (make-hash-table :test 'eql)) + + (defun weak-gethash (key hash-table &optional (default nil)) + (let ((pointer (gethash key hash-table default))) + (or (and (trivial-garbage:weak-pointer-p pointer) + (trivial-garbage:weak-pointer-value pointer)) + (prog1 default + ;; Clean up. + (remhash key hash-table))))) + + (defun (setf weak-gethash) (value key hash-table) + (setf (gethash key hash-table) + (trivial-garbage:make-weak-pointer value)))) + +#-cmu +(progn + (declaim (inline make-weak-value-hash-table)) -(defvar *class-objects* - (trivial-garbage:make-weak-hash-table :weakness :value - :test 'eql)) + (defun make-weak-value-hash-table () + (trivial-garbage:make-weak-hash-table :weakness :value + :test 'eql)) + + (setf (fdefinition 'weak-gethash) (fdefinition 'gethash) + (fdefinition '(setf weak-gethash)) (fdefinition '(setf gethash)))) + + +(defvar *skip-finalization* nil) +(defvar *skip-retaining* nil) -(defvar *exception-objects* - (trivial-garbage:make-weak-hash-table :weakness :value - :test 'eql)) +(defvar *id-objects* (make-weak-value-hash-table)) +(defvar *class-objects* (make-weak-value-hash-table)) +(defvar *exception-objects* (make-weak-value-hash-table)) -;; We call the `retain' method on every object that is garbage collected -;; on our side. Upon finalization, wie `release' it. +;; We call the `retain' method on every object that we receive from a +;; method call or otherwise except non-convenience constructor methods +;; (i.e. those whose name starts with `alloc' or `new'). Upon +;; Lisp-side finalization of an object, wie `release' it. (eval-when (:load-toplevel) (dolist (type '(objc-id objc-class objc-exception)) (funcall @@ -75,19 +101,19 @@ nil `(lambda () (defmethod make-instance ((class (eql ',type)) &rest initargs &key) - (let* ((hash-table ,(case type + (let* ((hash-table ,(ecase type ((objc-id) '*id-objects*) ((objc-class) '*class-objects*) ((objc-exception) '*exception-objects*))) (hash-key (pointer-address (getf initargs :pointer))) - (obj (gethash hash-key hash-table nil))) + (obj (weak-gethash hash-key hash-table nil))) (typecase obj (keyword (assert (eq :incomplete obj)) (call-next-method)) - (null (setf (gethash hash-key hash-table) + (null (setf (weak-gethash hash-key hash-table) :incomplete) (let ((new-obj (call-next-method))) - (setf (gethash hash-key hash-table) new-obj) + (setf (weak-gethash hash-key hash-table) new-obj) (unless *skip-retaining* (objcl-invoke-class-method new-obj "retain")) (unless *skip-finalization* @@ -95,6 +121,16 @@ (let ((saved-pointer (pointer-to new-obj)) (saved-type (type-of new-obj))) (flet ((finalizer () + ;; In order to send the `release' + ;; message to the newly GC'd object, + ;; we have to create a temporary + ;; container object for the final + ;; message delivery. Note that this + ;; can cause an infinite recursion + ;; or even memory corruption if we + ;; don't take measure to skip both + ;; finalization and retaining of the + ;; temporary object. (let ((temp (let ((*skip-finalization* t) (*skip-retaining* t)) (make-instance saved-type |