;;;; synch-exn-test.scm  -*- Scheme -*-
;;;; Kon Lovett, Dec '18

(import utf8)
(import test)
(import (only (chicken format) format))
(include "test-gloss.incl")

(test-begin "Synch Exn")

;;;

(import synch-exn synch-params (srfi 18))

;;

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

;;;

(test-group "synch exit"

  (import (chicken condition))

  (define mx (make-mutex 'mx))

  #;
  (let ((exit-k (call/cc (lambda (k) k))) )
    (define-thread mx-exn-th
      (synch mx
        (when exit-k
          (test-assert "exit k" exit-k)
          (exit-k #f))))
    (thread-start! mx-exn-th) )
  (thread-start!
    (lambda ()
      (call/cc (lambda (ret)
        (synch mx
          (ret 'ca))))))

  (test "unlocked" 'not-abandoned (mutex-state mx))

  (test-assert "reuse mutex" (synch mx #t))

)

;;;

(test-group "synch exception"

  (import (chicken condition))

  (define mx (make-mutex 'mx))

  (define-thread mx-exn-th
    (parameterize (
      (current-synch-raise
        (lambda (exn)
          (test "exn" 'ca1 ((lambda () exn))))) )
      (synch mx (abort 'ca1))))
  (thread-start! mx-exn-th)

  (test "unlocked" 'not-abandoned (mutex-state mx))

  (test-assert "reuse mutex" (synch mx #t))

)

;;;

(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-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"

;;

(import (chicken fixnum) (srfi 69))

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

  (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 +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)
      #; ;FIXME hangs
      (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))
      #; ;FIXME loops
      (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 Exn")

(test-exit)