diff options
author | Matthias Benkard <code@mail.matthias.benkard.de> | 2007-08-04 15:01:53 +0200 |
---|---|---|
committer | Matthias Benkard <code@mail.matthias.benkard.de> | 2007-08-04 15:01:53 +0200 |
commit | 4765624c39dffb085554b1459b3e80bcbf347791 (patch) | |
tree | 55408134eb69247c8020c540bd65060ba951c439 /Lisp/memory-management.lisp | |
parent | 533f953b4dd068e1c76c67e7c27e820606f649bf (diff) |
Refactor directory and source file layout.
darcs-hash:0eb031a60f3b86a678869960867410811ca5325c
Diffstat (limited to 'Lisp/memory-management.lisp')
-rw-r--r-- | Lisp/memory-management.lisp | 93 |
1 files changed, 93 insertions, 0 deletions
diff --git a/Lisp/memory-management.lisp b/Lisp/memory-management.lisp new file mode 100644 index 0000000..4476957 --- /dev/null +++ b/Lisp/memory-management.lisp @@ -0,0 +1,93 @@ +(in-package #:mulk.objective-cl) + + +(defvar *skip-finalization* nil) +(defvar *skip-retaining* nil) + +(defvar *id-objects* (make-weak-value-hash-table)) +(defvar *class-objects* (make-weak-value-hash-table)) +(defvar *exception-objects* (make-weak-value-hash-table)) + + +#+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)) + + (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)))) + +;; 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 + (compile + nil + `(lambda () + (defmethod make-instance ((class (eql ',type)) &rest initargs &key) + (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 (weak-gethash hash-key hash-table nil))) + (typecase obj + (keyword (assert (eq :incomplete obj)) + (call-next-method)) + (null (setf (weak-gethash hash-key hash-table) + :incomplete) + (let ((new-obj (call-next-method))) + (setf (weak-gethash hash-key hash-table) new-obj) + (unless *skip-retaining* + (objcl-invoke-class-method new-obj "retain")) + (unless *skip-finalization* + (assert (not (null (pointer-to new-obj)))) + (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 + :pointer saved-pointer)))) + (objcl-invoke-class-method temp "release")))) + (trivial-garbage:finalize new-obj #'finalizer)))) + new-obj)) + (t obj)))) + + (defmethod initialize-instance ((obj ,type) &key) + (call-next-method))))))) |