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

;; Issues

; Chicken Generic Arithmetic!

(module thread-utils

  (;export
    ;
    thread-warning-message
    print-exception-error
    print-exception-warning
    ;
    make-thread-timeout
    thread-timeout? check-thread-timeout error-thread-timeout
    ;
    check-thread error-thread
    ;
    thread-state=?
    thread-created?
    thread-ready?
    thread-running?
    thread-blocked?
    thread-suspended?
    thread-sleeping?
    thread-terminated?
    thread-dead?
    thread-obstructed?
    ;
    thread-blocked?/termination
    thread-blocked?/io
    thread-blocked?/timeout
    ;
    thread-unblock!)

  (import
    scheme
    chicken
    (only srfi-18
      thread-state thread? current-thread
      condition-variable?
      mutex?
      time? seconds->time time->seconds current-time)
    (only type-checks define-check+error-type))

  (require-library srfi-18 type-checks)

;; Thread Messages

(define (thread-warning-message th)
  (let ((o (open-output-string)))
		 (display "Warning (" o)
		 (display th o)
		 (display "): " o)
		 (get-output-string o) ) )

(define (print-exception-error exn #!optional (th (current-thread)) (out (current-error-port)))
  (print-error-message exn out (thread-warning-message th))
  (print-call-chain out 0 th) )

(define (print-exception-warning exn #!optional (th (current-thread)) (out (current-error-port)))
  (when (enable-warnings) (print-exception-error exn th out)) )

;; Thread Timeout Object (actually any SRFI 12 timeout)

(define (thread-timeout? obj) (or (not obj) (number? obj) (time? obj)))

(define-check+error-type thread-timeout)

(define (make-thread-timeout off #!optional base)
  (cond
    ;Ignore base when no timeout
    ((not off)
      #f )
    ((time? off)
      off )
    ((number? off)
      (let ((base
              (cond
                ((number? base)
                  base )
                ((not base)
                  (time->seconds (current-time)) )
                ((time? base)
                  (time->seconds base) )
                (else
                  (error-thread-timeout 'make-thread-timeout base 'base) ) ) ) )
          (seconds->time (+ off base)) ) )
    (else
      (error-thread-timeout 'make-thread-timeout off 'offset) ) ) )

;;; Unchecked slot access

(define (*thread-block-timeout th) (##sys#slot th 4))
(define (*thread-block-object th) (##sys#slot th 11))
(define (*thread-recipients th) (##sys#slot th 12))

;;

#; ;accurate and precise but more work
(define (block-object-of-recipient? th)
  (any
    (lambda (rth) (eq? (*thread-block-object rth) th))
    (*thread-recipients th)) )

;;;

;;

(define-check+error-type thread)

;;

(define (thread-state=? th tk) (eq? tk (thread-state th)))

(define (thread-created? th) (thread-state=? th 'created))
(define (thread-ready? th) (thread-state=? th 'ready))
(define (thread-running? th) (thread-state=? th 'running))
(define (thread-blocked? th) (thread-state=? th 'blocked))
(define (thread-suspended? th) (thread-state=? th 'suspended))
(define (thread-sleeping? th) (thread-state=? th 'sleeping))
(define (thread-terminated? th) (thread-state=? th 'terminated))
(define (thread-dead? th) (thread-state=? th 'dead))

(define (thread-obstructed? th) (or (thread-blocked? th) (thread-sleeping? th)))

;;

(define (*thread-blocked?/object th)
  (and (thread-blocked? th)
       (*thread-block-object th)) )

(define (thread-blocked?/termination th)
  (and (thread-blocked? th)
       ;FIXME accurate but imprecise
       (*thread-recipients th)
       #t ) )

(define (thread-blocked?/timeout th)
  (and (thread-blocked? th)
       (not (*thread-block-object th))
       (*thread-block-timeout th)
       #t ) )

(define (thread-blocked?/io th)
  (and-let* ((obj (*thread-blocked?/object th)))
    ;FIXME should check for (fd . i/o)
    (pair? obj) ) )

;thread-block-object:
;- mutex : means owns the mutex (but obviously not blocking on it)
;condition-variable : means blocked waiting for a cv announce
;thread : means blocked waiting for termination of the thread

;;

(define (thread-unblock! th)
  (when (thread-blocked?/timeout th) (##sys#thread-unblock! th))
  #;
  (when (thread-obstructed? th)
    (cond
      ((*thread-block-timeout th) (##sys#thread-unblock! th) )
      ;cannot unblock when terminating
      ((*thread-recipients th)    )
      ;cannot unblock when waiting for some other object
      ((*thread-block-object th)  ) ) ) )

) ;module thread-utils