;;;; synch-open-test.scm  -*- Scheme -*-
;;;; Kon Lovett, Nov '21

(import
  scheme
  (chicken base)
  test
  (only (chicken format) format) (test-utils gloss))
(import
  (chicken fixnum)
  (chicken condition)
  (srfi 18)
  (srfi 69)
  synch-params
  synch-open)

(define (check-structure loc obj tag)
  (##sys#check-structure obj tag loc)
  obj )

(define (check-hash-table loc obj)
  (check-structure loc obj 'hash-table) )

(define-syntax define-thread
	(syntax-rules ()
	  ((define-thread ?ident ?body ...)
	    (define ?ident (make-thread (lambda () ?body ...) '?ident) ) ) ) )

;;;

(test-begin "Synch Open")

;;

(test-group "synch early exit"
  (test-group "(top)"
    (define mx (make-mutex 'mx))
    (define (mx-exn)
      (call/cc (lambda (ret)
        (%synch mx
          (ret 'ca)))) )

    (define mx-exn-th (thread-start! mx-exn))

    (test "unlocked" 'not-abandoned (mutex-state mx))
    (test-assert "reuse mutex" (%synch mx #t))

    (thread-join! mx-exn-th)
  )

  (test-group "(thread+cc)"
    (define mx (make-mutex 'mx))
    (define done 0)

    ;! cc is <...> in (set! exit-k <...>) !
    (define exit-k (call/cc (lambda (k) k)))
    (define-thread mx-exn-th-cc
      (%synch mx
        (when exit-k
          (exit-k #f))) )

    (thread-start! mx-exn-th-cc)

    (cond (exit-k
            (test "unlocked (top)" 'not-abandoned (mutex-state mx)) )
          (else
            #; ;FAIL #<thread mx-exn-th-cc> != #<thread mx-exn-th-cc>
            (test "in-use by thread (thr)" mx-exn-th-cc (mutex-state mx))
            (test "in-use by thread (thr)" 'mx-exn-th-cc (thread-name (mutex-state mx))) ) )
    (set! done (fx+ done 1))

    ;w/o then deadlock
    (when (fx= 2 done)
      (thread-join! mx-exn-th-cc)
      ;not until end
      (test-assert "reuse mutex" (synch mx #t)) )
  )

  (test-group "(thread+exn)"
    (define mx (make-mutex 'mx))

    (define-thread mx-exn-th-exn
      (handle-exceptions exn
        (begin exn)
        (parameterize ((current-synch-raise (lambda (exn)
                                              (test "exn" 'ca1 ((lambda () exn))))))
          (%synch mx (abort 'ca1))) ) )

    (thread-start! mx-exn-th-exn)

    (test "unlocked" 'not-abandoned (mutex-state mx))
    (test-assert "reuse mutex" (%synch mx #t))

    (thread-join! mx-exn-th-exn)
  )
)

;;

(test-group "multi-valued"
  (define mx (make-mutex 'mx))

  (test '(1 2 3) (receive (%synch mx (values 1 2 3))))
)

;;

(test-group "record synch"
  (define-record-type <foo>
    (make-<foo> x y mtx)
    <foo>?
    (x <foo>-x)
    (y <foo>-y)
    (mtx <foo>-mutex))

  (let ((tfoo (make-<foo> 1 2 (make-mutex))))
    (test "record-synch" '(1 2)
      (%record-synch tfoo <foo> (list (<foo>-x tfoo) (<foo>-y tfoo)))) )
)

;; Synchronize thread access to an object

(define (hash-table-count ht)
  (hash-table-fold
    (check-hash-table 'hash-table-count ht)
    (lambda (k v a) (fx+ a 1))
    0) )

(define-constructor-%synch make-hash-table)
(define-predicate-%synch hash-table?)
(define-operation-%synch hash-table-count)
(define-operation-%synch hash-table-set!)

(define-constant WRITER-THREAD-LIMIT 10)
(define-constant READER-THREAD-LIMIT (* 2 WRITER-THREAD-LIMIT))

(define-constant THREAD-SLEEP-MS 100)
(define-constant READ-FACTOR 0)
(define-constant WRITE-FACTOR 0)

(test-group "hash-table synch"
  (define +tht+ (make-hash-table-%synch eq?))

  ;; Greedy Reader

  (define-thread reader-thread
    (do ((n (hash-table-count-%synch +tht+) (hash-table-count-%synch +tht+)))
        ((fx= READER-THREAD-LIMIT n) (gloss "limit reached"))
      (gloss "hash-table count = " n)
      ;NOTE deadlock everywhere but not here
      (thread-sleep! (* READ-FACTOR THREAD-SLEEP-MS))
      (thread-yield!) ) )

  ;; Cooperative Writer

  (define-thread writer-thread
    (do ((i WRITER-THREAD-LIMIT (fx- i 1)))
        ((fx= i 0))
      (hash-table-set!-%synch +tht+ i (number->string i))
      (hash-table-set!-%synch +tht+ (fx+ i 10) (number->string i))
      ;NOTE deadlock everywhere but not here
      (thread-sleep! (* WRITE-FACTOR THREAD-SLEEP-MS))
      (thread-yield!) ) )

  (thread-start! writer-thread)
  (thread-start! reader-thread)

  (thread-join! writer-thread)
  (thread-join! reader-thread)
)

;;;

(test-end "Synch Open")

(test-exit)