synchronized hash tables with weak keys may have duplicate entries

When using synchronized hash tables with weak keys (either :weakness :key or :weakness :key-and-value) we sometimes get duplicated entries, so we can't recover the value reliably. The test case is awfully big, but that's what I have for now. I'll try to minimize it later.

(in-package "CL-USER")

(eval-when (:compile-toplevel :execute :load-toplevel)

  (unless (find-package "BORDEAUX-THREADS")
    #+quicklisp (ql:quickload "bordeaux-threads")
    #-quicklisp (error "Please load \"bordeaux-threads\"."))

  (unless (find-package "TRIVIAL-GARBAGE")
    #+quicklisp (ql:quickload "bordeaux-threads")
    #-quicklisp (error "Please load \"trivial-garbage\".")))

(in-package "CL-USER")



(defun make-dynamic-variable-using-class (class &rest initargs)
  (apply #'make-instance class initargs))

(defparameter *default-dynamic-variable-class*
  'surrogate-dynamic-variable)

(defun make-dynamic-variable (&rest initargs)
  (apply #'make-dynamic-variable-using-class *default-dynamic-variable-class*
         initargs))


(defmacro dlet (bindings &body body)
  (flet ((pred (binding)
           (and (listp binding) (= 2 (length binding)))))
    (unless (every #'pred bindings)
      (error "DLET: bindings must be lists of two values.~%~
              Invalid bindings:~%~{ ~s~%~}" (remove-if #'pred bindings))))
  (loop for (var val) in bindings
        collect var into vars
        collect val into vals
        finally (return `(dynamic-variable-progv (list ,@vars) (list ,@vals)
                           ,@body))))

(defmacro dset (&rest pairs)
  `(setf ,@(loop for (var val) on pairs by #'cddr
                 collect `(dref ,var)
                 collect val)))

(defmacro dref (variable)
  `(dynamic-variable-value ,variable))


(defun call-with-dynamic-variable-progv (cont vars vals)
  (flet ((thunk ()
           (if vals
               (call-with-dynamic-variable cont (car vars) (car vals))
               (call-with-dynamic-variable cont (car vars)))))
    (if vars
        (call-with-dynamic-variable-progv #'thunk (cdr vars) (cdr vals))
        (funcall cont))))

(defmacro dynamic-variable-progv (vars vals &body body)
  (let ((cont (gensym)))
    `(flet ((,cont () ,@body))
       (call-with-dynamic-variable-progv (function ,cont) ,vars ,vals))))



(defvar +fake-unbound+ 'unbound)
(defvar +cell-unbound+ '(no-binding))

;;; CCL can't into :KEY-AND-VALUE.
(defclass surrogate-dynamic-variable ()
  ((tls-table
    :initform (make-hash-table :synchronized t
                               :weakness :key)
    :reader dynamic-variable-tls-table)
   (top-value
    :initform +fake-unbound+
    :accessor dynamic-variable-top-value)))

(defun %dynamic-variable-bindings (dvar)
  (let ((process (bt:current-thread))
        (tls-table (dynamic-variable-tls-table dvar)))
    (or (gethash process tls-table)
        (setf (gethash process tls-table) +cell-unbound+))))

(defun (setf %dynamic-variable-bindings) (value dvar)
  (let ((process (bt:current-thread))
        (tls-table (dynamic-variable-tls-table dvar)))
    (when (< (length value) 1)
      (error "booya"))
    (setf (gethash process tls-table) value)))

(defun dynamic-variable-value (dvar)
  (let ((tls-binds (%dynamic-variable-bindings dvar)))
    (if (eq tls-binds +cell-unbound+)
        (dynamic-variable-top-value dvar)
        (car tls-binds))))

(defun (setf dynamic-variable-value) (value dvar)
  (let ((tls-binds (%dynamic-variable-bindings dvar)))
    (if (eq tls-binds +cell-unbound+)
        (setf (dynamic-variable-top-value dvar) value)
        (setf (car tls-binds) value))))

(defvar *badhash* nil)
(defun call-with-dynamic-variable (cont dvar &optional (val +fake-unbound+))
  (push val (%dynamic-variable-bindings dvar))
  (assert (>= (length (%dynamic-variable-bindings dvar)) 2) nil "firt")
  (unwind-protect (funcall cont)
    (let ((bindings (%dynamic-variable-bindings dvar)))
      (unless (>= (length bindings) 2)
        (format t "----------------------------------~%")
        (format t "~a? ~a~%" (bt:current-thread) bindings)
        (setf *badhash* (dynamic-variable-tls-table dvar))
        (maphash (lambda (k v)
                   (if (eq k (bt:current-thread))
                       (format t "~a: ~a <---~%" k v)
                       (format t "~a: ~a~%" k v)))
                 (dynamic-variable-tls-table dvar))
        (error "plops")))
    (pop (%dynamic-variable-bindings dvar))))


#+ (or)
(defun call-with-dynamic-variable (cont dvar &optional (val +fake-unbound+))
  (push val (%dynamic-variable-bindings dvar))
  (assert (>= (length (%dynamic-variable-bindings dvar)) 2) nil "firt")
  (unwind-protect (funcall cont)
    (assert (>= (length (%dynamic-variable-bindings dvar)) 2) nil "secd")
    (pop (%dynamic-variable-bindings dvar))))

;;; This is a metaclass that allows defining dynamic slots that are bound with
;;; the operator SLOT-DLET.

;;; Slot definitions
;;; There is a considerable boilerplate involving customizing slots.
;;;
;;; - direct slot definition: local to a single defclass form
;;;
;;; - effective slot definition: combination of all direct slots with the same
;;;   name in the class and its superclasses
;;;
(defclass dynamic-direct-slot (mop:standard-direct-slot-definition)
  ((dynamic :initform nil :initarg :dynamic :reader dynamic-slot-p)))

;;; DYNAMIC-EFFECTIVE-SLOT is implemented to return as slot-value values of the
;;; dynamic variable that is stored with the instance.
;;;
;;; It would be nice if we could specify :ALLOCATION :DYNAMIC for the slot, but
;;; then STANDARD-INSTANCE-ACCESS would go belly up. We could make a clever
;;; workaround, but who cares?
(defclass dynamic-effective-slot (mop:standard-effective-slot-definition)
  ())

(defmethod mop:slot-value-using-class
    ((class standard-class)
     object
     (slotd dynamic-effective-slot))
  (dref (slot-dvar object slotd)))

(defmethod (setf mop:slot-value-using-class)
    (new-value
     (class standard-class)
     object
     (slotd dynamic-effective-slot))
  (dset (slot-dvar object slotd) new-value))

(defmethod mop:slot-boundp-using-class
  ((class standard-class)
   object
   (slotd dynamic-effective-slot))
  (dynamic-variable-bound-p (slot-dvar object slotd)))

(defmethod mop:slot-makunbound-using-class
  ((class standard-class)
   object
   (slotd dynamic-effective-slot))
  (dynamic-variable-makunbound (slot-dvar object slotd)))


;;; The metaclass CLASS-WITH-DYNAMIC-SLOTS specifies alternative effective slot
;;; definitions for slots with an initarg :dynamic.
(defclass class-with-dynamic-slots (standard-class) ())

;;; Class with dynamic slots may be subclasses of the standard class.
(defmethod mop:validate-superclass ((class class-with-dynamic-slots)
                                    (super standard-class))
  t)

;;; When allocating the instance we initialize all slots to a fresh symbol that
;;; represents the dynamic variable.
(defmethod allocate-instance ((class class-with-dynamic-slots) &rest initargs)
  (declare (ignore initargs))
  (let ((object (call-next-method)))
    (loop for slotd in (mop:class-slots class)
          when (typep slotd 'dynamic-effective-slot) do
            (setf (mop:standard-instance-access
                   object
                   (mop:slot-definition-location slotd))
                  (make-dynamic-variable)))
    object))

;;; To improve potential composability of CLASS-WITH-DYNAMIC-SLOTS with other
;;; metaclasses we treat specially only slots that has :DYNAMIC in initargs,
;;; otherwise we call the next method.
(defmethod mop:direct-slot-definition-class
    ((class class-with-dynamic-slots) &rest initargs)
  (loop for (key) on initargs by #'cddr
        when (eq key :dynamic)
          do (return-from mop:direct-slot-definition-class
               (find-class 'dynamic-direct-slot)))
  (call-next-method))

;;; The metaobject protocol did not specify an elegant way to communicate
;;; between the direct slot definition and the effective slot definition.
;;; Luckily we have dynamic bindings! :-)
(defvar *kludge/mop-deficiency/dynamic-slot-p* nil)
(defmethod mop:compute-effective-slot-definition
    ((class class-with-dynamic-slots)
     name
     direct-slotds)
  (declare (ignore name))
  (let ((latest-slotd (first direct-slotds)))
    (if (typep latest-slotd 'dynamic-direct-slot)
        (let ((*kludge/mop-deficiency/dynamic-slot-p*
                (dynamic-slot-p latest-slotd)))
          (call-next-method))
        (call-next-method))))

(defmethod mop:effective-slot-definition-class
    ((class class-with-dynamic-slots) &rest initargs)
  (declare (ignore initargs))
  (if *kludge/mop-deficiency/dynamic-slot-p*
      (find-class 'dynamic-effective-slot)
      (call-next-method)))

;;; Accessing and binding symbols behind the slot. We don't use SLOT-VALUE,
;;; because it will return the _value_ of the dynamic variable, and not the
;;; variable itself.
(defun slot-dvar (object slotd)
  (check-type slotd dynamic-effective-slot)
  (mop:standard-instance-access
   object (mop:slot-definition-location slotd)))

(defun slot-dvar* (object slot-name)
  (let* ((class (class-of object))
         (slotd (find slot-name (mop:class-slots class)
                      :key #'mop:slot-definition-name)))
    (slot-dvar object slotd)))

(defmacro slot-dlet (bindings &body body)
  `(dlet ,(loop for ((object slot-name) val) in bindings
                collect `((slot-dvar* ,object ,slot-name) ,val))
     ,@body))


(defclass dynamic-let.test-class ()
  ((slot1 :initarg :slot1 :dynamic nil :accessor slot1)
   (slot2 :initarg :slot2 :dynamic t   :accessor slot2)
   (slot3 :initarg :slot3              :accessor slot3))
  (:metaclass class-with-dynamic-slots))

(defmacro is (&body body) `(assert ,@body))

(defparameter *dynamic-let.test-instance-1*
  (make-instance 'dynamic-let.test-class
                 :slot1 :a :slot2 :b :slot3 :c))

(defun my-test ()
  (let ((o1 *dynamic-let.test-instance-1*)
       (fail nil))
   (is (eq (slot2 o1) :b))
   (flet ((make-runner (values)
            (lambda ()
              (slot-dlet (((o1 'slot2) :start))
                (let ((value (slot2 o1)))
                  (unless (eq value :start)
                    (setf fail value)))
                (loop repeat 1024 do
                  (setf (slot2 o1) (elt values (random (length values))))
                  (let ((value (slot2 o1)))
                    (unless (member value values)
                      (setf fail value))))))))
     (let ((threads (loop for i from 0 below 64
                          for v = (list (make-symbol (format nil "A~d" i))
                                        (make-symbol (format nil "B~d" i))
                                        (make-symbol (format nil "C~d" i)))
                          collect (bt:make-thread (make-runner v)))))
       (map nil #'bt:join-thread threads)
       (is (eq (slot2 o1) :b))
       (is (null fail))))))

Finally

(dotimes (v 64) (my-test))
;; expected NIL

;; observed
Long listing of key-val pairs (from maphash):
...
NIL: (NO-BINDING)
NIL: (NO-BINDING)
#<process Anonymous thread 0x7f57a166b0c0>: (NO-BINDING)
NIL: (NO-BINDING)
#<process repl-thread 0x7f57b44803c0>: (NO-BINDING)
#<process Anonymous thread 0x7f57a9066d80>: (NO-BINDING)
#<process Anonymous thread 0x7f57a166bb40>: (A2 NO-BINDING) <---
#<process Anonymous thread 0x7f57a166bb40>: (NO-BINDING) <---
#<process Anonymous thread 0x7f57a157e6c0>: (NO-BINDING)
NIL: (NO-BINDING)
NIL: (NO-BINDING)
...

Note that we have two entries with the same unique key. That leads to a corruption of "simulated" bindings in this program.

Note that this issue prevails after fixing the recent issue with rw locks (in other words it is independent).