repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Use strcmp, fix constructor & destrucor calling for classes witn namespace (phonon::MediaPlayer) and add :arg0 to :arg2 initargs
Annotate for file src/object-map.lisp
2009-04-05 tobias
1
(in-package :smoke)
15:36:29 '
2
2009-05-22 tobias
3
#+sbcl
2009-05-31 tobias
4
(defun make-synchronized-hash-table (&key weakness)
17:41:26 '
5
(if weakness
'
6
(make-weak-hash-table :weakness weakness :synchronized t)
'
7
(make-weak-hash-table :synchronized t)))
2009-04-05 tobias
8
2009-08-02 tobias
9
2009-05-22 tobias
10
#+openmcl
14:57:59 '
11
(let ((ccl::*shared-hash-table-default* t))
2009-05-31 tobias
12
(defun make-synchronized-hash-table (&key weakness)
17:41:26 '
13
(if weakness
'
14
(make-weak-hash-table :weakness weakness)
'
15
(make-weak-hash-table))))
2009-05-22 tobias
16
14:57:59 '
17
#-(or sbcl openmcl)
'
18
(progn
2009-06-10 tobias
19
(when *supports-threads-p*
12:01:10 '
20
(cerror "Use unsynchronized hash-table"
'
21
"Synchronized hash table not implemented."))
2009-05-31 tobias
22
(defun make-synchronized-hash-table (&key weakness)
17:41:26 '
23
(if weakness
2009-06-30 tobias
24
#-cmucl (make-weak-hash-table :weakness weakness)
2009-05-31 tobias
25
#+cmucl (make-hash-table :weak-p weakness)
17:41:26 '
26
(make-hash-table))))
2009-06-11 tobias
27
18:45:05 '
28
;; FIXME
2009-07-01 tobias
29
;; CLISP has problems with weak hash tables and finalizers.
2009-06-11 tobias
30
;; trivial-garbage has a workaround!?
18:45:05 '
31
;; http://sourceforge.net/tracker/index.php?func=detail&aid=1472478&group_id=1355&atid=101355
'
32
;; crashes 2.47 and 2.44.1
'
33
;; Works when not using a weak hash table, but now we are leaking memory!
2009-05-22 tobias
34
14:57:59 '
35
2009-05-31 tobias
36
(defvar *object-map* (make-synchronized-hash-table :weakness :value)
17:41:26 '
37
"Contains all objects constructed by Smoke, that are not yet destructed;
2009-08-02 tobias
38
except object with a non virtual destructor which had their ownership transferred
10:12:41 '
39
to C++.")
2009-05-22 tobias
40
2009-07-02 tobias
41
(eval-on-save ()
19:08:40 '
42
(loop for object being the hash-value of *object-map* do
2010-01-10 tobias
43
(warn "life object ~A" object)
2009-07-02 tobias
44
(remove-finalizer object)
19:08:40 '
45
(setf (slot-value object 'pointer) (null-pointer)))
'
46
(clrhash *object-map*))
'
47
2009-05-22 tobias
48
(declaim (inline get-object))
2009-04-05 tobias
49
(defun get-object (pointer)
2009-06-22 tobias
50
(gethash (pointer-address pointer) *object-map*))
2009-04-05 tobias
51
2009-05-22 tobias
52
(declaim (inline (setf get-object)))
2009-04-05 tobias
53
(defun (setf get-object) (value pointer)
2009-06-22 tobias
54
(setf (gethash (pointer-address pointer) *object-map*)
2009-05-22 tobias
55
value))
2009-04-05 tobias
56
2009-06-22 tobias
57
(declaim (inline has-pointer-p))
2009-04-05 tobias
58
(defun has-pointer-p (pointer)
15:36:29 '
59
"Returns T when there is an object for POINTER in the map and NIL otherwise."
2009-06-22 tobias
60
(nth-value 1 (gethash (pointer-address pointer) *object-map*)))
2009-05-22 tobias
61
2009-08-02 tobias
62
(defun remove-if-exists (pointer)
10:12:41 '
63
(remhash (pointer-address pointer) *object-map*))
'
64
2009-05-22 tobias
65
(defun remove-object (pointer)
2009-08-02 tobias
66
(declare (optimize (speed 3)))
2009-07-22 tobias
67
(unless (remhash (pointer-address pointer) *object-map*)
22:26:05 '
68
(cerror "ignore" "No object to remove for pointer ~A." pointer)))
2009-04-05 tobias
69
2009-06-03 tobias
70
(defun report-finalize-error (condition function class pointer)
21:55:26 '
71
"Report the error CONDITION it the finalizer FUNCTION for the
'
72
object at POINTER of class CLASS."
'
73
(warn "error calling finalizer ~A for ~A ~A:~%~5T~A~%"
2009-06-22 tobias
74
function class pointer condition)
12:18:08 '
75
#+sbcl (sb-debug:backtrace 10))
2009-04-05 tobias
76
2009-06-30 tobias
77
(declaim (inline remove-finalizer))
20:54:49 '
78
(defun remove-finalizer (object)
'
79
#-clisp
'
80
(cancel-finalization object)
'
81
#+clisp
'
82
(when (typep object 'smoke-standard-object)
'
83
(cancel-finalization (slot-value object 'finalizer))))
'
84
'
85
(declaim (inline set-finalizer))
'
86
(defun set-finalizer (object)
'
87
#-clisp
'
88
(finalize object (make-finalize object))
'
89
#+clisp
'
90
(finalize (slot-value object 'finalizer) (make-finalize object)))
'
91
2009-04-05 tobias
92
(defgeneric make-finalize (object)
15:36:29 '
93
(:documentation "Returns a function to be called when OBJECT is finalized."))
'
94
'
95
(defmethod make-finalize (object)
'
96
(let ((pointer (pointer object))
'
97
(class (class-of object)))
'
98
#'(lambda ()
2009-06-22 tobias
99
(declare (optimize (speed 3)))
2009-04-05 tobias
100
(handler-case (delete-pointer pointer class)
2009-05-31 tobias
101
(error (condition)
17:41:26 '
102
(report-finalize-error condition 't (name class) pointer))))))
2009-07-22 tobias
103
22:26:05 '
104
(defun debug-finalize ()
'
105
(eval '(defmethod make-finalize :around (object)
'
106
(let ((pointer (pointer object))
'
107
(class (class-of object))
'
108
(next (call-next-method)))
'
109
#'(lambda ()
'
110
(format *debug-io* "cl-smoke: finalizing: ~A..."
'
111
(make-instance class :pointer pointer))
'
112
(funcall next)
'
113
(format *debug-io* "done~%"))))))
2009-08-02 tobias
114
2009-04-05 tobias
115
(defun add-object (object)
2009-07-01 tobias
116
"Adds OBJECT to the pointer -> object map. It can later be retrieved
2009-05-24 tobias
117
with GET-OBJECT."
2009-08-02 tobias
118
(assert (not (has-pointer-p (pointer object)))
10:12:41 '
119
()
2009-09-02 tobias
120
"There exists already a object ~A for the pointer of ~A."
11:49:34 '
121
(get-object (pointer object)) object)
2009-04-05 tobias
122
(setf (get-object (pointer object)) object))