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

(import test)

(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-begin "synch exit")

(import (chicken condition))

(define mx1 (make-mutex 'mx1))

(thread-start!
  (lambda ()
    (call/cc (lambda (ret)
      (synch mx1
        (ret 'ca))))))

(cond-expand
  (compiling
    (test "compiled is unlocked" 'not-abandoned (mutex-state mx1)) )
  (else
    (test "eval'ed is locked" 'abandoned (mutex-state mx1)) ) )

(cond-expand
  (compiling
    (test-assert "compiled can reuse mutex" (synch mx1 #t)) )
  (else
    (test-error "eval'ed cannot reuse mutex" (synch mx1 #t)) ) )

(test-end "synch exit")

;;;

(test-begin "synch exception")

(import (chicken condition))

(define mx2 (make-mutex 'mx2))

(define-thread mx2-exn-th
  (parameterize (
    (current-synch-raise
      (lambda (exn)
        (test "exn" 'ca1 ((lambda () exn))))) )
    (synch mx2 (abort 'ca1))))
(thread-start! mx2-exn-th)
(test "unlocked" 'not-abandoned (mutex-state mx2))

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

(test-end "synch exception")

;;;

(test-begin "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)))) )

(test-end "record synch")

;;; Synchronize thread access to an object

(test-begin "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?))

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

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

;; Greedy Reader

(define-thread reader-thread
  (do ((n (hash-table-count-synch +tht+) (hash-table-count-synch +tht+)))
      ((fx= READER-THREAD-LIMIT n) (print "limit reached"))
    (print "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 "hash-table synch")

;;;

(test-end "Synch Exn")

(test-exit)