(in-package "DATA-OBJECTS")

(defgeneric get-item (obj &rest lock-args))

(defgeneric put-item (obj item &rest lock-args))

(defgeneric data-available-p (obj))

(defclass basic-data-object ()

())

(defclass basic-FIFO-queue (basic-data-object)

((data :accessor queue-data

:initform nil)))

(defmethod get-item ((queue basic-FIFO-queue) &rest lock-args)

(declare (ignore lock-args))

(pop (queue-data queue)))

(defmethod put-item ((queue basic-FIFO-queue) item &rest lock-args)

(declare (ignore lock-args))

(um:conc1f (queue-data queue) item))

(defmethod data-available-p ((queue basic-FIFO-queue))

(queue-data queue))

(defclass basic-LIFO-stack (basic-FIFO-queue)

((data :accessor stack-data

:initform nil)))

(defmethod put-item ((stack basic-LIFO-stack) item &rest lock-args)

(declare (ignore lock-args))

(push item (stack-data stack)))

(defclass mp-shared-mixin ()

((lock :accessor mp-shared-lock

:initform (mpcompat:make-lock :name "mp-shared-lock"))))

(defmethod lock ((v mp-shared-mixin) &optional whostate timeout)

(mpcompat:process-lock (mp-shared-lock v) whostate timeout))

(defmethod unlock ((v mp-shared-mixin))

(mpcompat:process-unlock (mp-shared-lock v)))

(defmethod with-locked-access (obj fn &optional whostate timeout)

(declare (ignore obj whostate timeout))

(values (funcall fn) t))

(defmethod with-locked-access ((obj mp-shared-mixin) fn

&optional whostate timeout)

(mpcompat:with-spinlock ((mp-shared-lock obj) whostate timeout)

(values (funcall fn) t)))

(defclass mp-shared-data-object

(mp-shared-mixin basic-data-object)

())

(defmethod data-available-p ((obj mp-shared-data-object))

;; return nil if either can't lock the object,

;; or else the object has no data available.

;; This is a polled call - no blocking.

(with-locked-access obj

#'(lambda ()

(call-next-method))

nil 0))

(defmethod get-item ((obj mp-shared-data-object) &rest lockargs)

;; return (values data t) if successful, else nil on timeout

(let ((whostate (first lockargs))

(timeout (second lockargs)))

(prog ()

again

(multiple-value-bind (val locked)

(with-locked-access obj

#'(lambda ()

(if (data-available-p obj)

(list (call-next-method) t)))

whostate timeout)

(if locked

(multiple-value-bind (data avail) (apply 'values val)

(if avail

(return (values data t))

(if (mpcompat:process-wait-with-timeout whostate timeout

'data-available-p obj)

(go again)))))

))))

(defmethod put-item ((obj mp-shared-data-object) item &rest lockargs)

(declare (ignore item))

(let ((whostate (first lockargs))

(timeout (second lockargs)))

(with-locked-access obj

#'(lambda ()

(call-next-method))

whostate timeout)))

(defclass condition-variable ()

((waiting-list :accessor cx-waiting-list :initform nil)))

(defclass mutex (mp-shared-mixin)

())

(defun make-mutex ()

(make-instance 'mutex))

(defun make-condition-variable ()

(make-instance 'condition-variable))

(defmethod cx-empty-p ((cx condition-variable))

(null (cx-waiting-list cx)))

(defmethod cx-wait ((cx condition-variable) (m mutex))

(let ((mb (mpcompat:make-mailbox :size 1 #|:lock-name "cx-lock"|#)))

(um:conc1f (cx-waiting-list cx) mb)

(unlock m)

(let ((ans (mpcompat:mailbox-read mb "waiting for condition signal")))

(lock m)

ans)))

(defmethod cx-signal ((cx condition-variable) &optional val)

(let ((p (pop (cx-waiting-list cx))))

(if p

(mpcompat:mailbox-send p val))

))

(defmethod cx-broadcast ((cx condition-variable) &optional val)

(do ((p (pop (cx-waiting-list cx)) (pop (cx-waiting-list cx))))

((null p))

(mpcompat:mailbox-send p val)))

(defmethod with-condition-var ((cx condition-variable) (m mutex) &key test oper)

(with-locked-access m

#'(lambda ()

(um:until (funcall test)

(cx-wait cx m))

(funcall oper))))

(defclass mp-shared-FIFO-queue (mp-shared-data-object basic-FIFO-queue)

())

(defclass mp-shared-LIFO-stack (mp-shared-data-object basic-LIFO-stack)

())