diff options
Diffstat (limited to 'Lisp')
| -rw-r--r-- | Lisp/libobjcl.lisp | 6 | ||||
| -rw-r--r-- | Lisp/memory-management.lisp | 149 | ||||
| -rw-r--r-- | Lisp/method-invocation.lisp | 7 |
3 files changed, 80 insertions, 82 deletions
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp index 7c5fd8c..1a7e21a 100644 --- a/Lisp/libobjcl.lisp +++ b/Lisp/libobjcl.lisp @@ -412,7 +412,7 @@ conventional case for namespace identifiers in Objective-C." (let ((selector-ptr (%objcl-find-selector selector-name))) (if (cffi:null-pointer-p selector-ptr) nil - (make-pointer-wrapper 'selector :pointer selector-ptr)))) + (intern-pointer-wrapper 'selector :pointer selector-ptr)))) (defun intern-selector-by-name (selector-name) @@ -420,7 +420,7 @@ conventional case for namespace identifiers in Objective-C." (assert (not (cffi:null-pointer-p selector-ptr)) (selector-ptr) "%OBJCL-INTERN-SELECTOR must always return a selector.") - (make-pointer-wrapper 'selector :pointer selector-ptr))) + (intern-pointer-wrapper 'selector :pointer selector-ptr))) (declaim (ftype (function ((or objective-c-class id exception)) string) @@ -718,7 +718,7 @@ separating parts by hyphens works nicely in all of the `:INVERT`, (let ((superclass-ptr (%objcl-class-superclass class-ptr))) (if (and (not (null-pointer-p superclass-ptr)) (%objcl-object-is-class superclass-ptr)) - (make-pointer-wrapper t :pointer superclass-ptr) + (intern-pointer-wrapper t :pointer superclass-ptr) nil))) (defun objcl-class-superclass (class) diff --git a/Lisp/memory-management.lisp b/Lisp/memory-management.lisp index 6e4731a..3d4685d 100644 --- a/Lisp/memory-management.lisp +++ b/Lisp/memory-management.lisp @@ -23,97 +23,94 @@ (defvar *selector-objects* (make-weak-value-hash-table)) -(defun make-pointer-wrapper (class &rest initargs &key pointer &allow-other-keys) +(defun intern-pointer-wrapper (class &rest initargs &key pointer &allow-other-keys) (when (or (null-pointer-p pointer) (pointer-eq (objcl-get-nil) pointer)) - (return-from make-pointer-wrapper + (return-from intern-pointer-wrapper ;; We can't simply return +NIL+ here, because this function might ;; be called at load-time (see the MAKE-LOAD-FORM methods in ;; data-types.lisp). (make-instance 'id :pointer (objcl-get-nil)))) (when (not (eq 'selector class)) (cond ((%objcl-object-is-meta-class pointer) - (return-from make-pointer-wrapper + (return-from intern-pointer-wrapper (find-objc-meta-class-by-name (%objcl-class-name pointer)))) ((%objcl-object-is-class pointer) - (return-from make-pointer-wrapper + (return-from intern-pointer-wrapper (find-objc-class-by-name (%objcl-class-name pointer)))))) (let* ((hash-table (ecase class ((id) *id-objects*) ((exception) *exception-objects*) ((selector) *selector-objects*))) (address (cffi:pointer-address pointer)) - (object (weak-gethash address hash-table nil)) - (constructor (case class - ((exception) #'make-condition) - (otherwise #'make-instance)))) + (object (weak-gethash address hash-table nil))) (if object object - (progn - ;; Note that we do not care whether another thread does the - ;; same here, so we don't need to lock the hash table before - ;; peeking into it. If our new object isn't put into the hash - ;; table because another thread was faster than us, that's - ;; fine. The important thing here is that (a) all objects - ;; that do get into the hash table are properly set up for - ;; garbage collection, and (b) most objects don't need to be - ;; boxed and set up for garbage collection (and later - ;; garbage-collected) anew all the time but can be retrieved - ;; from the hash table. - ;; - ;; (a) is ensured by MAKE-INSTANCE (see below), while (b) is - ;; what this function is all about. - ;; - ;; Note, too, that we would indeed have to lock the hash table - ;; before peeking into it if we wanted all wrapper objects to - ;; the same object to be EQL. I think that that would - ;; probably not only be necessary, but even sufficient. - ;; - ;; By the way, is using the return value of SETF considered - ;; bad style? - (let* ((*in-make-pointer-wrapper-p* t) - (new-wrapper (apply constructor - ;; We do not create direct - ;; instances of ID anymore. - ;; Instead, we look for the correct - ;; Objective-C wrapper class and - ;; use that. - ;; - ;; Note that we do not have to - ;; handle the case of POINTER - ;; pointing to a class, because it - ;; is handled right at the - ;; beginning of the function. - (if (eq class 'id) - (primitive-invoke pointer - "class" - 'id) - class) - initargs))) - (setf (weak-gethash address hash-table) new-wrapper) - ;; As classes always have a retain count of -1, we don't - ;; have to do memory management for them. Meanwhile, - ;; selectors and meta-classes cannot receive messages, so - ;; trying to do memory management for them would not be - ;; healthy. Considering these facts, doing memory - ;; management only for id instances seems the right thing to - ;; do. - (when (eq class 'id) - ;; 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. - (unless *skip-retaining* - (primitive-invoke new-wrapper "retain" 'id)) - (flet ((finalizer () - ;; Nowadays, PRIMITIVE-INVOKE happily accepts a - ;; pointer as its first argument, which is - ;; important here because the previously created - ;; object wrapper cannot be used anymore. We're - ;; right within its finalisation phase, after - ;; all. - (weak-remhash address hash-table) - (primitive-invoke pointer "release" :void))) - (trivial-garbage:finalize new-wrapper #'finalizer))) - new-wrapper))))) + (apply #'make-pointer-wrapper hash-table address class initargs)))) + + +(defun make-pointer-wrapper (hash-table address class + &rest initargs + &key pointer &allow-other-keys) + ;; Note that we do not care whether another thread does the same here, + ;; so we don't need to lock the hash table before peeking into it. If + ;; our new object isn't put into the hash table because another thread + ;; was faster than us, that's fine. The important thing here is that + ;; (a) all objects that do get into the hash table are properly set up + ;; for garbage collection, and (b) most objects don't need to be boxed + ;; and set up for garbage collection (and later garbage-collected) + ;; anew all the time but can be retrieved from the hash table. + ;; + ;; (a) is ensured by MAKE-INSTANCE (see below), while (b) is what this + ;; function is all about. + ;; + ;; Note, too, that we would indeed have to lock the hash table before + ;; peeking into it if we wanted all wrapper objects to the same object + ;; to be EQL. I think that that would probably not only be necessary, + ;; but even sufficient. + ;; + ;; By the way, is using the return value of SETF considered bad style? + (let* ((constructor (case class + ((exception) #'make-condition) + (otherwise #'make-instance)))(*in-make-pointer-wrapper-p* t) + (new-wrapper (apply constructor + ;; We do not create direct instances of ID + ;; anymore. Instead, we look for the + ;; correct Objective-C wrapper class and + ;; use that. + ;; + ;; Note that we do not have to handle the + ;; case of POINTER pointing to a class, + ;; because it is handled right at the + ;; beginning of the function. + (if (eq class 'id) + (primitive-invoke pointer + "class" + 'id) + class) + initargs))) + (setf (weak-gethash address hash-table) new-wrapper) + ;; As classes always have a retain count of -1, we don't have to do + ;; memory management for them. Meanwhile, selectors and + ;; meta-classes cannot receive messages, so trying to do memory + ;; management for them would not be healthy. Considering these + ;; facts, doing memory management only for id instances seems the + ;; right thing to do. + (when (eq class 'id) + ;; 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. + (unless *skip-retaining* + (primitive-invoke new-wrapper "retain" 'id)) + (flet ((finalizer () + ;; Nowadays, PRIMITIVE-INVOKE happily accepts a pointer + ;; as its first argument, which is important here because + ;; the previously created object wrapper cannot be used + ;; anymore. We're right within its finalisation phase, + ;; after all. + (weak-remhash address hash-table) + (primitive-invoke pointer "release" :void))) + (trivial-garbage:finalize new-wrapper #'finalizer))) + new-wrapper)) diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp index 750647f..660b9ae 100644 --- a/Lisp/method-invocation.lisp +++ b/Lisp/method-invocation.lisp @@ -451,9 +451,10 @@ easier to use with __apply__. (let ((*skip-retaining* (or *skip-retaining* (constructor-name-p (selector-name selector))))) - (make-pointer-wrapper (car return-type) - :pointer (cffi:mem-ref objc-return-value-cell - return-c-type)))) + (intern-pointer-wrapper (car return-type) + :pointer (cffi:mem-ref + objc-return-value-cell + return-c-type)))) ((:char :unsigned-char) ;; FIXME? This is non-trivial. See policy.lisp for ;; details. |