;;;; thread-reaper.scm
;;;; Kon Lovett, Oct '09

;; Issues
;;
;; - Could allow the stopping of an existing reaper and the startup of another.
;; Make '+stopping?+' thread thunk local w/ a set/get behavior.

; Used by threads that are cleanly terminating and wish to 'join' the
; primordial thread w/o any user intervention. (A thread that attempts
; to 'join' itself will cause a deadlock.)
;
; The "reaped" thread's end-exception, if any, is printed as a warning.
;
; The reaper can be stopped at any time

(module thread-reaper

  (;export
    thread-reaper-shutdown?
    thread-reap!
    thread-reaper-stop!
    thread-reaper-greedy
    thread-reaper-quantum)

  (import scheme
          chicken
          (only data-structures
            queue-empty? queue-remove! make-queue queue-add!)
          (only srfi-18
            thread-join! thread-yield! thread-start! make-thread
            thread-quantum-set! thread-quantum
            terminated-thread-exception? uncaught-exception?)
          (only miscmacros until)
          (only synch
            make-object/synch synch-with %synch-with)
          (only thread-support
            check-thread print-exception-warning))

  (require-library
    data-structures srfi-18
    miscmacros
    synch thread-support)

;;

(define (reap-queue-thread thq)
  ; In case an unhandled-exception
  (handle-exceptions exn
      (print-exception-warning exn)
    (thread-join! (queue-remove! thq)) ) )

(define (reap-thread-queue-top thq) (unless (queue-empty? thq) (reap-queue-thread thq)))
(define (reap-thread-queue thq) (until (queue-empty? thq) (reap-queue-thread thq)))

(define (reap-all) (%synch-with +threads+ threads (reap-thread-queue threads)))
(define (reap-top) (%synch-with +threads+ threads (reap-thread-queue-top threads)))

;;

(define-constant DEFAULT-REAPER-QUANTUM 2500)
(define-constant STOPPING-REAPER-QUANTUM 10000)

(define +threads+ #f)           ; Queue of threads to reap
(define +reaper-thread+ #f)     ; Needs a separate thread since asynch
(define +greedy?+ #f)           ; Reaper should empty the queue each time-slice
(define +stopping?+ #f)         ; Reaper should cleanly stop
(define +shutdown?+ #f)         ; Program terminating

; Reaper thread thunk

(define (reaper)
  (if +stopping?+ (reap-all)
      (begin
        (if +greedy?+ (reap-all) (reap-top))
        (thread-yield!)
        (reaper) ) ) )

(define (thread-reaper-stop!)
  (when (and +reaper-thread+ (not +stopping?+))
    ; Tell reaper we're quits
    (set! +stopping?+ #t)
    (let ((th +reaper-thread+))
      ; Bump up the time-slice so queue clears faster
      (thread-quantum-set! th (fxmax (thread-quantum th) STOPPING-REAPER-QUANTUM))
      ; Waits until queue empty
      (thread-join! th)
      ; No more reaping with this thread
      (set! +reaper-thread+ #f) ) ) )

(define (thread-reaper-shutdown!)
  (set! +shutdown?+ #t)
  (thread-reaper-stop!) )

(define (thread-reaper-start!)
  ; Local only so no need to protect
  (unless +threads+         ; Only done once
    (set! +threads+ (make-object/synch (make-queue) '(queue/synch-)))
    ; Clean shutdown
    (on-exit thread-reaper-shutdown!) )
  (unless +reaper-thread+   ; Whenever no reaper
    (set! +stopping?+ #f)
    (set! +reaper-thread+ (make-thread reaper 'thread-reaper))
    (thread-quantum-set! +reaper-thread+ DEFAULT-REAPER-QUANTUM)
    (thread-start! +reaper-thread+) ) )

(define (thread-reaper-shutdown?) +shutdown?+)

(define (thread-reaper-greedy . args)
  (if (null? args) +greedy?+
      (set! +greedy?+ (and (car args) #t)) ) )

(define (thread-reaper-quantum . args)
  (unless (or +stopping?+ +shutdown?+)
    (unless +reaper-thread+ (thread-reaper-start!))
    (if (null? args) (thread-quantum +reaper-thread+)
        (thread-quantum-set! +reaper-thread+ (car args)) ) ) )

(define (thread-reap! thread)
  (check-thread 'thread-reap! thread)
  (unless (or +stopping?+ +shutdown?+)
    (unless +reaper-thread+ (thread-reaper-start!))
    (%synch-with +threads+ threads (queue-add! threads thread)) ) )

) ;module thread-reaper