Fri May 22 16:57:59 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Use synchronized object-map

--- old-smoke/src/object-map.lisp 2014-09-30 10:27:48.000000000 +0200

+++ new-smoke/src/object-map.lisp 2014-09-30 10:27:49.000000000 +0200

@@ -1,30 +1,48 @@

(in-package :smoke)

-(defvar *object-map*

- #-cmucl (make-weak-hash-table :weakness :value)

- #+cmucl (make-hash-table :weak-p :value)

-

- "Maps a lisp object to Smoke C++ object.")

-

-;; FIXME This probably does not scale well. A per thread object-map

-;; or at least a read-write lock should be used.

-;; => use :synchronized of sbcl hash-table

-(defvar *object-map-mutex* (make-lock "object-map lock"))

+#+sbcl

+(defun make-weak-synchronized-hash-table (&key weakness)

+ (make-weak-hash-table :weakness weakness :synchronized t))

+

+

+#+openmcl

+(let ((ccl::*shared-hash-table-default* t))

+ (defun make-weak-synchronized-hash-table (&key weakness)

+ (make-weak-hash-table :weakness weakness)))

+

+#-(or sbcl openmcl)

+(progn

+(cerror "Use unsynchronized hash-table"

+ "Synchronized hash table not implemented.")

+(defun make-weak-synchronized-hash-table (&key weakness)

+ #-cmucl (make-weak-hash-table :weakness weakness)

+ #+cmucl (make-hash-table :weak-p weakness)

+ ))

+

+(defvar *object-map* (make-weak-synchronized-hash-table :weakness :value))

+

+(declaim (inline get-object))

(defun get-object (pointer)

- (with-lock-held (*object-map-mutex*)

- (gethash (pointer-address pointer) *object-map*)))

+ (gethash (pointer-address pointer) *object-map*))

+(declaim (inline (setf get-object)))

(defun (setf get-object) (value pointer)

- (with-lock-held (*object-map-mutex*)

- (setf (gethash (pointer-address pointer) *object-map*)

- value)))

-

+ (setf (gethash (pointer-address pointer) *object-map*)

+ value))

(defun has-pointer-p (pointer)

"Returns T when there is an object for POINTER in the map and NIL otherwise."

- (with-lock-held (*object-map-mutex*)

- (nth-value 1 (gethash (pointer-address pointer) *object-map*))))

+ (nth-value 1 (gethash (pointer-address pointer) *object-map*)))

+

+(defun remove-if-exists (pointer)

+ (remhash (pointer-address pointer) *object-map*))

+

+(defun remove-object (pointer)

+ (assert (has-pointer-p pointer)

+ (pointer)

+ "No object to remove for pointer ~A." pointer)

+ (remhash (pointer-address pointer) *object-map*))

(defgeneric make-finalize (object)

@@ -49,22 +67,3 @@

(let ((finalizer (make-finalize object)))

(finalize object finalizer)))

(setf (get-object (pointer object)) object))

-

-(defun remove-if-exists (pointer)

- (with-lock-held (*object-map-mutex*)

- (remhash (pointer-address pointer) *object-map*)))

-

-(defun remove-object (pointer)

- (assert (has-pointer-p pointer)

- (pointer)

- "No object to remove for pointer ~A." pointer)

- (with-lock-held (*object-map-mutex*)

- (remhash (pointer-address pointer) *object-map*)))

-

-(defun print-garbage ()

- (with-lock-held (*object-map-mutex*)

- (maphash #'(lambda (pointer object)

- (format t "~A of type: ~S~%"

- (make-pointer pointer)

- (class-name (class-of object))))

- *object-map*)))