;;;;
;;;; thread.stk             -- Threads support
;;;;
;;;; Copyright © 2006-2023 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@essi.fr]
;;;;    Creation date: 26-Jan-2006 22:56 (eg)
;;;;


(export make-thread thread-handler-error-show thread-sleep! thread-join!
        mutex-lock! mutex-unlock!
        join-timeout-exception? abandoned-mutex-exception?
        terminated-thread-exception?
        &uncaught-exception uncaught-exception? uncaught-exception-reason)


(define (%thread-timeout->seconds timeout)
  (cond
   ((time? timeout) (time->seconds timeout))
   ((not timeout)   timeout)
   ((real? timeout) (+ (time->seconds (current-time))
                       timeout))
   (else (error "bad timeout ~S" timeout))))

#|
<doc EXT make-thread
 * (make-thread thunk)
 * (make-thread thunk name)
 * (make-thread thunk name stack-size)
 *
 * Returns a new thread. This thread is not automatically made runnable
 * (the procedure |thread-start!| must be used for this). A thread has the
 * following fields:  name, specific, end-result, end-exception, and a list
 * of locked/owned mutexes it owns. The thread's execution consists of a call
 * to thunk with the "initial continuation". This continuation causes the
 * (then) current thread to store the result in its end-result field, abandon
 * all mutexes it owns, and finally terminate. The dynamic-wind
 * stack of the initial continuation is empty. The optional name is an
 * arbitrary Scheme object which identifies the thread (useful for debugging);
 * it defaults to an unspecified value. The specific field is set to an
 * unspecified value.  The thread inherits the dynamic environment from the
 * current thread. Moreover, in this dynamic environment the exception handler
 * is bound to the "initial exception handler" which is a unary procedure
 * which causes the (then) current thread to store in its end-exception
 * field an "uncaught exception" object whose "reason" is the argument
 * of the handler, abandon all mutexes it owns, and finally terminate.
 *
 * NOTE: The optional parameter |stack-size| permits to specify
 * the size (in words) reserved for the thread. This option does not exist
 * in {{quick-link-srfi 18}}.
