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

;; 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-for-termination?
  thread-blocked-for-io?
  thread-blocked-for-timeout?
  ;
  thread-unblock!
  ;
  thread-thunk
  thread-result-list
  #;thread-state
  thread-block-timeout
  thread-state-buffer
  #;thread-name
  thread-end-exception
  thread-owned-mutexes
  #;thread-quantum
  #;thread-specific
  thread-block-object
  thread-recipients
  thread-dynamic-winds
  thread-standard-input
  thread-standard-output
  thread-standard-error
  thread-default-exception-handler
  thread-current-parameter-vector
  ;
  thread-block-object-of-recipient?
  ;
  *thread-thunk
  *thread-result-list
  *thread-state
  *thread-block-timeout
  *thread-state-buffer
  *thread-name
  *thread-end-exception
  *thread-owned-mutexes
  *thread-quantum
  *thread-specific
  *thread-block-object
  *thread-recipients)

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

;; Thread Messages

(define (thread-warning-message th)
  (format #t "Warning (~A): " th) )

(define (print-exception-error exn
            #!optional
            (th (current-thread))
            (out (current-error-port))
            (hdr "\n\tThread call history:\n"))
  (print-error-message exn out (thread-warning-message th))
  (print-call-chain out 0 th hdr) )

(define (print-exception-warning exn
            #!optional
            (th (current-thread))
            (out (current-error-port))
            (hdr "\n\tThread call history:\n"))
  (when (enable-warnings)
    (print-exception-error exn th out hdr)) )

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

;(define make-thread-timeout

;;; Unchecked slot access

(define (*thread-thunk th)            (##sys#slot th 1))
(define (*thread-result-list th)      (##sys#slot th 2))
(define (*thread-state th)            (##sys#slot th 3))
(define (*thread-block-timeout th)    (##sys#slot th 4))
(define (*thread-state-buffer th)     (##sys#slot th 5))
(define (*thread-name th)             (##sys#slot th 6))
(define (*thread-end-exception th)    (##sys#slot th 7))
(define (*thread-owned-mutexes th)    (##sys#slot th 8))
(define (*thread-quantum th)          (##sys#slot th 9))
(define (*thread-specific th)         (##sys#slot th 10))
(define (*thread-block-object th)     (##sys#slot th 11))
(define (*thread-recipients th)       (##sys#slot th 12))
(define (*unblocked-by-timeout? th)   (##sys#slot th 13))

;;

(define (*state-buffer-dynamic-winds sb)              (vector-ref sb 0))
(define (*state-buffer-standard-input sb)             (vector-ref sb 1))
(define (*state-buffer-standard-output sb)            (vector-ref sb 2))
(define (*state-buffer-standard-error sb)             (vector-ref sb 3))
(define (*state-buffer-default-exception-handler sb)  (vector-ref sb 4))
(define (*state-buffer-current-parameter-vector sb)   (vector-ref sb 5))

;;

(define (thread-block-object-of-recipient? th)
  (any
    (lambda (rth) (eq? (*thread-block-object rth) th))
    (*thread-recipients th)) )

;;;

;;

(define-check+error-type thread)

;;

(: thread-state=? (thread * -> boolean))
;
(define (thread-state=? th tk) (eq? tk (thread-state th)))

(: thread-created? (thread -> boolean))
(: thread-ready? (thread -> boolean))
(: thread-running? (thread -> boolean))
(: thread-blocked? (thread -> boolean))
(: thread-suspended? (thread -> boolean))
(: thread-sleeping? (thread -> boolean))
(: thread-terminated? (thread -> boolean))
(: thread-dead? (thread -> boolean))
(: thread-obstructed? (thread -> boolean))
;
(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)))

;;

(: thread-blocked-for-object (thread -> *))
;
(define (*thread-blocked-for-object th)
  (and
    (thread-blocked? th)
    (*thread-block-object th)) )

(: thread-blocked-for-termination? (thread -> boolean))
;
(define (thread-blocked-for-termination? th)
  (and
    (thread-blocked? th)
    ;????? ;FIXME accurate but imprecise
    (null? (*thread-recipients th))
    #t ) )

(: thread-blocked-for-timeout? (thread -> boolean))
;
(define (thread-blocked-for-timeout? th)
  (and
    (thread-blocked? th)
    (not (*thread-block-object th))
    (*thread-block-timeout th)
    #t ) )

(: thread-blocked-for-io? (thread -> boolean))
;
(define (thread-blocked-for-io? th)
  (and-let* ((obj (*thread-blocked-for-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

;;

(: thread-unblock! (thread -> void))
;
(define (thread-unblock! th)
  (when (thread-blocked-for-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)
        ) ) ) )

;;

#| ;SRFI-18
(: thread-state (thread -> *))
;
(define (thread-state th)
	(*thread-state (check-thread 'thread-state th)) )
(: thread-name (thread -> *))
;
(define (thread-name th)
	(*thread-name (check-thread 'thread-name th)) )

(: thread-quantum (thread -> *))
;
(define (thread-quantum th)
	(*thread-quantum (check-thread 'thread-quantum th)) )

(: thread-specific (thread -> *))
;
(define (thread-specific th)
	(*thread-specific (check-thread 'thread-specific th)) )
|#

(: thread-thunk (thread -> procedure))
;
(define (thread-thunk th)
	(*thread-thunk (check-thread 'thread-thunk th)) )

(: thread-result-list (thread -> (or boolean list)))
;
(define (thread-result-list th)
	(*thread-result-list (check-thread 'thread-result-list th)) )

(: thread-block-timeout (thread -> (or boolean float)))
(define (thread-block-timeout th)
	(*thread-block-timeout (check-thread 'thread-block-timeout th)) )

(: thread-state-buffer (thread -> vector))
;
(define (thread-state-buffer th)
	(*thread-state-buffer (check-thread 'thread-state-buffer th)) )

(: thread-end-exception (thread -> *))
;
(define (thread-end-exception th)
	(*thread-end-exception (check-thread 'thread-end-exception th)) )

(: thread-owned-mutexes (thread -> list))
;
(define (thread-owned-mutexes th)
	(*thread-owned-mutexes (check-thread 'thread-owned-mutexes th)) )

(: thread-block-object (thread -> *))
;
(define (thread-block-object th)
	(*thread-block-object (check-thread 'thread-block-object th)) )

(: thread-recipients (thread -> list))
;
(define (thread-recipients th)
	(*thread-recipients (check-thread 'thread-recipients th)) )

(: unblocked-by-timeout? (thread -> boolean))
;
(define (unblocked-by-timeout? th)
	(*unblocked-by-timeout? (check-thread 'unblocked-by-timeout? th)) )

;;

(: thread-dynamic-winds (thread -> list))
;
(define (thread-dynamic-winds th)
	(*state-buffer-dynamic-winds (*thread-state-buffer (check-thread 'thread-dynamic-winds th))) )

(: thread-standard-input (thread -> port))
;
(define (thread-standard-input th)
	(*state-buffer-standard-input (*thread-state-buffer (check-thread 'thread-standard-input th))) )

(: thread-standard-output (thread -> port))
;
(define (thread-standard-output th)
	(*state-buffer-standard-output (*thread-state-buffer (check-thread 'thread-standard-output th))) )

(: thread-standard-error (thread -> port))
;
(define (thread-standard-error th)
	(*state-buffer-standard-error (*thread-state-buffer (check-thread 'thread-standard-error th))) )

(: thread-default-exception-handler (thread -> procedure))
;
(define (thread-default-exception-handler th)
	(*state-buffer-default-exception-handler (*thread-state-buffer (check-thread 'thread-default-exception-handler th))) )

(: thread-current-parameter-vector (thread -> vector))
;
(define (thread-current-parameter-vector th)
	(*state-buffer-current-parameter-vector (*thread-state-buffer (check-thread 'thread-current-parameter-vector th))) )

#; ;TBD
(:define vector (thread-current-parameter-vector (thread th) !..)
	;# ;
	"..."
	;# ;dynamic checks
	(check-thread 'thread-current-parameter-vector th) ...
	...
	;body
	(*state-buffer-current-parameter-vector (*thread-state-buffer th)) )

) ;module thread-utils