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