diff options
Diffstat (limited to 'Lisp')
| -rw-r--r-- | Lisp/data-types.lisp | 1 | ||||
| -rw-r--r-- | Lisp/init.lisp | 2 | ||||
| -rw-r--r-- | Lisp/libobjcl.lisp | 14 | ||||
| -rw-r--r-- | Lisp/memory-management.lisp | 129 | ||||
| -rw-r--r-- | Lisp/method-invocation.lisp | 4 | ||||
| -rw-r--r-- | Lisp/parameters.lisp | 5 | ||||
| -rw-r--r-- | Lisp/performance-hacks.lisp | 27 |
7 files changed, 114 insertions, 68 deletions
diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp index 11ac9fe..cf175a1 100644 --- a/Lisp/data-types.lisp +++ b/Lisp/data-types.lisp @@ -182,7 +182,6 @@ an __exception__, you can simply send it the `self' message. (list* 'struct '() name (mapcar #'type-info children)))) - (defgeneric objcl-eql (obj1 obj2)) (defmethod objcl-eql ((obj1 c-pointer-wrapper) (obj2 c-pointer-wrapper)) (pointer-eq (pointer-to obj1) (pointer-to obj2))) diff --git a/Lisp/init.lisp b/Lisp/init.lisp index a56d2e2..f965995 100644 --- a/Lisp/init.lisp +++ b/Lisp/init.lisp @@ -4,6 +4,8 @@ (eval-when (:load-toplevel) (unless (boundp '+nil+) + ;; As nil is never deallocated, we can safely use MAKE-INSTANCE + ;; here. (defconstant +nil+ (make-instance 'id :pointer (objcl-get-nil)))) (unless (boundp '+yes+) diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp index d2f3e3c..9d8a6be 100644 --- a/Lisp/libobjcl.lisp +++ b/Lisp/libobjcl.lisp @@ -206,10 +206,10 @@ conventional case for namespace identifiers in Objective C." (let ((class-ptr (%objcl-find-class class-name))) (if (cffi:null-pointer-p class-ptr) nil - #-openmcl (make-instance 'objc-class :pointer class-ptr) - #+openmcl (change-class (make-instance 'c-pointer-wrapper - :pointer value) - 'objc-class)))) + #-(or t openmcl) (make-pointer-wrapper 'objc-class :pointer class-ptr) + #+(and nil openmcl) (change-class (make-pointer-wrapper 'c-pointer-wrapper + :pointer value) + 'objc-class)))) (declaim (ftype (function (string) (or null selector)) @@ -218,7 +218,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-instance 'selector :pointer selector-ptr)))) + (make-pointer-wrapper 'selector :pointer selector-ptr)))) (declaim (ftype (function ((or objc-class id exception)) string) @@ -306,11 +306,11 @@ by which __invoke__ converts its arguments into a *message name*. (%objcl-object-is-meta-class (pointer-to obj))) (defun object-get-class (obj) - (make-instance 'objc-class + (make-pointer-wrapper 'objc-class :pointer (%objcl-object-get-class (pointer-to obj)))) (defun object-get-meta-class (obj) - (make-instance 'objc-meta-class + (make-pointer-wrapper 'objc-meta-class :pointer (%objcl-object-get-meta-class (pointer-to obj)) :meta-class-for-class (object-get-class obj))) diff --git a/Lisp/memory-management.lisp b/Lisp/memory-management.lisp index de75626..f8bebbf 100644 --- a/Lisp/memory-management.lisp +++ b/Lisp/memory-management.lisp @@ -4,62 +4,77 @@ (defvar *id-objects* (make-weak-value-hash-table)) (defvar *class-objects* (make-weak-value-hash-table)) (defvar *exception-objects* (make-weak-value-hash-table)) +(defvar *selector-objects* (make-weak-value-hash-table)) +(defvar *meta-class-objects* (make-weak-value-hash-table)) -;; 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 '(id objc-class exception)) - (funcall - (compile - nil - `(lambda () - (defmethod make-instance ((class (eql ',type)) &rest initargs &key) - (let* ((hash-table ,(ecase type - ((id) '*id-objects*) - ((objc-class) '*class-objects*) - ((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))) - (unless *skip-retaining* - (primitive-invoke new-obj "retain" 'id)) - (unless *skip-finalization* - ;; We only put the new object into the hash - ;; table if it is a regular wrapper object - ;; rather than a temporary one, else the object - ;; pointed to might be released prematurely - ;; because of the lack of memory management. - (setf (weak-gethash hash-key hash-table) new-obj) - (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)))) - (primitive-invoke temp "release" :void)))) - (trivial-garbage:finalize new-obj #'finalizer)))) - new-obj)) - (t obj)))) - - (defmethod initialize-instance ((obj ,type) &key) - (call-next-method))))))) +(defun make-pointer-wrapper (class &rest initargs &key pointer &allow-other-keys) + (let* ((hash-table (ecase class + ((id) *id-objects*) + ((objc-class) *class-objects*) + ((exception) *exception-objects*) + ((selector) *selector-objects*) + ((objc-meta-class) *meta-class-objects*))) + (address (cffi:pointer-address pointer)) + (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 #'make-instance 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 () + ;; 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. Therefore, we call MAKE-INSTANCE + ;; directly. + ;; + ;; (In principle, PRIMITIVE-INVOKE should also + ;; happily take a pointer as its first argument, + ;; but why push our luck?) + (let* ((temporary-wrapper + (make-instance class :pointer pointer))) + (primitive-invoke temporary-wrapper "release" :void)))) + (trivial-garbage:finalize new-wrapper #'finalizer))) + new-wrapper))))) diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp index 83fead1..9e44e62 100644 --- a/Lisp/method-invocation.lisp +++ b/Lisp/method-invocation.lisp @@ -254,7 +254,7 @@ easier to use with __apply__. return-c-type))) (if (cffi:null-pointer-p pointer) nil - (make-instance return-type :pointer pointer)))) + (make-pointer-wrapper return-type :pointer pointer)))) ((:void) (values)) (otherwise (cffi:mem-ref return-value-cell return-c-type))))))))))) @@ -402,7 +402,7 @@ easier to use with __apply__. (let ((*skip-retaining* (or *skip-retaining* (constructor-name-p (selector-name selector))))) - (make-instance (car return-type) + (make-pointer-wrapper (car return-type) :pointer (cffi:mem-ref objc-return-value-cell return-c-type)))) ((:void) (values)) diff --git a/Lisp/parameters.lisp b/Lisp/parameters.lisp index cd8890d..524e34e 100644 --- a/Lisp/parameters.lisp +++ b/Lisp/parameters.lisp @@ -3,9 +3,12 @@ (defvar *runtime-initialisation-level* 0) -(defvar *skip-finalization* nil) (defvar *skip-retaining* nil) +(defvar *in-make-pointer-wrapper-p* nil + "A debugging tool that helps identify direct MAKE-INSTANCE calls that +ought not be there.") + (defvar *trace-method-calls* nil "Whether to print trace messages of all Objective C method calls. diff --git a/Lisp/performance-hacks.lisp b/Lisp/performance-hacks.lisp new file mode 100644 index 0000000..054fe5e --- /dev/null +++ b/Lisp/performance-hacks.lisp @@ -0,0 +1,27 @@ +(in-package #:mulk.objective-cl) + +;;; This file is for hacks that we might not want to actually use in a +;;; production environment but which might be useful in determining +;;; performance bottlenecks. These hacks may depend on specific +;;; versions of third-party libraries such as CFFI. + + +;;; The following hack depends on a specific CFFI snapshot. It tries to +;;; alleviate the apparent slowness of CFFI::PARSE-TYPE in that +;;; particular snapshot. +;;; +;;; The performance improvement for method calls accomplished by this +;;; hack amounts to approximately 80 % for PRIMITIVE-INVOKE and +;;; approximately 50 % for INVOKE. +#+(or) +(progn + (defparameter *cffi-hacked* nil) + (eval-when (:load-toplevel) + ;; If we do this more than once, we cache our own cached function, + ;; which is kind of useless. + (unless *cffi-hacked* + (setq *cffi-hacked* t) + (let ((original-cffi-parse-type-fn (fdefinition 'cffi::parse-type))) + (define-cached-function cffi::parse-type (type) + type + (funcall original-cffi-parse-type-fn type)))))) |