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

(import scheme chicken)
(use
  (only srfi-1 any)
  (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))

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

;(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=? ((struct thread) * --> boolean))
(define (thread-state=? th tk)
	(eq? tk (thread-state th)) )

(: thread-created? ((struct thread) --> boolean))
(define (thread-created? th)
	(thread-state=? th 'created) )

(: thread-ready? ((struct thread) --> boolean))
(define (thread-ready? th)
	(thread-state=? th 'ready) )

(: thread-running? ((struct thread) --> boolean))
(define (thread-running? th)
	(thread-state=? th 'running) )

(: thread-blocked? ((struct thread) --> boolean))
(define (thread-blocked? th)
	(thread-state=? th 'blocked) )

(: thread-suspended? ((struct thread) --> boolean))
(define (thread-suspended? th)
	(thread-state=? th 'suspended) )

(: thread-sleeping? ((struct thread) --> boolean))
(define (thread-sleeping? th)
	(thread-state=? th 'sleeping) )

(: thread-terminated? ((struct thread) --> boolean))
(define (thread-terminated? th)
	(thread-state=? th 'terminated) )

(: thread-dead? ((struct thread) --> boolean))
(define (thread-dead? th)
	(thread-state=? th 'dead) )

(: thread-obstructed? ((struct thread) --> boolean))
(define (thread-obstructed? th)
	(or (thread-blocked? th) (thread-sleeping? th)) )

;;

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

(: thread-blocked-for-termination? ((struct 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? ((struct 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? ((struct 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! ((struct 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)  ) ) ) )

;;

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

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

#;
(: thread-state ((struct thread) --> *))
#;
(define (thread-state th)
	(*thread-state (check-thread 'thread-state th)) )

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

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

#;
(: thread-name ((struct thread) --> *))
#;
(define (thread-name th)
	(*thread-name (check-thread 'thread-name th)) )

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

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

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

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

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

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

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

;;

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

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

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

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

(: thread-default-exception-handler ((struct 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 ((struct 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 ((struct thread) th) !..)
	;# ;
	"..."
	;# ;dynamic checks
	(check-thread 'thread-current-parameter-vector th) ...
	...
	;body
	(*state-buffer-current-parameter-vector (*thread-state-buffer th)) )

;DEPRECATED

(define thread-blocked?/termination thread-blocked-for-termination?)
(define thread-blocked?/io thread-blocked-for-io?)
(define thread-blocked?/timeout thread-blocked-for-timeout?)

) ;module thread-utils