Hi all,

to simplify the reviews job wrt the mutex locking fixes I posted the
other day, let me give some more explanations regarding those changes.

I hope this helps a bit.

Best

/Jörg

# What's wrong so far?

Parameter 1:  A memory leak
Parameter 2:  Timeouts will disown the mutex.
Parameter 3:  Mutex-giveaway and unowned locking does not work.

Details:

1. Let's hide 10.000.000 bytes:

------
(use srfi-18)
(define m (make-mutex))
(thread-start!
 (lambda ()
   (mutex-lock! m)
   (mutex-unlock! m)
   (make-string 10000000 #\X)))
(thread-yield!)
(print (string-length (thread-join! (##sys#slot m 2))))
-------

2.  Timeouts  
     
The srfi-18 document suggests a semaphore
implementations (a.k.a. recursive mutex like this one):
      
-------
(use srfi-18)
(define m (make-mutex))
(define (mutex-lock-recursively! mutex . timeout)
  (if (eq? (mutex-state mutex) (current-thread))
      (let ((n (mutex-specific mutex)))
	(mutex-specific-set! mutex (+ n 1)))
      (begin
	(mutex-lock! mutex (and (pair? timeout) (car timeout)))
	(mutex-specific-set! mutex 0))))
(define (mutex-unlock-recursively! mutex)
  (let ((n (mutex-specific mutex)))
    (if (= n 0)
	(mutex-unlock! mutex)
	(mutex-specific-set! mutex (- n 1)))))
(define t1
  (thread-start!
   (lambda ()
     (mutex-lock-recursively! m)
     (thread-sleep! 1)
     (mutex-lock-recursively! m)
     ;; Never reached.  Deadlock before.
     (mutex-unlock-recursively! m)
     (mutex-unlock-recursively! m))))
(thread-yield!)
(mutex-lock-recursively! m 0.05)
(thread-join! t1)
-------

Let's successfully lock a mutex and find the return value #f
indicating a timeout.  (Will print "Failed" even though the mux was
successfully locked.)

-------
(use srfi-18)
(define m (make-mutex))
(mutex-lock! m)
(define t1
  (thread-start!
   (lambda ()
     (if (mutex-lock! m 0.5) 'GotIt 'Failed))))
(thread-yield!)
(mutex-unlock! m)
(print (thread-join! t1))
-------

3. This was documented before, though only for #f as third parameter
to mutex-lock!  However it's rather obvious that it does not matter
much whether a thread or #f is passed.

The problem is that mutex-unlock! does now know anything about the
optional thread/#f parameter.  Thus it can not do the assignment.

#  The old code

Comments at the right side behind the "|" character.  Needs a wide screen.

========================================================================================================================
(define mutex-lock! 
  (lambda (mutex . ms-and-t)
    (##sys#check-structure mutex 'mutex 'mutex-lock!)
    (let* ([limitsup (pair? ms-and-t)]
	   [limit (and limitsup (compute-time-limit (car ms-and-t) 'mutex-lock!))]
	   [threadsup (fx> (length ms-and-t) 1)]
	   [thread (and threadsup (cadr ms-and-t))] )
      (when thread (##sys#check-structure thread 'thread 'mutex-lock!))
      (##sys#call-with-current-continuation
       (lambda (return)
	 (let ([ct ##sys#current-thread])
	   (define (switch)
             (dbg ct " sleeping on mutex " (mutex-name mutex))
	     (##sys#setslot mutex 3 (##sys#append (##sys#slot mutex 3) (list ct)))
	     (##sys#schedule) )
	   (define (check)
	     (when (##sys#slot mutex 4)	; abandoned
	       (return
		(##sys#signal
		 (##sys#make-structure 'condition '(abandoned-mutex-exception) '()))) ) )
	   (dbg ct ": locking " (mutex-name mutex))
	   (cond [(not (##sys#slot mutex 5))						       	       	    
		  (if (and threadsup (not thread))					     | This correctly locks  
		      (begin								     | and assigns the mutex 
			(##sys#setislot mutex 2 #f)					     |			    
			(##sys#setislot mutex 5 #t) )					     | Moved into new local 
		      (let* ([t (or thread ct)]						     | procedure "(assign)"
			     [ts (##sys#slot t 3)] )					     | for reuse.      	   
			(if (or (eq? 'terminated ts) (eq? 'dead ts))			     |
			    (##sys#setislot mutex 4 #t)					     |
			    (begin							     |
			      (##sys#setislot mutex 5 #t)				     |
			      (##sys#setslot t 8 (cons mutex (##sys#slot t 8)))		     |
			      (##sys#setslot t 11 mutex)				     |
			      (##sys#setslot mutex 2 t) ) ) ) )				     |
		  (check)      	       	       	       	       	       	       	       	       	       	      
		  (return #t) ]								 | A bit late, we should not modify the mux before
		 [limit
		  (check)
		  (##sys#setslot
		   ct 1 
		   (lambda ()
		     (##sys#setslot mutex 3 (##sys#delq ct (##sys#slot mutex 3)))	     | done by mutex-unlock! except for timeout	       	       	       
		     (unless (##sys#slot ct 13)  ; not unblocked by timeout							       
		       (##sys#remove-from-timeout-list ct))									       
		     (check)							       	       	       	       	       	       	       
		     (##sys#setslot ct 8 (cons mutex (##sys#slot ct 8)))	       	     | wrong if unblocked by timeout	       
		     (##sys#setslot ct 11 #f)					    					    
		     (##sys#setslot mutex 2 thread)					     | wrong if unblocked by timeout
		     (return #f) ))							     | wrong if mutex was successfully locked 
		  (##sys#thread-block-for-timeout! ct limit)				     				    	      
		  (switch) ]								     				    
		 [else									     				    
		  (##sys#setslot ct 3 'sleeping)					     				    
		  (##sys#setslot ct 11 mutex)						     				    
		  (##sys#setslot ct 1 (lambda () (check) (return #t)))			     				    
		  (switch) ] ) ) ) ) ) ) )						     				    
											     				    
(define mutex-unlock!									     				    
  (lambda (mutex . cvar-and-to)								     				    
    (##sys#check-structure mutex 'mutex 'mutex-unlock!)					     				    
    (let ([ct ##sys#current-thread]							     				    
	  [cvar (and (pair? cvar-and-to) (car cvar-and-to))]				     				    
	  [timeout (and (fx> (length cvar-and-to) 1) (cadr cvar-and-to))] )		     				    
      (dbg ct ": unlocking " (mutex-name mutex))					     				    
      (when cvar									     				    
	(##sys#check-structure cvar 'condition-variable 'mutex-unlock!))		     				    
      (##sys#call-with-current-continuation						     				    
       (lambda (return)									     				    
	 (let ([waiting (##sys#slot mutex 3)]						     				    
	       [limit (and timeout (compute-time-limit timeout 'mutex-unlock!))] )
	   (##sys#setislot mutex 4 #f)	; abandoned
	   (##sys#setislot mutex 5 #f)	; blocked
	   (let ((t (##sys#slot mutex 2)))
	     (when t
	       (##sys#setslot t 8 (##sys#delq mutex (##sys#slot t 8))))) ; unown from owner  | Leaves memory leak - see (1.)
	   (when cvar									     
	     (##sys#setslot cvar 2 (##sys#append (##sys#slot cvar 2) (##sys#list ct)))	     
	     (##sys#setslot ct 11 cvar)	; block object					     
	     (cond (limit								     
		    (##sys#setslot 							     
		     ct 1								     
		     (lambda () 							     
		       (##sys#setslot cvar 2 (##sys#delq ct (##sys#slot cvar 2)))	     
		       (##sys#setslot ct 11 #f) ; block object				     
		       (if (##sys#slot ct 13) ; unblocked by timeout			     
			   (return #f)							     
			   (begin							     
			     (##sys#remove-from-timeout-list ct)			     
			     (return #t))) ) )						     
		    (##sys#thread-block-for-timeout! ct limit) )			     
		   (else								     
		    (##sys#setslot ct 1 (lambda () (return #t)))			     
		    (##sys#setslot ct 3 'sleeping)) ) )					     
	   (unless (null? waiting)							     
	     (let* ([wt (##sys#slot waiting 0)]						     
		    [wts (##sys#slot wt 3)] )						     
	       (##sys#setslot mutex 3 (##sys#slot waiting 1))				     
	       (##sys#setislot mutex 5 #t)						     
	       (when (or (eq? wts 'blocked) (eq? wts 'sleeping))			     
		 (##sys#setslot mutex 2 wt)						     | which thread or #f is
		 (##sys#setslot wt 8 (cons mutex (##sys#slot wt 8)))			     | only know to mutex-lock!
		 (##sys#setslot wt 11 #f)						     			       
		 (when (eq? wts 'sleeping) (##sys#add-to-ready-queue wt) ) ) ) )	     			       
	   (if (eq? (##sys#slot ct 3) 'running)						     			       
	       (return #t)								     			       
	       (##sys#schedule)) ) ) ) ) ))						     			       
========================================================================================================================
											     
# The new code										     
											     
========================================================================================================================
(define mutex-lock! 									     
  (lambda (mutex . ms-and-t)								     
    (##sys#check-structure mutex 'mutex 'mutex-lock!)					     
    (let* ([limitsup (pair? ms-and-t)]							     
	   [limit (and limitsup (compute-time-limit (car ms-and-t) 'mutex-lock!))]	     
	   [threadsup (fx> (length ms-and-t) 1)]					     
	   [thread (and threadsup (cadr ms-and-t))] )					     
      (when thread (##sys#check-structure thread 'thread 'mutex-lock!))			     
      (##sys#call-with-current-continuation						     
       (lambda (return)									     
	 (let ([ct ##sys#current-thread])						     
	   (define (switch)								     
             (dbg ct " sleeping on mutex " (mutex-name mutex))				     
	     (##sys#setslot mutex 3 (##sys#append (##sys#slot mutex 3) (list ct)))	     
	     (##sys#schedule) )								     
	   (define (check)								     
	     (when (##sys#slot mutex 4)	; abandoned					     
	       (return (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) (list (##sys#slot mutex 1))))) ) )
	   (define (assign)								     | Here the lock/assign code. 	       	       	       	
	     (check)									     | First check,    	       	  
	     (if (and threadsup (not thread))						     | rest mostly unchanged   	
		 (begin									     |			    
		   (##sys#setislot mutex 2 #f)						     |			    
		   (##sys#setislot mutex 5 #t) )					     |
		 (let* ([t (or thread ct)]						     |
			[ts (##sys#slot t 3)] )						     |
		   (if (or (eq? 'terminated ts) (eq? 'dead ts))				     |
		       (begin								     |
			 (##sys#setislot mutex 2 #f)					     |
			 (##sys#setislot mutex 5 #f)					     |
       	       	       	 (##sys#setislot mutex 4 #t)					     |
                         (check))      	       	    					     |
		       (begin								     |
			 (##sys#setslot mutex 2 t)					     |
			 (##sys#setislot mutex 5 #t)					     |
			 (##sys#setslot t 8 (cons mutex (##sys#slot t 8))) ) ) ) )	     |
	     (return #t))								     |
	   (dbg ct ": locking " mutex)							     
	   (cond [(not (##sys#slot mutex 5))
		  (assign) ]								     | call the new proc
		 [limit									     			
		  (check)								     			
		  (##sys#setslot							     
		   ct 1 								     
		   (lambda ()								     
		     (if (##sys#slot ct 13)  ; unblocked by timeout			     
			 (begin								      
			   (##sys#setslot mutex 3 (##sys#delq ct (##sys#slot mutex 3)))	     | move here, otherwise mux-unlock did it
			   (return #f))							     | return #f only in this case     	     
			 (begin												  
			   (##sys#remove-from-timeout-list ct)								  
			   (assign))) ))						     | re-use the assignement code
		  (##sys#thread-block-for-timeout! ct limit)
		  (switch) ]
		 [else
		  (##sys#setslot ct 3 'sleeping)
		  (##sys#setslot ct 11 mutex)
		  (##sys#setslot ct 1 assign)						     | re-use the assig-code
		  (switch) ] ) ) ) ) ) ) )						     
											     
(define mutex-unlock!									     
  (lambda (mutex . cvar-and-to)								     
    (##sys#check-structure mutex 'mutex 'mutex-unlock!)					     
    (let ([ct ##sys#current-thread]							     
	  [cvar (and (pair? cvar-and-to) (car cvar-and-to))]				     
	  [timeout (and (fx> (length cvar-and-to) 1) (cadr cvar-and-to))] )		     
      (dbg ct ": unlocking " (mutex-name mutex))					     
      (when cvar									     
	(##sys#check-structure cvar 'condition-variable 'mutex-unlock!))		     
      (##sys#call-with-current-continuation						     
       (lambda (return)									     
	 (let ([waiting (##sys#slot mutex 3)]						     
	       [limit (and timeout (compute-time-limit timeout 'mutex-unlock!))] )	     
	   (##sys#setislot mutex 4 #f)	; abandoned					     
	   (##sys#setislot mutex 5 #f)	; blocked					     
	   (let ((t (##sys#slot mutex 2)))						     
	     (when t									     
	       (##sys#setislot mutex 2 #f)						     
	       (##sys#setslot t 8 (##sys#delq mutex (##sys#slot t 8))))) ; unown from owner  
	   (when cvar									     
	     (##sys#setslot cvar 2 (##sys#append (##sys#slot cvar 2) (##sys#list ct)))	     
	     (##sys#setslot ct 11 cvar)	; block object					     
	     (cond (limit								     
		    (##sys#setslot 							     
		     ct 1								     
		     (lambda ()								     
		       (##sys#setislot ct 11 #f)					     
		       (if (##sys#slot ct 13) ; unblocked by timeout			     
			   (begin							     
			     (##sys#setslot cvar 2 (##sys#delq ct (##sys#slot cvar 2)))	     
			     (return #f))						     
			   (begin							     
			     (##sys#remove-from-timeout-list ct)			     
			     (return #t))) ) )						     
		    (##sys#thread-block-for-timeout! ct limit) )			     
		   (else								     
		    (##sys#setslot ct 1 (lambda () (return #t)))			     
		    (##sys#setslot ct 3 'sleeping)) ) )					     
	   (unless (null? waiting)							     
	     (let* ((wt (##sys#slot waiting 0))						     
		    (wts (##sys#slot wt 3)) )						     
	       (##sys#setslot mutex 3 (##sys#slot waiting 1))				     
	       (##sys#setislot mutex 5 #t)						     | assignment code is gone.
	       (case wts								     
		 ((blocked sleeping)
		  (##sys#setslot wt 11 #f)
		  (##sys#add-to-ready-queue wt))
		 (else
		  (##sys#error 'mutex-unlock "Internal scheduler error: unknown thread state: "
			       wt wts))) ) )
	   (if (eq? (##sys#slot ct 3) 'running)
	       (return #t)
	       (##sys#schedule)) ) ) ) ) ))