;; SPDX-License-Identifier: EUPL-1.2
;; SPDX-FileCopyrightText: 2025 Uko Kokņevičs <perkontevs@gmail.com>
(defpackage :ukkoclot/src/rw-lock
  (:documentation "Implementation of a shared/read-write lock.")
  (:use :c2cl :bt2 :iterate)
  (:import-from :alexandria :with-gensyms)
  (:import-from :com.dieggsy.f-string :enable-f-strings)
  (:import-from :sb-sys
   :allow-with-interrupts :with-local-interrupts :without-interrupts)
  (:export
   #:rw-lock
   #:rw-lock-p
   #:make-rw-lock
   #:acquire-read-lock
   #:release-read-lock
   #:with-read-lock
   #:acquire-write-lock
   #:release-write-lock
   #:with-write-lock))
(in-package :ukkoclot/src/rw-lock)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (enable-f-strings))

;; TODO: Get rid of broadcasting for writers, instead have separate condvars
;; TODO: Make it a bit more fair, 50% chance of waking up writers or readers
;; TODO: Use atomic-integer in best-case for read locks to decrease contention
(defstruct (rw-lock (:constructor make-rw-lock%))
  (lock nil :type lock :read-only t)
  (unlocked nil :type condition-variable :read-only t)
  (readers 0 :type integer)
  (has-writer nil :type boolean))

(defvar *counter-lock* (make-lock :name "rw-lock::*counter-lock*"))

(defvar *counter* 0)

(defun gen-name ()
  (format nil "Read-Write Lock ~A"
          (with-lock-held (*counter-lock*)
            (incf *counter*))))

(defun make-rw-lock (&key (name (gen-name)))
  (check-type name string)
  (make-rw-lock%
   :lock (make-lock :name #f"{name}'s internal lock")
   :unlocked (make-condition-variable :name #f"{name}'s internal unlocked")))

(defun acquire-read-lock (rw-lock &key (wait t))
  ;; TODO: timeout
  (check-type rw-lock rw-lock)
  (with-slots (lock unlocked readers has-writer) rw-lock
    (let ((lock-acquired))
      (without-interrupts
        (unwind-protect
             (when (setf lock-acquired
                         (allow-with-interrupts
                          (acquire-lock lock :wait wait)))
               (with-local-interrupts
                 (when (if wait
                           (iter
                             (unless has-writer
                               (return t))
                             (condition-wait unlocked lock))
                           (not has-writer))
                   (incf readers)
                   t)))
          (when lock-acquired
            (release-lock lock)))))))

(defun release-read-lock (rw-lock)
  (check-type rw-lock rw-lock)
  (with-slots (lock unlocked readers has-writer) rw-lock
    (with-lock-held (lock)
      (assert (> readers 0) nil "Trying to release a read lock that's not taken!")
      (decf readers)
      (when (zerop readers)
        (condition-broadcast unlocked))))
  rw-lock)

(defmacro with-read-lock ((rw-lock) &body body)
  ;; TODO: timeout
  (with-gensyms (lock-acquired lock-value)
    `(let ((,lock-acquired)
           (,lock-value ,rw-lock))
       (without-interrupts
         (unwind-protect
              (when (setf ,lock-acquired
                          (allow-with-interrupts
                           (acquire-read-lock ,lock-value)))
                (with-local-interrupts ,@body))
           (when ,lock-acquired
             (release-read-lock ,lock-value)))))))

(defun acquire-write-lock (rw-lock &key (wait t))
  ;; TODO: timeout
  (check-type rw-lock rw-lock)
  (with-slots (lock unlocked readers has-writer) rw-lock
    (let ((lock-acquired))
      (without-interrupts
        (unwind-protect
             (when (setf lock-acquired
                         (allow-with-interrupts
                           (acquire-lock lock :wait wait)))
               (with-local-interrupts
                 (when (if wait
                           (iter
                             (unless (or (> readers 0) has-writer)
                               (return t))
                             (condition-wait unlocked lock))
                           (and (zerop readers) (not has-writer)))
                   (setf has-writer t)
                   t)))
          (when lock-acquired
            (release-lock lock)))))))

(defun release-write-lock (rw-lock)
  (check-type rw-lock rw-lock)
  (with-slots (lock unlocked readers has-writer) rw-lock
    (with-lock-held (lock)
      (assert has-writer nil "Trying to release a write lock that's not taken!")
      (setf has-writer nil)
      (condition-broadcast unlocked)))
  rw-lock)

(defmacro with-write-lock ((rw-lock) &body body)
  ;; TODO: timeout
  (with-gensyms (lock-acquired lock-value)
    `(let ((,lock-acquired)
           (,lock-value ,rw-lock))
       (without-interrupts
         (unwind-protect
              (when (setf ,lock-acquired
                          (allow-with-interrupts
                            (acquire-write-lock ,lock-value)))
                (with-local-interrupts ,@body))
           (when ,lock-acquired
             (release-write-lock ,lock-value)))))))