doc>
|#
(define (make-thread thunk :optional (name (symbol->string (gensym "thread")))
                     stack-size)

  (define (show-thread-error c)
    (when (and (condition? c)
               (condition-has-type? c &error-message))
      (let* ((name (thread-name (current-thread)))
             (who  (condition-ref c 'location))
             (msg  (condition-ref c 'message))
             (bt   (condition-ref c 'backtrace))
             (loc  (%build-error-location who bt)))
        (display (do-color 'bold 'red
                           "**** Error "
                           'blue
                           (format "(in thread ~S):\n" name)
                           'bold 'red
                           (format "~A: ~A\n" (car loc) msg)
                           'normal
                           "    (this error may be signaled again later)\n")
                 (current-error-port)))))

  (define (thread-handler c)
    (%thread-end-exception-set! (current-thread) c)
    (when (thread-handler-error-show)
      ;; show a message as soon as the error occurs instead of postponing
      ;; it until the thread is joined
      (show-thread-error c))
    c)

  (%make-thread (lambda ()
                  (with-handler thread-handler
                                (thunk)))
                name
                stack-size))

#|
<doc EXT thread-handler-error-show
 * (thread-handler-error-show)
 * (thread-handler-error-show value)
 *
 * When an untrapped error occurs in a thread, it produces an
 * <<make-thread, _uncaught exception_>> which can finally be
 * trapped when the thread is <<thread-join, _joined_>>.
 * Setting the |thread-handler-error-show| parameter permits to see
 * error message as soon as possible, even without joining the thread.
 * This makes debugging easier. By default, this parameter is set to
 * `#t`.
doc>
|#
(define-parameter thread-handler-error-show #t)


(define (thread-sleep! timeout)
  (let ((n (%thread-timeout->seconds timeout)))
    (unless n
      (error 'thread-sleep! "cannot used #f as timeout"))
    (%thread-sleep! n)))


(define (thread-join! thread :optional timeout (timeout-val #f timeout-val?))
  (if (and (eq? thread (current-thread)) (not timeout))
      (error 'thread-join! "cannot join on myself (deadlock will occur)")
      (let ((join (%thread-join! thread
                                 (%thread-timeout->seconds timeout))))
        (cond
         (join
          ;; We had a timeout
          (if timeout-val?
              timeout-val
              (raise (make-condition &thread-join-timeout))))
         ((%thread-end-exception thread)
          ;; We had an exception in thread. Raise an uncaught-exception
          (let ((old-exception  (%thread-end-exception thread)))
            (raise (make-condition &uncaught-exception
                                   'reason old-exception))))
         (else
          ;; No exception. Return the thread-result
          (%thread-end-result thread))))))

;; **********************************************************************
;;
;;  Mutexes
;;
;; **********************************************************************

(define (mutex-lock! mtx :optional timeout (thread (current-thread)))
  (let ((res (%mutex-lock! mtx (%thread-timeout->seconds timeout) thread)))
    ;; Different cases for res:
    ;;  - The owning thread which is now terminated (a condition must be raised)
    ;;  - #f: we had a timeout
    ;;  - #t: otherwise
    (if (thread? res)
        (make-condition &thread-abandonned-mutex)
        res)))

(define (mutex-unlock! mtx :optional condv timeout)
  (%mutex-unlock! mtx condv timeout))

;; **********************************************************************
;;
;; Conditions
;;
;; **********************************************************************

(%define-condition-type-accessors &thread-join-timeout  &condition
                                  join-timeout-exception?)

(%define-condition-type-accessors &thread-abandonned-mutex  &condition
                                  abandoned-mutex-exception?)

(%define-condition-type-accessors &thread-terminated  &condition
                                  terminated-thread-exception?)


;; The following definitions correspond to the macro-expansion of the form
;;
;;   (define-condition-type &uncaught-exception &condition
;;     &uncaught-exception?
;;     (reason uncaught-exception-reason))
;;
;; Using the macro-expansion avoid the auto-loading of SRFI-35
(define &uncaught-exception (make-condition-type '&uncaught-exception
                                                 &condition
                                                 '(reason)))

(%define-condition-type-accessors &uncaught-exception &condition
                                  uncaught-exception?
                                  (reason uncaught-exception-reason))


#|
<doc EXT join-timeout-exception?
 * (join-timeout-exception? obj)
 *
 * Returns `#t` if |obj| is a _join timeout exception_ object,
 * otherwise returns `#f`.
 *
 * A _join timeout exception_ is raised when thread-join! is called, the timeout
 * is reached and no timeout-val is supplied.
doc>
<doc EXT abandoned-mutex-exception?
 * (abandoned-mutex-exception? obj)
 *
 * Returns `#t` if |obj| is an _abandoned mutex exception_ object,
 * otherwise returns `#f`.
 *
 * An _abandoned mutex exception_ is raised when the current thread locks
 * a mutex that was owned by a thread which terminated ,(see |mutex-lock!|).
doc>
<doc EXT terminated-thread-exception?
 * (terminated-thread-exception? obj)
 *
 * Returns `#t` if |obj| is a _terminated thread exception_ object, otherwise
 * returns `#f`.
 *
 * A _terminated thread exception_ is raised when thread-join! is
 * called and the target thread has terminated as a result of a call to
 * |thread-terminate!|.
doc>
<doc EXT uncaught-exception?
 * (uncaught-exception? obj)
 *
 * Returns `#t` if |obj| is an _uncaught exception_ object, otherwise
 * returns `#f`.
 *
 * An _uncaught exception_ is raised when |thread-join!| is called and the
 * target thread has terminated because it raised an exception that called
 * the initial exception handler of that thread.
doc>
<doc EXT uncaught-exception-reason
 * (uncaught-exception-reason exc)
 *
 * Returns the object which was passed to the initial exception handler
 * of that thread (`exc` must be an _uncaught exception_ object).
doc>
|#
