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

;; Issues

; Chicken Generic Arithmetic!

(module thread-support

  (;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-blocked?/termination
    thread-blocked?/io
    thread-blocked?/timeout
    ;
    thread-unblock!)

  (import scheme
          chicken
          (only srfi-18
            thread-state thread? current-thread
            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)))
  (print-error-message exn (current-error-port) (thread-warning-message th))
  (print-call-chain (current-error-port) 0 th) )

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

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

(define (make-thread-timeout n)
  (if (number? n) (seconds->time (+ n (time->seconds (current-time))))
      n ) )

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

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

;;; 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))

;;;

;;

(define-check+error-type thread)

;;

(define (thread-state=? th state) (eq? state (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-blocked?/termination th)
  (and (thread-blocked? th)
       (*thread-recipients th)
       #t ) )

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

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

;;

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

) ;module thread-support