summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
Diffstat (limited to 'Lisp')
-rw-r--r--Lisp/data-types.lisp1
-rw-r--r--Lisp/init.lisp2
-rw-r--r--Lisp/libobjcl.lisp14
-rw-r--r--Lisp/memory-management.lisp129
-rw-r--r--Lisp/method-invocation.lisp4
-rw-r--r--Lisp/parameters.lisp5
-rw-r--r--Lisp/performance-hacks.lisp27
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))))))