;;;;
;;;; thread.stk				-- Threads support
;;;;
;;;; Copyright © 2006-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; 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)
;;;; Last file update: 27-May-2011 23:10 (eg)
;;;;
(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.
 * @l
 * ,(bold "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)
			   'clear
			   "    (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
 * ,(ref :mark "make-thread" "uncaught exception") which can finally be
 * trapped when the thread is ,(ref :mark "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 thread-handler-error-show (make-parameter #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>
|#