Sun May 31 19:41:26 CEST 2009 Tobias Rautenkranz * Ownership for return values on the stack diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp --- old-smoke/src/clos.lisp 2014-10-01 19:32:08.000000000 +0200 +++ new-smoke/src/clos.lisp 2014-10-01 19:32:08.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 +;)) diff -rN -u old-smoke/src/object-map.lisp new-smoke/src/object-map.lisp --- old-smoke/src/object-map.lisp 2014-10-01 19:32:08.000000000 +0200 +++ new-smoke/src/object-map.lisp 2014-10-01 19:32:08.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 diff -rN -u old-smoke/src/overload-resolution.lisp new-smoke/src/overload-resolution.lisp --- old-smoke/src/overload-resolution.lisp 2014-10-01 19:32:08.000000000 +0200 +++ new-smoke/src/overload-resolution.lisp 2014-10-01 19:32:08.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))))) diff -rN -u old-smoke/src/smoke.lisp new-smoke/src/smoke.lisp --- old-smoke/src/smoke.lisp 2014-10-01 19:32:08.000000000 +0200 +++ new-smoke/src/smoke.lisp 2014-10-01 19:32:08.000000000 +0200 @@ -192,4 +192,3 @@ `(defmethod ,method ,lambda-list (cancel-finalization ,object) (remove-object ,object))) -