4 (defun make-synchronized-hash-table (&key weakness)
6 (make-weak-hash-table :weakness weakness :synchronized t)
7 (make-weak-hash-table :synchronized t)))
10 (let ((ccl::*shared-hash-table-default* t))
11 (defun make-synchronized-hash-table (&key weakness)
13 (make-weak-hash-table :weakness weakness)
14 (make-weak-hash-table))))
18 (when *supports-threads-p*
19 (cerror "Use unsynchronized hash-table"
20 "Synchronized hash table not implemented."))
21 (defun make-synchronized-hash-table (&key weakness)
23 #-cmucl (make-weak-hash-table :weakness weakness)
24 #+cmucl (make-hash-table :weak-p weakness)
28 ;; CLISP has problems with weak hash tables and finalizers.
29 ;; trivial-garbage has a workaround!?
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!
35 (defvar *object-map* (make-synchronized-hash-table :weakness :value)
36 "Contains all objects constructed by Smoke, that are not yet destructed;
37 except object with a non virtual destructor which had their ownership
41 (tg:gc :full t) ;; Try to get all #'smoke::make-auto-pointer
42 (loop for object being the hash-value of *object-map* do
43 (warn "life object ~A ~A" object (pointer object))
44 (remove-finalizer object)
45 (setf (slot-value object 'pointer) (null-pointer)))
46 (clrhash *object-map*))
48 (declaim (inline get-object))
49 (defun get-object (pointer)
50 (gethash (pointer-address pointer) *object-map*))
52 (declaim (inline (setf get-object)))
53 (defun (setf get-object) (value pointer)
54 (setf (gethash (pointer-address pointer) *object-map*)
57 (declaim (inline has-pointer-p))
58 (defun has-pointer-p (pointer)
59 "Returns T when there is an object for POINTER in the map and NIL otherwise."
60 (nth-value 1 (gethash (pointer-address pointer) *object-map*)))
62 (defun remove-object (pointer)
63 (unless (remhash (pointer-address pointer) *object-map*)
64 (cerror "ignore" "No object to remove for pointer ~A." pointer)))
66 (defun report-finalize-error (condition function class pointer)
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~%"
70 function class pointer condition)
71 #+sbcl (sb-debug:backtrace 10))
73 (declaim (inline remove-finalizer))
74 (defun remove-finalizer (object)
76 (cancel-finalization object)
78 (when (typep object 'smoke-standard-object)
79 (cancel-finalization (slot-value object 'finalizer))))
81 (declaim (inline set-finalizer))
82 (defun set-finalizer (object)
84 (finalize object (make-finalize object))
86 (finalize (slot-value object 'finalizer) (make-finalize object)))
88 (defgeneric make-finalize (object)
89 (:documentation "Returns a function to be called when OBJECT is finalized."))
91 (defmethod make-finalize (object)
92 (let ((pointer (pointer object))
93 (class (class-of object)))
95 (declare (optimize (speed 3)))
96 ;; #'remove-object is called in the destructed callback. This
97 ;; happens even for objects without an virtual destructor.
98 (handler-case (delete-pointer pointer class)
100 (report-finalize-error condition 't (name class) pointer))))))
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)))
108 (format *debug-io* "cl-smoke: finalizing: ~A..."
109 (make-instance class :pointer pointer))
111 (format *debug-io* "done~%"))))))
113 (defun add-object (object)
114 "Adds OBJECT to the pointer -> object map. It can later be retrieved
116 (when (has-pointer-p (pointer object))
117 (cerror "Overwrite the old object."
118 "There exists already a object ~A for the pointer of ~A."
119 (get-object (pointer object)) object))
120 (setf (get-object (pointer object)) object))