;;;; srfi-18.barrier.scm  -*-Scheme-*-
;;;; Kon Lovett, May '22

;; Issues
;;
;; - Barrier/Mutex/Condition-Variable Specific?

(declare
  (usual-integrations)
  (disable-interrupts))

(module (srfi-18 barrier)

(;export
  make-barrier
  barrier? check-barrier error-barrier
  barrier-count barrier-limit
  barrier-name
  barrier-specific barrier-specific-set!
  barrier-state
  barrier-wait)

(import scheme utf8)
(import (chicken base))
(import (chicken fixnum))
(import (chicken type))
(import (srfi 18))
(import (only moremacros true false))
(import (only record-variants define-record-type-variant))
(import (only type-checks define-check+error-type check-positive-fixnum))

;;

(define-type real (or integer ratnum float))

(define-type thread (struct thread))
(define-type time (struct time))
(define-type timeout (or real time))

(define-type barrier (struct barrier))

(: make-barrier (fixnum #!optional (or boolean symbol) -> barrier))

(: barrier? (* -> boolean : barrier))
(: check-barrier (symbol * #!rest --> barrier))
(: error-barrier (symbol * #!rest -> void))

(: barrier-name (barrier --> (or false symbol)))
(: barrier-count (barrier -> fixnum))
(: barrier-limit (barrier --> fixnum))

(: barrier-specific (barrier --> *))
(: barrier-specific-set! (barrier * -> void))

(: barrier-state (barrier -> (or thread symbol)))

(: barrier-wait (barrier #!optional timeout -> boolean))

;;;

(define (check-timeout loc obj . rest)
  (unless (or (real? obj) (time? obj))
    (error loc "invalid timeout (not a real or time)" obj))
  obj )

(define barrier 'barrier)
(define-record-type-variant barrier (unsafe unchecked inline)
  (%make-barrier mtx cnd lim cnt nam)
  %barrier?
  (mtx %barrier-mutex)
  (cnd %barrier-condition-variable)
  (lim %barrier-limit)
  (cnt %barrier-count %barrier-count-set!)
  (nam %barrier-name))

;;;

(define (make-barrier lim #!optional nam)
  (let ((nam (and nam (if (boolean? nam) (gensym 'barrier) nam))))
    (%make-barrier
      (make-mutex (and nam (symbol-append nam 'mutex)))
      (make-condition-variable (and nam (symbol-append nam 'condition-variable)))
      (check-positive-fixnum 'make-barrier lim)
      0 nam) ) )

(define (barrier? x) (%barrier? x))

(define-check+error-type barrier)

(define (barrier-name bar) (barrier-name (check-barrier 'barrier-name bar)))
(define (barrier-limit bar) (%barrier-limit (check-barrier 'barrier-limit bar)))
(define (barrier-count bar) (%barrier-count (check-barrier 'barrier-count bar)))

(define (barrier-specific-get bar)
  (check-barrier 'barrier-specific bar)
  ;(mutex-specific (%barrier-mutex bar))
  (condition-variable-specific (%barrier-condition-variable bar)) )

(define (barrier-specific-set! bar obj)
  (check-barrier 'barrier-specific-set! bar)
  ;(mutex-specific-set! (%barrier-mutex bar) obj)
  (condition-variable-specific-set! (%barrier-condition-variable bar) obj) )

(define barrier-specific (getter-with-setter barrier-specific-get barrier-specific-set!))

(define (barrier-state bar)
  (mutex-state (%barrier-mutex (check-barrier 'barrier-count bar))) )

(define (barrier-wait bar #!optional timout)
  (and timout (check-timeout 'barrier-wait timout))
  (check-barrier 'barrier-wait bar)
  (let ((mtx (%barrier-mutex bar))
        (cnd (%barrier-condition-variable bar)) )
    (mutex-lock! mtx)
    (let ((cnt (fx+ (%barrier-count bar) 1)))
      (if (fx>= cnt (%barrier-limit bar))
          (true
            (%barrier-count-set! bar 0)
            (condition-variable-broadcast! cnd)
            (mutex-unlock! mtx))
          (false
            (%barrier-count-set! bar cnt)
            (mutex-unlock! mtx cnd timout)) ) ) ) )

) ;(srfi-18 barrier)