1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
;;;; Objective-CL, an Objective-C bridge for Common Lisp.
;;;; Copyright (C) 2007 Matthias Andreas Benkard.
;;;;
;;;; This program is free software: you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public License
;;;; as published by the Free Software Foundation, either version 3 of
;;;; the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful, but
;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this program. If not, see
;;;; <http://www.gnu.org/licenses/>.
(in-package #:mulk.objective-cl)
(defvar *id-objects* (make-weak-value-hash-table))
(defvar *exception-objects* (make-weak-value-hash-table))
(defvar *selector-objects* (make-weak-value-hash-table))
(defun make-pointer-wrapper (class &rest initargs &key pointer &allow-other-keys)
(when (not (eq 'selector class))
(cond ((%objcl-object-is-meta-class pointer)
(return-from make-pointer-wrapper
(find-objc-meta-class-by-name (%objcl-class-name pointer))))
((%objcl-object-is-class pointer)
(return-from make-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))))
(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 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
(funcall constructor class :pointer pointer)))
(primitive-invoke temporary-wrapper "release" :void))))
(trivial-garbage:finalize new-wrapper #'finalizer)))
new-wrapper)))))
|
