repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Fix undefine init_smoke* C function & cleanup finalizers when a image is saved.
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
'
43
(warn "life object ~A" (class-of object))
'
44
(remove-finalizer object)
'
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
(assert (has-pointer-p pointer)
22:26:05 '
68
(pointer)
'
69
"No object to remove for pointer ~A." pointer)
'
70
(remhash (pointer-address pointer) *object-map*))
2009-04-05 tobias
71
2009-06-03 tobias
72
(defun report-finalize-error (condition function class pointer)
21:55:26 '
73
"Report the error CONDITION it the finalizer FUNCTION for the
'
74
object at POINTER of class CLASS."
'
75
(warn "error calling finalizer ~A for ~A ~A:~%~5T~A~%"
2009-06-22 tobias
76
function class pointer condition)
12:18:08 '
77
#+sbcl (sb-debug:backtrace 10))
2009-04-05 tobias
78
2009-06-30 tobias
79
(declaim (inline remove-finalizer))
20:54:49 '
80
(defun remove-finalizer (object)
'
81
#-clisp
'
82
(cancel-finalization object)
'
83
#+clisp
'
84
(when (typep object 'smoke-standard-object)
'
85
(cancel-finalization (slot-value object 'finalizer))))
'
86
'
87
(declaim (inline set-finalizer))
'
88
(defun set-finalizer (object)
'
89
#-clisp
'
90
(finalize object (make-finalize object))
'
91
#+clisp
'
92
(finalize (slot-value object 'finalizer) (make-finalize object)))
'
93
2009-04-05 tobias
94
(defgeneric make-finalize (object)
15:36:29 '
95
(:documentation "Returns a function to be called when OBJECT is finalized."))
'
96
'
97
(defmethod make-finalize (object)
'
98
(let ((pointer (pointer object))
'
99
(class (class-of object)))
'
100
#'(lambda ()
2009-06-22 tobias
101
(declare (optimize (speed 3)))
2009-04-05 tobias
102
(handler-case (delete-pointer pointer class)
2009-05-31 tobias
103
(error (condition)
17:41:26 '
104
(report-finalize-error condition 't (name class) pointer))))))
2009-08-02 tobias
105
2009-04-05 tobias
106
(defun add-object (object)
2009-07-01 tobias
107
"Adds OBJECT to the pointer -> object map. It can later be retrieved
2009-05-24 tobias
108
with GET-OBJECT."
2009-08-02 tobias
109
(assert (not (has-pointer-p (pointer object)))
10:12:41 '
110
()
2009-09-02 tobias
111
"There exists already a object ~A for the pointer of ~A."
11:49:34 '
112
(get-object (pointer object)) object)
2009-04-05 tobias
113
(setf (get-object (pointer object)) object))