repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Support modular smoke & cleanup.
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 ()
2010-01-10 tobias
41
(tg:gc :full t) ;; Try to get all #'smoke::make-auto-pointer
2009-07-02 tobias
42
(loop for object being the hash-value of *object-map* do
2010-01-10 tobias
43
(warn "life object ~A ~A" object (pointer 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
14:57:59 '
62
(defun remove-object (pointer)
2009-07-22 tobias
63
(unless (remhash (pointer-address pointer) *object-map*)
22:26:05 '
64
(cerror "ignore" "No object to remove for pointer ~A." pointer)))
2009-04-05 tobias
65
2009-06-03 tobias
66
(defun report-finalize-error (condition function class pointer)
21:55:26 '
67
"Report the error CONDITION it the finalizer FUNCTION for the
'
68
object at POINTER of class CLASS."
'
69
(warn "error calling finalizer ~A for ~A ~A:~%~5T~A~%"
2009-06-22 tobias
70
function class pointer condition)
12:18:08 '
71
#+sbcl (sb-debug:backtrace 10))
2009-04-05 tobias
72
2009-06-30 tobias
73
(declaim (inline remove-finalizer))
20:54:49 '
74
(defun remove-finalizer (object)
'
75
#-clisp
'
76
(cancel-finalization object)
'
77
#+clisp
'
78
(when (typep object 'smoke-standard-object)
'
79
(cancel-finalization (slot-value object 'finalizer))))
'
80
'
81
(declaim (inline set-finalizer))
'
82
(defun set-finalizer (object)
'
83
#-clisp
'
84
(finalize object (make-finalize object))
'
85
#+clisp
'
86
(finalize (slot-value object 'finalizer) (make-finalize object)))
'
87
2009-04-05 tobias
88
(defgeneric make-finalize (object)
15:36:29 '
89
(:documentation "Returns a function to be called when OBJECT is finalized."))
'
90
'
91
(defmethod make-finalize (object)
'
92
(let ((pointer (pointer object))
'
93
(class (class-of object)))
'
94
#'(lambda ()
2009-06-22 tobias
95
(declare (optimize (speed 3)))
2009-08-30 tobias
96
;; #'remove-object is called in the destructed callback. This
14:12:44 '
97
;; happens even for objects without an virtual destructor.
2009-04-05 tobias
98
(handler-case (delete-pointer pointer class)
2009-05-31 tobias
99
(error (condition)
17:41:26 '
100
(report-finalize-error condition 't (name class) pointer))))))
2009-07-22 tobias
101
22:26:05 '
102
(defun debug-finalize ()
'
103
(eval '(defmethod make-finalize :around (object)
'
104
(let ((pointer (pointer object))
'
105
(class (class-of object))
'
106
(next (call-next-method)))
'
107
#'(lambda ()
'
108
(format *debug-io* "cl-smoke: finalizing: ~A..."
'
109
(make-instance class :pointer pointer))
'
110
(funcall next)
'
111
(format *debug-io* "done~%"))))))
2009-08-02 tobias
112
2009-04-05 tobias
113
(defun add-object (object)
2009-07-01 tobias
114
"Adds OBJECT to the pointer -> object map. It can later be retrieved
2009-05-24 tobias
115
with GET-OBJECT."
2009-09-02 tobias
116
(when (has-pointer-p (pointer object))
11:49:34 '
117
(cerror "Overwrite the old object."
'
118
"There exists already a object ~A for the pointer of ~A."
'
119
(get-object (pointer object)) object))
2009-04-05 tobias
120
(setf (get-object (pointer object)) object))