;;;; 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)
(import (chicken base))
(import (chicken fixnum))
(import (chicken type))
(import (srfi 18))
(import (only moremacros true false false?))
(import (only record-variants define-record-type-variant))
(import (only type-checks-basic define-check+error-type))
(import (only (check-errors sys) check-fixnum-in-range))

(define (check-positive-fixnum loc obj)
  (import (only (chicken fixnum) most-positive-fixnum))
  (check-fixnum-in-range loc obj 1 most-positive-fixnum) )

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

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

(define-type barrier (struct barrier))

(: make-barrier (#!optional fixnum * -> barrier))

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

(: barrier-name (barrier --> *))
(: 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 (false? obj) (real? obj) (time? obj))
    (error loc "invalid timeout (not false, real or time)" obj))
  obj )

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

;;;

(define (make-barrier #!optional (lim 1) nam)
  (%make-barrier
    (make-mutex nam)
    (make-condition-variable nam)
    (check-positive-fixnum 'make-barrier lim)
    0) )

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

(define-check+error-type barrier)

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

(define (barrier-name bar)
  (mutex-name (%barrier-mutex (check-barrier 'barrier-name 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)
  ;must be initial, not time-of-use
  (and timout (check-timeout 'barrier-wait timout)) ;skip test when #f
  (check-barrier 'barrier-wait bar)
  ;"safe"
  (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)