(in-package :smoke)

#+sbcl 
(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-synchronized-hash-table (&key weakness)
    (if weakness
        (make-weak-hash-table :weakness weakness)
        (make-weak-hash-table))))

#-(or sbcl openmcl)
(progn
  (when *supports-threads-p*
    (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))))

;; FIXME
;; CLISP has problems with weak hash tables and finalizers.
;; trivial-garbage has a workaround!?
;; http://sourceforge.net/tracker/index.php?func=detail&aid=1472478&group_id=1355&atid=101355
;; crashes 2.47 and 2.44.1
;; Works when not using a weak hash table, but now we are leaking memory!
     

(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 destructor which had their ownership
transferred to C++.")

(eval-on-save ()
  (tg:gc :full t) ;; Try to get all #'smoke::make-auto-pointer
  (loop for object being the hash-value of *object-map* do
       (warn "life object ~A ~A" object (pointer object))
       (remove-finalizer object)
       (setf (slot-value object 'pointer) (null-pointer)))
  (clrhash *object-map*))

(declaim (inline get-object))
(defun get-object (pointer)
  (gethash (pointer-address pointer) *object-map*))

(declaim (inline (setf get-object)))
(defun (setf get-object) (value pointer)
  (setf (gethash (pointer-address pointer) *object-map*)
        value))

(declaim (inline has-pointer-p))
(defun has-pointer-p (pointer)
  "Returns T when there is an object for POINTER in the map and NIL otherwise."
  (nth-value 1 (gethash (pointer-address pointer) *object-map*)))

(defun remove-object (pointer)
  (unless (remhash (pointer-address pointer) *object-map*)
    (cerror "ignore" "No object to remove for pointer ~A." pointer)))

(defun report-finalize-error (condition function class pointer)
  "Report the error CONDITION it the finalizer FUNCTION for the
object at POINTER of class CLASS."
  (warn "error calling finalizer ~A for ~A ~A:~%~5T~A~%"
        function class pointer condition)
  #+sbcl (sb-debug:backtrace 10))

(declaim (inline remove-finalizer))
(defun remove-finalizer (object)
  #-clisp
  (cancel-finalization object)
  #+clisp
  (when (typep object 'smoke-standard-object)
    (cancel-finalization (slot-value object 'finalizer))))

(declaim (inline set-finalizer))
(defun set-finalizer (object)
  #-clisp
  (finalize object (make-finalize object))
  #+clisp
  (finalize (slot-value object 'finalizer) (make-finalize object)))

(defgeneric make-finalize (object)
  (:documentation "Returns a function to be called when OBJECT is finalized."))

(defmethod make-finalize (object)
  (let ((pointer (pointer object))
        (class (class-of object)))
    #'(lambda ()
        (declare (optimize (speed 3)))
        ;; #'remove-object is called in the destructed callback. This
        ;; happens even for objects without an virtual destructor.
        (handler-case (delete-pointer pointer class)
          (error (condition)
            (report-finalize-error condition 't (name class) pointer))))))

(defun debug-finalize ()
  (eval '(defmethod make-finalize :around (object)
          (let ((pointer (pointer object))
                (class (class-of object))
                (next (call-next-method)))
            #'(lambda ()
                (format *debug-io* "cl-smoke: finalizing: ~A..."
                        (make-instance class :pointer pointer))
                (funcall next)
                (format *debug-io* "done~%"))))))
        
(defun add-object (object)
  "Adds OBJECT to the pointer -> object map. It can later be retrieved
with GET-OBJECT."
  (when (has-pointer-p (pointer object))
    (cerror "Overwrite the old object."
            "There exists already a object ~A for the pointer of ~A."
            (get-object (pointer object)) object))
  (setf (get-object (pointer object)) object))