Sun May 31 19:41:26 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Ownership for return values on the stack

--- old-smoke/src/clos.lisp 2014-09-28 09:40:46.000000000 +0200

+++ new-smoke/src/clos.lisp 2014-09-28 09:40:46.000000000 +0200

@@ -121,22 +121,19 @@

()

(:documentation "A Smoke C++ class"))

-(defclass smoke-wrapper-class (smoke-standard-class)

+(defclass cxx:class (smoke-standard-class)

((smoke :reader smoke-symbol :initarg :smoke-symbol

- :type symbol)))

+ :type symbol))

+ (:documentation "Metaclass to extend Smoke Objects."))

-(defmethod smoke ((class smoke-wrapper-class))

+(defmethod smoke ((class cxx:class))

(eval (smoke-symbol class)))

-(defclass cxx:class (smoke-wrapper-class)

- ()

- (:documentation "Metaclass to extend Smoke Objects."))

-

(defmethod closer-mop:validate-superclass ((class smoke-standard-class) (superclass standard-class))

T)

-(defmethod closer-mop:validate-superclass ((class smoke-wrapper-class) (superclass smoke-standard-class))

+(defmethod closer-mop:validate-superclass ((class cxx:class) (superclass smoke-standard-class))

T)

(defmethod reinitialize-instance :around

@@ -159,7 +156,7 @@

args))

(defmethod reinitialize-instance :around

- ((class smoke-wrapper-class)

+ ((class cxx:class)

&rest args &key direct-superclasses &allow-other-keys)

(assert (not (null direct-superclasses))

(direct-superclasses)

@@ -176,7 +173,7 @@

args)))

(defmethod initialize-instance :around

- ((class smoke-wrapper-class)

+ ((class cxx:class)

&rest args &key direct-superclasses &allow-other-keys)

(assert (not (null direct-superclasses))

(direct-superclasses)

@@ -259,6 +256,7 @@

(let ((object (get-object object-pointer)))

(when object

(cancel-finalization object)

+ (remove-wrapper-object object)

(remove-object object-pointer)

(setf (slot-value object 'pointer) (null-pointer)))))

@@ -275,6 +273,8 @@

arg))))))

(defun convert-argument (argument type &optional (user t))

+ "Returns ARGUMENT converted to TYPE. If USER is true, user defined

+conversion sequences are considered."

(let ((rank (get-conversion-sequence argument type user)))

(if (null rank)

(error "Can not convert the argument ~S to ~A."

@@ -293,14 +293,8 @@

(let ((converted-value (convert-argument value type nil)))

(push-smoke-stack stack converted-value (type-id type))

(when (stack-p type) ;; Pass by value => smoke deletes the object.

- (cancel-finalization converted-value)

- (when (and (class-p type)

- (not (virtual-destructor-p (get-class type))))

- (if (pointerp converted-value)

- (remove-object converted-value)

- (progn

- (cancel-finalization value)

- (remove-object (pointer value))))))))))

+ (cancel-finalization converted-value)

+ (disown-object value))))))

(defun get-gf-for-method (smoke-method)

(declare (smoke-method smoke-method)

@@ -403,3 +397,43 @@

(take-ownership ret)

(add-object ret))

ret))

+

+(defvar *cxx-wrapper-objects* (make-synchronized-hash-table))

+

+(defun keep-wrapper (object)

+ (assert (not (gethash object *cxx-wrapper-objects*)))

+ (setf (gethash object *cxx-wrapper-objects*) object))

+

+(defun remove-wrapper-object (object)

+ (remhash object *cxx-wrapper-objects*))

+

+(defun disown-object (object)

+ "Transfers the ownership of OBJECT to C++."

+ (cancel-finalization object)

+ (if (typep (class-of object) 'cxx:class)

+ (progn

+ (assert (virtual-destructor-p (class-of object))

+ ()

+ "The ownership of the object ~A is transfered to C++, but

+it has a nonvirtual destructor." object)

+ (keep-wrapper object))

+ (when (and (typep object 'smoke-standard-object)

+ (not (virtual-destructor-p (class-of object))))

+ (remove-object (pointer object)))))

+

+

+

+(defun take-ownership (object)

+ "Assigns the ownership of OBJECT to Lisp. i.e.:

+cl-smoke is responsible for deleting the object."

+ (remove-wrapper-object object)

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

+ (finalize object finalizer)))

+

+;(eval-when (:load-toplevel)

+; (trace disown-object

+; keep-wrapper

+; remove-wrapper-object

+;take-ownership

+;put-returnvalue

+;))

--- old-smoke/src/object-map.lisp 2014-09-28 09:40:46.000000000 +0200

+++ new-smoke/src/object-map.lisp 2014-09-28 09:40:46.000000000 +0200

@@ -1,26 +1,34 @@

(in-package :smoke)

#+sbcl

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

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

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

+ (if weakness

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

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

#+openmcl

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

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

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

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

+ (if weakness

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

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

#-(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)

- ))

+ (cerror "Use unsynchronized hash-table"

+ "Synchronized hash table not implemented.")

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

+ (if weakness

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

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

+ (make-hash-table))))

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

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

+ "Contains all objects constructed by Smoke, that are not yet destructed;

+except object with a non virtual destuctor which had their ownership transfered

+to C++.")

(declaim (inline get-object))

(defun get-object (pointer)

@@ -44,6 +52,9 @@

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

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

+(defun report-finalize-error (condition function object pointer)

+ (warn "error calling finalizer ~A for ~A ~A:~%~5T~A"

+ function object pointer condition))

(defgeneric make-finalize (object)

(:documentation "Returns a function to be called when OBJECT is finalized."))

@@ -53,16 +64,8 @@

(class (class-of object)))

#'(lambda ()

(handler-case (delete-pointer pointer class)

- (condition (condition)

- (format *debug-io* "error finalize ~A ~A~%" (name class)

- condition))))))

-

-

-(defun take-ownership (object)

- "Assigns the ownership of OBJECT to Lisp. i.e.:

-cl-smoke is responsible for deleting the object."

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

- (finalize object finalizer)))

+ (error (condition)

+ (report-finalize-error condition 't (name class) pointer))))))

(defun add-object (object)

"Adds OBJECT to the pointer -> object map. It can later be retrived

--- old-smoke/src/overload-resolution.lisp 2014-09-28 09:40:46.000000000 +0200

+++ new-smoke/src/overload-resolution.lisp 2014-09-28 09:40:46.000000000 +0200

@@ -481,6 +481,9 @@

(if (null arguments)

(let ((method (find-smoke-method (smoke-class-of object-or-class)

name)))

+ (assert (valid-p method)

+ ()

+ "No applicable method ~A() for ~A." name object-or-class)

(if (static-p method)

(s-call method (null-pointer))

(s-call method (cast object-or-class (get-class method)))))

--- old-smoke/src/smoke.lisp 2014-09-28 09:40:46.000000000 +0200

+++ new-smoke/src/smoke.lisp 2014-09-28 09:40:46.000000000 +0200

@@ -192,4 +192,3 @@

`(defmethod ,method ,lambda-list

(cancel-finalization ,object)

(remove-object ,object)))

-