(load-relative "loadtest.ss")

(Section 'synchronization)

(define SYNC-SLEEP-DELAY 0.025)
(define SYNC-BUSY-DELAY 0.1) ; go a little slower to check busy waits

;; ----------------------------------------
;;  Semaphore peeks

(let* ([s (make-semaphore)]
       [p (semaphore-peek-evt s)]
       [ch (make-channel)])
  (test #f sync/timeout 0 s p)
  (test #f sync/timeout 0 s p)
  (semaphore-post s)
  (test p sync/timeout 0 p)
  (test p sync p)
  (test s sync s)
  (test #f sync/timeout 0 p)
  (thread (lambda () (sync (system-idle-evt)) (semaphore-post s)))
  (test p sync p)
  (test p sync p)
  (test s sync s)
  (test #f sync/timeout 0 p)
  (thread (lambda () (sync/timeout 0 p) (channel-put ch 7)))
  (thread (lambda () (sync/timeout 0 p) (channel-put ch 7)))
  (thread (lambda () (sync/timeout 0 p) (channel-put ch 7)))
  (semaphore-post s)
  (test 7 channel-get ch)
  (test 7 channel-get ch)
  (test 7 channel-get ch)
  (test #f channel-try-get ch)
  (thread (lambda () (channel-put ch 9)))
  (sync (system-idle-evt))
  (test 9 channel-try-get ch)
  (test #f channel-try-get ch))

(arity-test semaphore-peek-evt 1 1)
(err/rt-test (semaphore-peek-evt #f))
(err/rt-test (semaphore-peek-evt (semaphore-peek-evt (make-semaphore))))

;; ----------------------------------------
;; Channels

(arity-test make-channel 0 0)

(let ([c (make-channel)]
      [v 'nope])
  (test #f sync/timeout 0 c)
  (thread (lambda () (sync (system-idle-evt)) (set! v (channel-get c))))
  (test (void) channel-put c 10)
  (sync (system-idle-evt))
  (test 10 'thread-v v)
  (thread (lambda () (sync (system-idle-evt)) (channel-put c 11)))
  (test #f sync/timeout 0 c)
  (test 11 sync c)
  (let ([p (channel-put-evt c 45)])
    (thread (lambda () (sync (system-idle-evt)) (set! v (sync c))))
    (test #f sync/timeout 0 p)
    (test p sync p)
    (test #f sync/timeout 0 p)
    (sync (system-idle-evt))
    (test 45 'thread-v v))
  ;;;;; Make sure break/kill before action => break/kill only
  ;; get:
  (let ([try (lambda (break-thread)
	       (let ([t (thread (lambda ()
				  (set! v (channel-get c))))])
		 (test #t thread-running? t)
		 (sync (system-idle-evt))
		 (test #t thread-running? t)
		 (test (void) break-thread t)
		 (test #f sync/timeout 0 (channel-put-evt c 32))
                 (sync (system-idle-evt))
		 (test #f thread-running? t)
		 (test 45 'old-v v)))])
    (try break-thread)
    (try kill-thread))
  ;; put:
  (let ([try (lambda (break-thread)
	       (let ([t (thread (lambda () (channel-put c 17)))])
		 (test #t thread-running? t)
		 (sync (system-idle-evt))
		 (test #t thread-running? t)
		 (test (void) break-thread t)
		 (test #f sync/timeout 0 c)
		 (sync (system-idle-evt))
		 (test #f thread-running? t)))])
    (try break-thread)
    (try kill-thread))
  ;; put in main thread:
  (let ([t (current-thread)])
    (thread (lambda () 
	      (sync (system-idle-evt))
	      (break-thread t) 
	      (set! v (channel-get c)))))
  (test 77
	'broken
	(with-handlers ([exn:break? (lambda (x) 77)])
	  (sync (channel-put-evt c 32))))
  (test 45 'old-v v)
  (channel-put c 89)
  (sleep)
  (test 89 'new-v v)
  ;; get in main thread:
  (let ([t (current-thread)])
    (thread (lambda () 
	      (sync (system-idle-evt))
	      (break-thread t) 
	      (channel-put c 66))))
  (test 99
	'broken
	(with-handlers ([exn:break? (lambda (x) 99)])
	  (sync c)))
  (test 66 sync/timeout 0 c)

  ;;; Can't sync with self!
  (test #f sync/timeout 0 c (channel-put-evt c 100))
  ;; Test cross sync:
  (let ([c2 (make-channel)]
	[ok-result? (lambda (r)
		      (or (eq? r 100) (evt? r)))])
    (thread (lambda () (channel-put c2 (sync c (channel-put-evt c 100)))))
    (thread (lambda () (channel-put c2 (sync c (channel-put-evt c 100)))))
    (test #t ok-result? (channel-get c2))
    (test #t ok-result? (channel-get c2))))

;; ----------------------------------------
;; Alarms

(test #f sync/timeout 0.1 (alarm-evt (+ (current-inexact-milliseconds) 200)))
(test 'ok sync/timeout 0.1 
      (wrap-evt
       (alarm-evt (+ (current-inexact-milliseconds) 50))
       (lambda (x) 'ok)))
(test 'ok sync/timeout 100
      (wrap-evt
       (alarm-evt (+ (current-inexact-milliseconds) 50))
       (lambda (x) 'ok)))

;; ----------------------------------------
;; Waitable sets

(err/rt-test (choice-evt 7))
(err/rt-test (choice-evt (make-semaphore) 7))

(arity-test choice-evt 0 -1)

(test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt))
(test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt) (choice-evt))
(test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt (choice-evt) (choice-evt)))

(let ([s1 (make-semaphore)]
      [s2 (make-semaphore)]
      [s3 (make-semaphore)])
  (test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 s2 s3))
  (semaphore-post s2)
  (test s2 sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 s2 s3))
  (test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 s2 s3))
  (let ([set (choice-evt s1 s2 s3)])
    (test #f sync/timeout SYNC-SLEEP-DELAY set)
    (semaphore-post s2)
    (test s2 sync/timeout SYNC-SLEEP-DELAY set)
    (test #f sync/timeout SYNC-SLEEP-DELAY set))
  (thread (lambda () (sleep) (semaphore-post s3)))
  (test s3 sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 s2 s3))
  (test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 s2 s3))
  (semaphore-post s3)
  (test s3 sync/timeout SYNC-SLEEP-DELAY s1 (choice-evt s2 s3))
  (test #f sync/timeout SYNC-SLEEP-DELAY s1 (choice-evt s2 s3))
  (semaphore-post s3)
  (test s3 sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 s2) s3)
  (test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 s2) s3)
  (let ([set (choice-evt s1 s2)])
    (test #f sync/timeout SYNC-SLEEP-DELAY s1 set s3)
    (semaphore-post s2)
    (test s2 sync/timeout SYNC-SLEEP-DELAY set s3)
    (test #f sync/timeout SYNC-SLEEP-DELAY set s3))
  (test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 (choice-evt s2 s3)))
  (semaphore-post s3)
  (test s3 sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 (choice-evt s2 s3)))
  (test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt s1 (choice-evt s2 s3)))
  (semaphore-post s3)
  (test s3 sync/timeout SYNC-SLEEP-DELAY (choice-evt (choice-evt s1 s2) s3))
  (test #f sync/timeout SYNC-SLEEP-DELAY (choice-evt (choice-evt s1 s2) s3))
  (let ([set (choice-evt s1 (choice-evt s2 s3))])
    (test #f sync/timeout SYNC-SLEEP-DELAY set)
    (semaphore-post s3)
    (test s3 sync/timeout SYNC-SLEEP-DELAY set)
    (test #f sync/timeout SYNC-SLEEP-DELAY set))
  
  (let* ([c (make-channel)]
	 [set (choice-evt s1 s2 c)])
    (test #f sync/timeout SYNC-SLEEP-DELAY set)
    (thread (lambda () (channel-put c 12)))
    (test 12 sync/timeout SYNC-SLEEP-DELAY set)
    (test #f sync/timeout SYNC-SLEEP-DELAY set)
    (let* ([p (channel-put-evt c 85)]
	   [set (choice-evt s1 s2 p)])
      (test #f sync/timeout SYNC-SLEEP-DELAY set)
      (thread (lambda () (channel-get c)))
      (test p sync/timeout SYNC-SLEEP-DELAY set)
      (test #f sync/timeout SYNC-SLEEP-DELAY set))))

(test 77 sync/timeout 
      #f 
      (wrap-evt (make-semaphore) void) 
      (guard-evt 
       (lambda () 
	 (choice-evt 
	  (make-semaphore) (make-semaphore) (make-semaphore) (make-semaphore) 
	  (make-semaphore) (make-semaphore) (make-semaphore) (make-semaphore) 
	  (let ([sema (make-semaphore 1)])
	    (wrap-evt sema (lambda (x)
                             (test sema values x)
                             77)))))))

;; More alarms:
(let ([make-delay
       (lambda (amt)
	 (guard-evt
	  (lambda ()
	    (wrap-evt
	     (alarm-evt (+ (current-inexact-milliseconds) (* 1000 amt)))
	     (lambda (v) amt)))))])
  (test #f sync/timeout 0.1 (make-delay 0.15) (make-delay 0.2))
  (test 0.15 sync/timeout 18 (make-delay 0.15) (make-delay 0.2))
  (test 0.15 sync/timeout 18 (make-delay 0.2) (make-delay 0.15))
  (test 0.15 sync/timeout 0.18 (make-delay 0.15) (make-delay 0.2))
  (test 0.15 sync/timeout 18 
	(choice-evt (make-delay 0.2) (make-delay 0.15))))

;; ----------------------------------------
;; Wrapped waitables

(arity-test wrap-evt 2 2)

(err/rt-test (wrap-evt 1 void))
(err/rt-test (wrap-evt (make-semaphore) 10))
(err/rt-test (wrap-evt (make-semaphore) (lambda () 10)))

(test 17 sync (wrap-evt (make-semaphore 1) (lambda (sema) 17)))
(test 17 sync (choice-evt
				  (make-semaphore)
				  (wrap-evt (make-semaphore 1) (lambda (sema) 17))))
(test #t sync (wrap-evt (make-semaphore 1) semaphore?))
(test 18 'sync
      (let ([n 17]
	    [s (make-semaphore)])
	(thread (lambda () (sync (system-idle-evt)) (semaphore-post s)))
	(sync 
         (wrap-evt 
          s 
          (lambda (sema) (set! n (add1 n)) n))
         (wrap-evt 
          s 
          (lambda (sema) (set! n (add1 n)) n)))))

(let ([c (make-channel)])
  (thread (lambda () (channel-put c 76)))
  (test 77 sync (wrap-evt c add1)))

(test 78 sync 
      (wrap-evt (choice-evt (make-semaphore 1) (make-semaphore 1))
			     (lambda (x) 78)))

;; ----------------------------------------
;; Nack waitables

(arity-test nack-guard-evt 1 1)
(arity-test guard-evt 1 1)

(err/rt-test (nack-guard-evt 10))
(err/rt-test (nack-guard-evt (lambda () 10)))
(err/rt-test (guard-evt 10))
(err/rt-test (guard-evt (lambda (x) 10)))

(let ([s (make-semaphore 1)]
      [nack-try-wait? (lambda (n)
                        (unless (evt? n)
                          (error "NACK isn't ready for try-wait"))
			(let ([v (sync/timeout 0 n)])
			  (when v
			    (test #t void? v)
			    (test (void) sync n))
			  (and v #t)))])
  (test s sync (nack-guard-evt (lambda (nack) s)))
  (test #f semaphore-try-wait? s)
  (semaphore-post s)
  (let ([v #f])
    (test #f sync/timeout 0
	  (nack-guard-evt (lambda (nack) 
                            (set! v nack)
                            (make-semaphore))))
    (test #t nack-try-wait? v)
    (set! v #f)
    (test #f sync/timeout SYNC-SLEEP-DELAY
	  (nack-guard-evt (lambda (nack) 
                            (set! v nack)
                            (make-semaphore))))
    (test #t nack-try-wait? v)
    (set! v #f)
    (test #f sync/timeout 0
	  (nack-guard-evt (lambda (nack) 
                            (set! v nack)
                            (make-semaphore)))
	  (nack-guard-evt (lambda (nack) 
                            (set! v nack)
                            (make-semaphore))))
    (test #t nack-try-wait? v)
    (set! v #f)
    (test #f sync/timeout SYNC-SLEEP-DELAY
	  (nack-guard-evt (lambda (nack) 
                            (set! v nack)
                            (make-semaphore)))
	  (nack-guard-evt (lambda (nack) 
                            (set! v nack)
                            (make-semaphore))))
    (test #t nack-try-wait? v)
    (set! v #f)
    (test #f sync/timeout SYNC-SLEEP-DELAY
	  (choice-evt 
	   (nack-guard-evt (lambda (nack) 
                             (set! v nack)
                             (make-semaphore)))
	   (nack-guard-evt (lambda (nack) 
                             (set! v nack)
                             (make-semaphore)))))
    (test #t nack-try-wait? v)
    (set! v #f)
    (test s sync/timeout 0
	  (nack-guard-evt (lambda (nack) 
                            (set! v nack)
                            s)))
    (test #f nack-try-wait? v) ; ... but not an exception!
    (semaphore-post s)
    (set! v #f)
    (let loop ()
      (test s sync/timeout 0
	    (nack-guard-evt (lambda (nack) 
                              (set! v nack)
                              (make-semaphore)))
	    s)
      (if v
	  (test #t nack-try-wait? v)
	  (begin  ; tried the 2nd first, so do test again
	    (semaphore-post s)
	    (loop))))
    (set! v #f)
    (let loop ()
      (err/rt-test (sync/timeout 0
				 (nack-guard-evt (lambda (nack) 
						   (set! v nack)
						   (make-semaphore)))
				 (nack-guard-evt (lambda (nack)
						   (/ 1 0))))
		   exn:fail:contract:divide-by-zero?)
      (if v
	  (test #t nack-try-wait? v)
	  (loop)))
    (set! v #f)
    (let loop ()
      (err/rt-test (sync/timeout 0
				 (nack-guard-evt (lambda (nack)
						   (/ 10 0)))
				 (nack-guard-evt (lambda (nack) 
						   (set! v nack)
						   (make-semaphore))))
		   exn:fail:contract:divide-by-zero?)
      (if v
	  (begin
	    (set! v #f)
	    (loop))
	  (test #t not v)))
    (set! v null)
    (test #f sync/timeout 0
	  (nack-guard-evt (lambda (nack) 
			    (set! v (cons nack v))
			    (make-semaphore)))
	  (nack-guard-evt (lambda (nack) 
			    (set! v (cons nack v))
			    (make-semaphore))))
    (test '(#t #t) map nack-try-wait? v)

    ;; Check that thread kill also implies nack:
    (set! v #f)
    (let* ([ready (make-semaphore)]
	   [t (thread (lambda ()
			(sync/timeout 
			 #f
			 (nack-guard-evt
			  (lambda (nack)
			    (set! v nack)
			    (semaphore-post ready)
			    (make-semaphore))))))])
      (semaphore-wait ready)
      (kill-thread t)
      (test #t nack-try-wait? v))))
		       

(let ([s (make-semaphore 1)])
  (test s sync/timeout 0 (guard-evt (lambda () s))))

(let ([v #f])
  (test #f sync/timeout 0
	(nack-guard-evt
	 (lambda (nack)
	   (set! v nack)
	   (choice-evt (make-semaphore) (make-semaphore)))))
  (unless (evt? v) (error "the NACK isn't ready!"))
  (test (void) sync/timeout 0 v))

(let ([ch (make-channel)]
      [n #f])
  (let ([t (thread
	    (lambda ()
	      (sync
	       (nack-guard-evt
		(lambda (nack)
		  (set! n nack)
		  never-evt))
	       (channel-put-evt ch 10))))])
    (sync (system-idle-evt))
    (test 10 channel-get ch)
    (test (void) sync/timeout 0 n)))
	       

;; ----------------------------------------
;; Poll waitables

(arity-test poll-guard-evt 1 1)

(err/rt-test (poll-guard-evt 10))
(err/rt-test (poll-guard-evt (lambda () 10)))

(let ([s (semaphore-peek-evt (make-semaphore 1))])
  (test s sync/timeout 0 (poll-guard-evt (lambda (poll?)
                                           (test #t values poll?)
                                           s)))
  (test s sync (poll-guard-evt (lambda (poll?)
                                 (test #f values poll?)
                                 s)))
  (test s sync/timeout 0 (choice-evt
                          (poll-guard-evt (lambda (poll?)
                                            (test #t values poll?)
                                            s))
                          (make-semaphore)))
  (test s sync (choice-evt
                (poll-guard-evt (lambda (poll?)
                                  (test #f values poll?)
                                  s))
                (make-semaphore))))

;; ----------------------------------------
;; Structures as waitables

;; Bad property value:
(err/rt-test (make-struct-type 'wt #f 2 0 #f (list (cons prop:evt -1))) exn:application:mismatch?)
;; slot index 1 not immutable:
(err/rt-test (make-struct-type 'wt #f 2 0 #f (list (cons prop:evt 1))) exn:application:mismatch?)

(define-values (struct:wt make-wt wt? wt-ref wt-set!)
  (make-struct-type 'wt #f 2 0 #f (list (cons prop:evt 1)) (make-inspector) #f '(1)))

(define-values (struct:wt2 make-wt2 wt2? wt2-ref wt2-set!)
  (make-struct-type 'wt2 #f 2 0 #f (list (cons prop:evt 1))
                    (make-inspector) 0 '(1)))

(let ([test-wt
       (lambda (make-wt)
         (let ([always-ready (make-wt (lambda () 10) (lambda (self) #t))]
               [always-stuck (make-wt 1 2)])
           (test always-ready sync always-ready)
           (test always-ready sync/timeout 0 always-ready)
           (test #f sync/timeout 0 always-stuck)
           (test #f sync/timeout SYNC-SLEEP-DELAY always-stuck)))])
  (test-wt make-wt)
  (test-wt make-wt2))

;; Check whether something that takes at least SYNC-SLEEP-DELAY
;;  seconds in fact takes roughly that much CPU time. We
;;  expect non-busy-wait takes to take a very small fraction
;;  of the time.
;; This test only works well if there are no other
;;  threads running and the underlying OS is not loaded.
(define (check-busy-wait go busy?)
  (collect-garbage) ; reduces false-positives in detecting busy wait
  (let ([msecs (current-process-milliseconds)]
	[gc-msecs (current-gc-milliseconds)]
	[real-msecs (current-milliseconds)])
    (go)
    (let ([took (/ (abs (- (current-process-milliseconds) msecs
			   (abs (- (current-gc-milliseconds) gc-msecs))))
		   1000.0)]
	  [real-took (/ (abs (- (current-milliseconds) real-msecs)) 1000.0)]
	  [boundary (/ SYNC-BUSY-DELAY 6)])
      ;; Hack.
      ;; The following test isn't reliable, so only Matthew should see it,
      ;; and only in non-parallel mode:
      (when (and (regexp-match #rx"(mflatt)|(matthewf)" (path->string (find-system-path 'home-dir)))
                 (equal? "" Section-prefix))
	(test busy? (lambda (a ax b c d) (> b c)) 'busy-wait? go took boundary real-took)))))

(define (test-good-waitable wrap-sema make-wt)
  (let ([sema (make-semaphore)])
    (letrec-values ([(sema-ready-part get-sema-result) (wrap-sema sema sema (lambda () sema-ready))]
		    [(sema-ready) (make-wt 1 sema-ready-part)])
      (test #f 'initial-sema (sync/timeout 0 sema-ready))
      (semaphore-post sema)
      (test (get-sema-result) sync/timeout 0 sema-ready)
      (test #f semaphore-try-wait? sema)
      (test #f sync/timeout 0 sema-ready)
      (semaphore-post sema)
      (let ()
	(define (non-busy-wait waitable get-result)
          (begin
            (thread (lambda ()
                      (sync (system-idle-evt))
                      (semaphore-post sema)))
            (test (get-result) sync waitable))
	  (test #f sync/timeout 0 waitable)
	  (semaphore-post sema)
	  (test (get-result) sync waitable)
	  (test #f sync/timeout 0 waitable)
	  (semaphore-post sema)
	  (test (get-result) sync waitable)
	  (test #f semaphore-try-wait? sema)
	  (test #f sync/timeout 0 waitable))
	(non-busy-wait sema-ready get-sema-result)
	(semaphore-post sema)
	(letrec-values ([(wrapped-part get-wrapped-result)
			 (wrap-sema (make-wt 2 (lambda (self) sema-ready))
				    (get-sema-result)
				    (lambda () sema-ready))]
			[(wrapped) (make-wt 3 wrapped-part)])
	  (non-busy-wait (get-wrapped-result) get-wrapped-result))))))

(map
 (lambda (make-wt)
   (test-good-waitable (lambda (x x-result get-self)
                         (values x (lambda () x-result)))
                       make-wt)
   (test-good-waitable (lambda (x x-result get-self)
                         (let ([ws (choice-evt
                                    x
                                    (make-wt 99 (lambda (self) (make-semaphore))))])
                           (values ws (lambda () x-result))))
                       make-wt))
 (list make-wt make-wt2))

(check-busy-wait
 (letrec ([s (make-semaphore)]
	  [wt (make-wt 1 (lambda (self) (unless (or (eq? wt s)
						    (eq? self wt) )
					  (error 'wt "yikes: ~s != ~s" self wt)) 
				 wt))])
   (thread (lambda () (sleep (/ SYNC-BUSY-DELAY 2)) (set! wt s)))
   (lambda ()
     (test #f sync/timeout SYNC-BUSY-DELAY wt)))
 #t)

;; ----------------------------------------

(define (test-stuck-port ready-waitable make-waitable-unready make-waitable-ready)
  (let* ([go? #f]
	 [bad-stuck-port (make-input-port
			  'name
			  (lambda (str)
			    (if go?
				(begin
				  (bytes-set! str 0 (char->integer #\x))
				  1)
				(if (zero? (random 2))
				    0
				    ready-waitable)))
			  #f
			  void)])
    (make-waitable-unready ready-waitable)
    (test #f char-ready? bad-stuck-port)
    (test #f sync/timeout SYNC-SLEEP-DELAY bad-stuck-port)
    (test 0 read-bytes-avail!* (make-bytes 10) bad-stuck-port)
    (set! go? #t)
    (test #t char-ready? bad-stuck-port)
    (test bad-stuck-port sync/timeout SYNC-SLEEP-DELAY bad-stuck-port)
    (test #t positive? (read-bytes-avail!* (make-bytes 10) bad-stuck-port))
    (set! go? #f)
    (test #f char-ready? bad-stuck-port)
    (test #f sync/timeout SYNC-SLEEP-DELAY bad-stuck-port)
    (test 0 read-bytes-avail!* (make-bytes 10) bad-stuck-port)
    (set! ready-waitable 0)
    (test #f sync/timeout 0 bad-stuck-port)
    (test #f sync/timeout 0 bad-stuck-port)
    (check-busy-wait
     (lambda ()
       (test #f sync/timeout SYNC-BUSY-DELAY bad-stuck-port))
     #t)
    (check-busy-wait
     (lambda ()
       (thread (lambda ()
		 (sleep SYNC-BUSY-DELAY)
		 (set! go? #t)))
       (test bad-stuck-port sync bad-stuck-port))
     #t)))

(map
 (lambda (make-wt)
   (test-stuck-port (make-semaphore 1) semaphore-try-wait? semaphore-post)
   (let ([ready? #t])
     (test-stuck-port (make-wt 77 (lambda (self)
                                    (if ready?
                                        #t
                                        (make-semaphore))))
                      (lambda (wt) (set! ready? #f))
                      (lambda (wt) (set! ready? #t))))
   (let ([s (make-semaphore 1)])
     (test-stuck-port (make-wt 77 s)
                      (lambda (wt) (semaphore-try-wait? s))
                      (lambda (wt) (semaphore-post s))))
   (let ([s (make-semaphore 1)])
     (test-stuck-port (make-wt 177 (lambda (self) s))
                      (lambda (wt) (semaphore-try-wait? s))
                      (lambda (wt) (semaphore-post s)))))
 (list make-wt make-wt2))

;; ----------------------------------------

;; In the current implemenation, a depth of 10 for 
;;  waitable chains is a magic number; it causes the scheduler to
;;  swap a thread in to check whether it can run, instead of
;;  checking in the thread. (For a well-behaved chain, this 
;;  swap in will lead to a more friendly semaphore wait, for
;;  example.)

(letrec ([stack-em (lambda (n s)
		     ;; This needs to be tail-recursive to
		     ;; the find-depth check below (to check
		     ;; blocking depth, not precdure depth)
		     (if (zero? n)
			 s
			 (stack-em (sub1 n) (make-wt n s))))])
  (let* ([s1 (make-semaphore 1)]
	 [s20 (make-semaphore 1)]
	 [wt1 (stack-em 1 s1)]
	 [wt20 (stack-em 20 s20)])
    (test s1 sync/timeout 0 wt1)
    (test s20 sync/timeout 0 wt20)
    (test #f semaphore-try-wait? s1)
    (test #f semaphore-try-wait? s20)
    (let ([t20
	   (thread (lambda ()
		     (test s20 sync/timeout 1.0 wt20)))])
      (let loop ([n 20])
	(unless (zero? n)
	  (sleep)
	  (loop (sub1 n))))
      (semaphore-post s20)
      (test (void) thread-wait t20))))


;; ----------------------------------------
;;  Thread suspend, resume, and dead waitables

(let ([d (thread-dead-evt (thread void))])
  (test d sync d))

(let* ([sema (make-semaphore)]
       [t (thread (lambda () (semaphore-wait sema)))]
       [r (thread-resume-evt t)]
       [s (thread-suspend-evt t)])
  (test #f sync/timeout 0 t s)
  (test t sync/timeout 0 t s r)
  (test t sync/timeout 0 r)
  (thread-suspend t)
  (test t sync/timeout 0 r)
  (test t sync/timeout 0 s)
  (let* ([r (thread-resume-evt t)]
	 [s (thread-suspend-evt t)])
    (test #f sync/timeout 0 t r)
    (test t sync/timeout 0 t s r)
    (test t sync/timeout 0 s)
    (thread-resume t)
    (test t sync/timeout 0 s)
    (test t sync/timeout 0 r)
    (let* ([s (thread-suspend-evt t)])
      (thread (lambda () (sync (system-idle-evt)) (thread-suspend t)))
      (test #f sync/timeout 0 s)
      (test t sync s)
      (let* ([r (thread-resume-evt t)]
	     [d (thread-dead-evt t)])
	(thread (lambda () (sync (system-idle-evt)) (thread-resume t)))
	(test #f sync/timeout 0 r)
	(test t sync r)

	(test #f sync/timeout 0 d)
	(semaphore-post sema)
	(test d sync d)
	(test t sync r)
	(test t sync s)
	(test #f sync/timeout 0 (thread-resume-evt t))
	(test #f sync/timeout 0 (thread-suspend-evt t))
	(test d thread-dead-evt t)))))

;; ----------------------------------------
;;  thread mbox

(test #f thread-try-receive)
(test #f sync/timeout 0 (thread-receive-evt))
(test (void) thread-send (current-thread) 10)
(let ([t (thread-receive-evt)])
  (test t sync/timeout 10 t))
(test 10 thread-try-receive)
(test #f thread-try-receive)
(let ([t (current-thread)])
  (thread (lambda ()
            (sync (system-idle-evt))
            (thread-send t 35))))
(test 35 thread-receive)
(test #f thread-try-receive)
(test (void) thread-rewind-receive '(1 2 3))
(test 3 thread-try-receive)
(test 2 thread-try-receive)
(test (void) thread-rewind-receive '(4))
(test 4 thread-try-receive)
(test 1 thread-try-receive)
(test #f thread-try-receive)
(test (void) thread-rewind-receive (vector->list (make-vector 500 'x)))
(let loop ([n 500])
  (unless (zero? n)
    (test 'x thread-try-receive)
    (loop (sub1 n))))
(test #f thread-try-receive)
(let* ([s #f]
       [t1 (let ([t (current-thread)])
             (thread (lambda ()
                       (set! s (thread-receive)))))])
  (sync (system-idle-evt))
  (thread-suspend t1)
  (thread-send t1 'apple)
  (sync (system-idle-evt))
  (test #f values s)
  (thread-resume t1)
  (sync (system-idle-evt))
  (test 'apple values s))
(let* ([s 0]
       [t (thread (lambda ()
                    (set! s (list (thread-receive)
                                  (thread-receive)
                                  (thread-receive)))))])
  (thread-send t 0)
  (thread-send t 1)
  (thread-send t 2)
  (sync (system-idle-evt))
  (test '(0 1 2) values s))
(let ([t (thread void)])
  (sync (system-idle-evt))
  (test 'z thread-send t 'x (lambda () 'z))
  (test-values '(a z) (lambda ()
                        (thread-send t 'x (lambda () (values 'a 'z)))))
  (err/rt-test (thread-send t 'x)))

;; make sure it's ok for rewind to be the first action:
(test (void) thread-wait (thread (lambda () (thread-rewind-receive '(1 2 3)))))

;; ----------------------------------------
;;  Garbage collection

(define (num-scheduled)
  (let ([v (make-vector 7)])
    (vector-set-performance-stats! v)
    (vector-ref v 6)))

(define (check-threads-gcable label blocking-thunk)
  ;; Actually, we approximate the gcable check as a num-scheduled check,
  ;;  even though there's still a lot of machinery here to try to check
  ;;  GCing. The explicit gc has been commented out.
  (define orig-scheduled (num-scheduled))
  (let ([l (let loop ([n 20][die? #f])
	     (if (zero? n)
		 null
		 (cons (make-weak-box (thread (if die? void blocking-thunk)))
		       (loop (if die? n (sub1 n)) (not die?)))))]
	[sl (lambda ()
	      (let loop ([n 20])
		(unless (zero? n) (sleep) (loop (sub1 n)))))]
	[ok-done? (lambda (r) 
                    (or (<= (list-ref r 3) orig-scheduled)
                        ;; If we're running parallel threads, 
                        ;; just give up on the comparison.
                        (not (equal? "" Section-prefix))))])
    (test #t
	  ok-done?
	  (let loop ([tries 0][n 100])
	    (if (or (= tries 3) (< n 10))
		(list tries n label (num-scheduled))
		(begin
		  (sl) 
		  ;; (collect-garbage)
		  (loop (add1 tries)
			(apply + (map (lambda (b) (if (weak-box-value b) 1 0)) l)))))))))

(check-threads-gcable 'sema (lambda () (semaphore-wait (make-semaphore))))
(define (check/combine c)
  (check-threads-gcable 'semaw (lambda () (sync (c (make-semaphore)))))
  (check-threads-gcable 'semap (lambda () (sync (c (semaphore-peek-evt (make-semaphore))))))
  (check-threads-gcable 'ch (lambda () (sync (c (make-channel)))))
  (check-threads-gcable 'chput (lambda () (sync (c (channel-put-evt (make-channel) 10)))))
  (check-threads-gcable 'wrapped (lambda () (sync (c (wrap-evt (make-semaphore) void)))))
  (check-threads-gcable 'guard (lambda () (sync (c (guard-evt (lambda () (make-semaphore)))))))
  (check-threads-gcable 'nack (lambda () (sync (c (nack-guard-evt (lambda (nack) (make-semaphore)))))))
  (check-threads-gcable 'poll (lambda () (sync (c (poll-guard-evt (lambda (poll?) (make-semaphore)))))))
  (check-threads-gcable 'never (lambda () (sync (c never-evt)))))
(check/combine values)
(check/combine (lambda (x) (choice-evt x (make-semaphore))))
(check/combine (lambda (x) (choice-evt (make-semaphore) x)))
(check/combine (lambda (x) (choice-evt (make-semaphore) x)))

(check-threads-gcable 'nested (lambda () (call-in-nested-thread (lambda () (semaphore-wait (make-semaphore))))))
(pseudo-random-generator? 10)
(check-threads-gcable 'suspended (lambda () (thread-suspend (current-thread))))
(check-threads-gcable 'nested-suspend (lambda () (call-in-nested-thread (lambda () (thread-suspend (current-thread))))))

(check-threads-gcable 'resume (lambda () (let ([t (thread (lambda () (sleep 10)))])
					   (thread-suspend t)
					   (sync (thread-resume-evt t)))))
(check-threads-gcable 'suspend (lambda () (let ([t (thread (lambda () (semaphore-wait (make-semaphore))))])
					    (sync (thread-suspend-evt t)))))
(check-threads-gcable 'suspend-self (lambda () (sync (thread-suspend-evt (current-thread)))))

;; ----------------------------------------
;;  Fairness in wait selection

(let ([try (lambda (t1 t2 r min max)
	     (test #t 
		   < 
		   min
		   (let loop ([n 100][r-n 0])
		     (if (zero? n)
			 r-n
			 (loop (sub1 n) (+ r-n
					   (if (eq? r (sync t1 t2))
					       1
					       0)))))
		   max))])
  (let ([t1 (semaphore-peek-evt (make-semaphore 1))]
	[t2 (semaphore-peek-evt (make-semaphore 1))])
    (let-values ([(r w) (make-pipe)])
      (fprintf w "Hi!~n")
      ;; Between 20% and 80% is fair, and surely < 20% or > 80% is unlikely
      (try t1 t2 t1 20 80)
      (try t1 t2 t2 20 80)
      (try t1 w w 20 80)
      (try w t1 w 20 80)
      (try t1 (choice-evt t2 w) t1 10 50)
      (try t1 (choice-evt t2 w) w 10 50)
      (try (choice-evt t2 w) t1 w 10 50))))

;; ----------------------------------------
;;  No starvation, despite hack to increase throughput for
;;  semaphore-protected data structures:

(let ([s1 (make-semaphore)])
  (define t1
    (thread (lambda ()
	      (semaphore-wait s1)
	      (semaphore-post s1))))
  (let loop ()
    (sleep)
    (semaphore-post s1)
    (semaphore-wait s1)
    (when (thread-running? t1)
      (loop)))
  (test #t string? "No starvation - good!"))

(let ([s1 (make-semaphore)]
      [s2 (make-semaphore)])
  (define t1
    (thread (lambda ()
	      (semaphore-post (sync s1 s2)))))
  (define t2
    (thread (lambda ()
	      (semaphore-post (sync s1 s2)))))
  (let loop ()
    (sleep)
    (semaphore-post s1)
    (semaphore-wait s1)
    (semaphore-post s2)
    (semaphore-wait s2)
    (when (or (thread-running? t1)
	      (thread-running? t2))
      (loop)))
  (test #t string? "No starvation - good!"))

;; ----------------------------------------
;;  Breaks and dynamic-wind

(let ([s #f]
      [p #f]
      [/dev/null-for-err
       (make-output-port #f always-evt (lambda (s start end ? ??) (- end start)) void void)]
      [did-pre1 #f]
      [did-pre2 #f]
      [did-act1 #f]
      [did-act2 #f]
      [did-post1 #f]
      [did-post2 #f]
      [did-done #f]
      [break-on (lambda () (break-enabled #t))]
      [sw semaphore-wait])
  (let ([mk-t
	 (lambda (init ;; how to start
		  ;; functions that can capture the continuation:
		  capture-pre capture-act capture-post
		  ;; whether to start the thread with breaks off (imperatively)
		  break-off?
		  ;; things to do in pre, act, and post
		  pre-thunk act-thunk post-thunk
		  ;; sema-wait or sema-wait/enable-break:
		  pre-semaphore-wait act-semaphore-wait post-semaphore-wait)
	   ;; This reset function is called for a cptured continuation
	   ;;  to reset the effective arguments
	   (define (reset
		    -capture-pre -capture-act -capture-post
		    -break-off?
		    -pre-thunk -act-thunk -post-thunk
		    -pre-semaphore-wait -act-semaphore-wait -post-semaphore-wait)
	     (when -break-off?
	       (break-enabled #f))
	     (set! capture-pre -capture-pre)
	     (set! capture-act -capture-act)
	     (set! capture-post -capture-post)
	     (set! pre-thunk -pre-thunk)
	     (set! act-thunk -act-thunk)
	     (set! post-thunk -post-thunk)
	     (set! pre-semaphore-wait -pre-semaphore-wait)
	     (set! act-semaphore-wait -act-semaphore-wait)
	     (set! post-semaphore-wait -post-semaphore-wait))
	   ;; initially, thread hasn't gotten anywhere:
	   (set! did-pre1 #f) (set! did-pre2 #f)
	   (set! did-act1 #f) (set! did-act2 #f)
	   (set! did-post1 #f) (set! did-post2 #f)
	   (set! did-done #f)
	   (thread 
	    (lambda ()
	      (current-error-port /dev/null-for-err)
	      (when break-off?
		(break-enabled #f))
	      (init ;; init function gets to decide whether to do the normal body:
	       (lambda ()
           (printf "here ~s\n"  (procedure? capture-pre))
		 (dynamic-wind
		     (lambda ()
           (printf "here3 ~s\n" (procedure? capture-pre))
		       (capture-pre
			reset
			(lambda ()
           (printf "here4\n")
			  (set! did-pre1 #t)
			  (semaphore-post p)
			  (pre-thunk)
			  (pre-semaphore-wait s)
			  (set! did-pre2 #t))))
		     (lambda () 
           (printf "here2\n")
		       (capture-act
			reset
			(lambda ()
			  (set! did-act1 #t)
			  (semaphore-post p)
			  (act-thunk)
			  (act-semaphore-wait s)
			  (set! did-act2 #t))))
		     (lambda ()
		       (capture-post
			reset
			(lambda ()
			  (set! did-post1 #t)
			  (semaphore-post p)
			  (post-thunk)
			  (post-semaphore-wait s)
			  (set! did-post2 #t)))))
		 (set! did-done #t))))))])
    ;; `go' runs the tests, parameterized by when to break the other
    ;;  thread and when it should take effect in the other thread
    (define (go
	     mk-t* break-off?
	     pre-thunk act-thunk post-thunk
	     pre-semaphore-wait act-semaphore-wait post-semaphore-wait
	     try-pre-break 
	     should-pre-break?
	     should-preact-break?
	     try-act-break 
	     should-act-break?
	     try-post-break 
	     should-post-break?
	     should-done-break?)
      ;; print the state for this test:
      (test #t list? (list 'go 
			   pre-thunk act-thunk post-thunk
			   pre-semaphore-wait act-semaphore-wait post-semaphore-wait
			   try-pre-break 
			   should-pre-break?
			   should-preact-break?
			   try-act-break 
			   should-act-break?
			   try-post-break 
			   should-post-break?
			   should-done-break?))
      ;; create fresh semaphores
      (set! s (make-semaphore))
      (set! p (make-semaphore))
      (printf "mk ~s\n" mk-t*)
      ;; create the thread
      (let ([t (mk-t* break-off?
		      pre-thunk act-thunk post-thunk
		      pre-semaphore-wait act-semaphore-wait post-semaphore-wait)])
	(semaphore-wait p)
	(test #t 'pre1 did-pre1)
	(try-pre-break t)
	(semaphore-post s)
	(if should-pre-break?
	    (begin
	      (thread-wait t)
	      (test #f 'pre2 did-pre2))
	    (if should-preact-break?
		(begin
		  (semaphore-post s) ; for post
		  (thread-wait t)
		  (test #t 'pre2 did-pre2)
		  (test #f 'act1 did-act1))
		(begin
		  (semaphore-wait p)
		  (test #t 'pre2 did-pre2)
		  (test #t 'act1 did-act1)
		  (try-act-break t)
		  (semaphore-post s)
		  (if should-act-break?
		      (begin
			(semaphore-post s) ; for post
			(thread-wait t)
			(test #f 'act2 did-act2))
		      (begin
			(semaphore-wait p)
			(test #t 'act2 did-act2)
			(test #t 'post1 did-post1)
			(try-post-break t)
			(semaphore-post s)
			(if should-post-break?
			    (begin
			      (thread-wait t)
			      (test #f 'post2 did-post2))
			    (begin
			      (thread-wait t)
			      (test #t 'post2 did-post2)
			      (test (not should-done-break?) 'done did-done))))))))))
    (for-each 
     (lambda (mk-t)
       (for-each 
	(lambda (nada)
	  ;; Basic checks --- dynamic-wind thunks don't explicitly enable breaks
	  (go mk-t #f  nada nada nada  sw sw sw  void #f #f void #f void #f #f)
	  (go mk-t #f  nada nada nada  sw sw sw  break-thread #f 'pre-act void #f void #f #f)
	  (go mk-t #f  nada nada nada  sw sw sw  void #f #f break-thread 'act void #f #f)
	  (go mk-t #f  nada nada nada  sw sw sw  void #f #f void #f break-thread #f 'done)

	  ;; All dynamic-wind thunks enable breaks
	  (map (lambda (break-on sw)
		 (go mk-t #f  break-on break-on break-on  sw sw sw  void #f #f void #f void #f #f)
		 (go mk-t #f  break-on break-on break-on  sw sw sw  break-thread 'pre #f void #f void #f #f)
		 (go mk-t #f  break-on break-on break-on  sw sw sw  void #f #f break-thread 'act void #f #f)
		 (go mk-t #f  break-on break-on break-on  sw sw sw  void #f #f void #f break-thread 'post #f))
	       (list break-on void)
	       (list sw semaphore-wait/enable-break))

	  ;; Enable break in pre or act shouldn't affect post
	  (go mk-t #f  break-on nada nada  sw sw sw  void #f #f void #f break-thread #f 'done)
	  (go mk-t #f  nada break-on nada  sw sw sw  void #f #f void #f break-thread #f 'done)
	  
	  ;; Enable break in pre shouldn't affect act/done
	  (go mk-t #t  break-on nada nada  sw sw sw  void #f #f break-thread #f void #f #f)
	  (go mk-t #t  break-on nada nada  sw sw sw  void #f #f void #f break-thread #f #f))
	(list void sleep)))
     ;; We'll make threads in three modes: normal, restore a continuation into pre,
     ;;  and restore a continuation into act
     (let* ([no-capture (lambda (reset body) (body))]
	    [plain-mk-t (lambda args
			  (apply mk-t 
				 (lambda (f) (f))
				 no-capture no-capture no-capture
				 args))]
	    [mk-capturing (lambda (which)
			    (let* ([k+reset #f]
				   [capture (lambda (reset body)
					      (let/cc k 
						(set! k+reset (cons k reset)))
					      (body))])
			      ;; Grab a continuation for the dyn-wind's pre/act/post
			      (go (lambda args
                                    (printf "here???\n")
                                    (printf "??? ~s\n" k+reset)
                                    (printf "??? ~s\n" capture)
				    (apply mk-t 
					   (lambda (f) (f))
					   (if (eq? which 'pre) capture no-capture)
					   (if (eq? which 'act) capture no-capture)
					   (if (eq? which 'post) capture no-capture)
					   args))
				  #f  void void void  sw sw sw  void #f #f void #f void #f #f)
			      (lambda args
				(apply mk-t 
				       (lambda (f)
					 ;; First, reset the arguments that are in the continuation's
					 ;;  state
					 (apply (cdr k+reset) no-capture no-capture no-capture args)
					 ;; Now restore the continuation
					 ((car k+reset)))
				       no-capture no-capture no-capture
				       args))))])
       (list plain-mk-t
	     (mk-capturing 'pre)
	     (mk-capturing 'act))))))

;; ----------------------------------------
;; Check wrap-evt result superceded by internally
;;  installed constant (i.e., the input port):

(let ([p (make-input-port
	  'test
	  (lambda (bstr) never-evt)
	  (lambda (bstr skip-count progress-evt)
	    (wrap-evt always-evt (lambda (_) 17)))
	  void)])
  ;; Make sure we don't get 17
  (test p sync p))

;; ----------------------------------------

(report-errs)