guile-knots/tests/thread-pool.scm

(use-modules (tests)
             (ice-9 atomic)
             (ice-9 threads)
             (srfi srfi-71)
             (fibers)
             (unit-test)
             (knots)
             (knots thread-pool))

(let ((thread-pool
       (make-fixed-size-thread-pool 2)))

  (assert-equal
   (call-with-thread
    thread-pool
    (lambda ()
      4))
   4))

(let ((thread-pool
       (make-fixed-size-thread-pool
        2
        #:thread-initializer (const '(2)))))

  (assert-equal
   (call-with-thread
    thread-pool
    (lambda (num)
      (* 2 num)))
   4))

(let ((thread-pool
       (make-fixed-size-thread-pool 2)))

  (assert-equal
   #t
   (with-exception-handler
       (lambda (exn)
         (knots-exception? exn))
     (lambda ()
       (call-with-thread
        thread-pool
        (lambda ()
          (+ 1 'a))))
     #:unwind? #t)))

(run-fibers-for-tests
 (lambda ()
   (let ((thread-pool
          (make-thread-pool 2)))

     (assert-equal
      (call-with-thread
       thread-pool
       (lambda ()
         4))
      4))))

(run-fibers-for-tests
 (lambda ()
   (let ((thread-pool
          (make-thread-pool
           2
           #:thread-initializer (const '(2)))))

     (assert-equal
      (call-with-thread
       thread-pool
       (lambda (num)
         (* 2 num)))
      4))))

(run-fibers-for-tests
 (lambda ()
   (let ((thread-pool
          (make-thread-pool 2)))

     (assert-equal
      #t
      (with-exception-handler
          (lambda (exn)
            (knots-exception? exn))
        (lambda ()
          (call-with-thread
           thread-pool
           (lambda ()
             (+ 1 'a))))
        #:unwind? #t)))))

(let ((thread-pool
       (make-fixed-size-thread-pool
        1
        #:thread-lifetime 1
        #:thread-initializer
        (lambda ()
          (list (make-atomic-box #t))))))

  (for-each
   (lambda _
     (call-with-thread
      thread-pool
      (lambda (box)
        (if (atomic-box-ref box)
            (atomic-box-set! box #f)
            (error (atomic-box-ref box))))))
   (iota 10)))

(run-fibers-for-tests
 (lambda ()
   (let ((thread-pool
          (make-thread-pool 1 #:thread-lifetime 1)))

     (for-each
      (lambda _
        (call-with-thread
         thread-pool
         (lambda () #f)))
      (iota 10)))))

(let ((thread-pool
       (make-fixed-size-thread-pool
        1
        #:thread-lifetime 2
        #:thread-initializer
        (lambda ()
          (list (make-atomic-box 2))))))

  (define (ref-and-decrement box)
    (let ((val (atomic-box-ref box)))
      (atomic-box-set! box (- val 1))
      val))

  (unless (= 2 (call-with-thread
                thread-pool
                ref-and-decrement))
    (error))
  (unless (= 1 (call-with-thread
                thread-pool
                ref-and-decrement))
    (error))
  (unless (= 2 (call-with-thread
                thread-pool
                ref-and-decrement))
    (error)))

;; Test that the destructor is called when a size 1 fixed-size thread
;; pool is destroyed, and that destroy-thread-pool blocks until it has
;; completed.
(let* ((destructor-called? #f)
       (thread-pool
        (make-fixed-size-thread-pool
         1
         #:thread-destructor
         (lambda ()
           (set! destructor-called? #t)))))
  (destroy-thread-pool thread-pool)
  (assert-equal #t destructor-called?))

;; Test that the destructor is called for every thread when a
;; multi-thread fixed-size thread pool is destroyed, and that
;; destroy-thread-pool blocks until all destructors have completed.
(let* ((destructor-count 0)
       (mutex (make-mutex))
       (pool-size 3)
       (thread-pool
        (make-fixed-size-thread-pool
         pool-size
         #:thread-destructor
         (lambda ()
           (with-mutex mutex
             (set! destructor-count (+ destructor-count 1)))))))
  (destroy-thread-pool thread-pool)
  (assert-equal pool-size destructor-count))

(display "thread-pool test finished successfully\n")