;*=====================================================================*/
;*    serrano/prgm/project/bigloo/fthread/src2.6b/Llib/mutex.scm       */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Mon Feb 18 13:33:50 2002                          */
;*    Last change :  Wed Jun 11 09:52:45 2003 (serrano)                */
;*    Copyright   :  2002-03 Manuel Serrano                            */
;*    -------------------------------------------------------------    */
;*    Bigloo fair mutex                                                */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module __ft_mutex
   
   (import __ft_types
	   __ft_%types
	   __ft_%thread
	   __ft_thread
	   __ft_exception
	   __ft_%exception
	   __ft_scheduler
	   __ft_signal)
   
   (export (make-mutex::mutex . name)
	   
	   (mutex-state ::mutex)
	   (mutex-lock! ::mutex . arg)
	   (mutex-unlock! ::mutex . arg)))

;*---------------------------------------------------------------------*/
;*    make-mutex ...                                                   */
;*---------------------------------------------------------------------*/
(define (make-mutex . name)
   (instantiate::%mutex
      (name (if (pair? name) (car name) (gensym 'mutex)))))

;*---------------------------------------------------------------------*/
;*    object-display ::mutex ...                                       */
;*---------------------------------------------------------------------*/
(define-method (object-display o::mutex . port)
   (with-output-to-port (if (pair? port) (car port) (current-output-port))
      (lambda ()
	 (with-access::mutex o (name)
	    (display* "#<mutex:" name ">")))))

;*---------------------------------------------------------------------*/
;*    object-write ::mutex ...                                         */
;*---------------------------------------------------------------------*/
(define-method (object-write o::mutex . port)
   (with-output-to-port (if (pair? port) (car port) (current-output-port))
      (lambda ()
	 (with-access::%mutex o (name %abandoned %locked)
	    (display* "#<mutex:" name ":"
		      (if %abandoned "abandoned/" "not-abandoned/")
		      (if %locked "locked" "not-locked")
		      ">")))))

;*---------------------------------------------------------------------*/
;*    object-print ::mutex...                                          */
;*---------------------------------------------------------------------*/
(define-method (object-print o::mutex port print-slot)
   (object-write o port))

;*---------------------------------------------------------------------*/
;*    mutex-state ...                                                  */
;*---------------------------------------------------------------------*/
(define (mutex-state m)
   (with-access::%mutex m (%locked %owned %abandoned)
      (cond
	 (%locked (if (thread? %owned) %owned 'not-owned))
	 (%abandoned 'abandoned)
	 (else 'not-abandoned))))

;*---------------------------------------------------------------------*/
;*    mutex-lock! ...                                                  */
;*---------------------------------------------------------------------*/
(define (mutex-lock! m . arg)
   (define (lock! timeout thread)
      (with-access::%mutex m (%locked %owned %abandoned %unlock-signal)
	 ;; the mutex is currently locked, wait for it to unlock
	 (if %locked
	     (if (number? timeout)
		 (thread-await! %unlock-signal timeout)
		 (thread-await! %unlock-signal)))
	 ;; check if the lock is now available
	 (cond
	    (%locked
	     #f)
	    ((not thread)
	     (set! %locked #t)
	     (set! %owned #f)
	     #t)
	    (else
	     (let ((to-raise (and (not %locked) %abandoned)))
		(if (%thread-is-dead thread)
		    (begin
		       (set! %abandoned #t)
		       (set! %locked #f)
		       (set! %owned #f)
		       (if to-raise
			   (raise *abandoned-mutex-exception*)
			   #t))
		    (begin
		       (set! %abandoned #f)
		       (set! %locked #t)
		       (if (and (thread? %owned) (not (eq? %owned thread)))
			   (begin
			      (%thread-del-mutex! %owned m)
			      (set! %owned thread)
			      (%thread-add-mutex! thread m)))
		       (set! %owned thread)
		       (if to-raise
			   (raise *abandoned-mutex-exception*)
			   #t))))))))
   (match-case arg
      ((?timeout ?thread)
       (cond
	  ((and timeout (not (number? timeout)))
	   (bigloo-type-error "mutex-lock!" "integer" timeout))
	  ((and thread (not (thread? thread)))
	   (error "mutex-lock!" "Illegal thread" thread))
	  (else
	   (lock! timeout thread))))
      ((?timeout)
       (if (and timeout (not (number? timeout)))
	   (bigloo-type-error "mutex-lock!" "integer" timeout)
	   (lock! timeout (current-thread))))
      (else
       (lock! #f (current-thread)))))
	 
;*---------------------------------------------------------------------*/
;*    mutex-unlock! ...                                                */
;*---------------------------------------------------------------------*/
(define (mutex-unlock! m . arg)
   (define (unlock! cv timeout)
      (with-access::%mutex m (%abandoned %owned %locked %unlock-signal)
	 (if (thread? %owned) (%thread-del-mutex! %owned m))
	 (set! %owned #f)
	 (set! %locked #f)
	 (broadcast! %unlock-signal) 
	 (let ((t (current-thread)))
	    (if (condition-variable? cv)
		(if (thread? t)
		    (if timeout
			(pair? (thread-await! cv timeout))
			(begin
			   (thread-await! cv)
			   #t))
		    (error "mutex-unlock!" "No current thread" m))
		(if (thread? t)
		    (thread-yield!))))))
   (match-case arg
      ((?cv ?timeout)
       (cond
	  ((not (number? timeout))
	   (bigloo-type-error "mutex-unlock!" "integer" timeout))
	  ((not (condition-variable? cv))
	   (bigloo-type-error "mutex-unlock!" "condition-variable" cv))
	  (else
	   (unlock! cv timeout))))
      ((?cv)
       (if (not (condition-variable? cv))
	   (bigloo-type-error "mutex-unlock!" "condition-variable" cv)
	   (unlock! cv #f)))
      (else
       (unlock! #f #f))))
