Ticket #1231: mutexlock.patch

File mutexlock.patch, 6.4 KB (added by joergw, 8 years ago)

Patch including test.

  • srfi-18.scm 

    >From b517e5d75e04c96f0ea06d5ae7c322a2a3b39f4d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
 <address@hidden>
Date: Wed, 25 Nov 2015 10:57:33 +0100
Subject: [PATCH] Fix in mutex handling.

So far a thread calling (mutex-lock! <muxtex> #f #f) did own the mutex if, and only if, it had to wait for it.  In consequence those mutexes became abandoned when the calling thread terminates, while the correct state would be locked/not-owned.
---
 srfi-18.scm          | 81 +++++++++++++++++++++++++++-------------------------
 tests/mutex-test.scm | 53 ++++++++++++++++++++++++++++++++++
 2 files changed, 95 insertions(+), 39 deletions(-)

diff --git a/srfi-18.scm b/srfi-18.scm
index 2ae489d..e355e1f 100644
    a b  
    276276             (##sys#schedule) )
    277277           (define (check)
    278278             (when (##sys#slot mutex 4) ; abandoned
    279                (return
    280                 (##sys#signal
    281                  (##sys#make-structure 'condition '(abandoned-mutex-exception) '()))) ) )
    282            (dbg ct ": locking " (mutex-name mutex))
     279               (return (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) (list (##sys#slot mutex 1))))) ) )
     280           (define (assign)
     281             (check)
     282             (if (and threadsup (not thread))
     283                 (begin
     284                   (##sys#setislot mutex 2 #f)
     285                   (##sys#setislot mutex 5 #t) )
     286                 (let* ([t (or thread ct)]
     287                        [ts (##sys#slot t 3)] )
     288                   (if (or (eq? 'terminated ts) (eq? 'dead ts))
     289                       (begin
     290                         (##sys#setislot mutex 2 #f)
     291                         (##sys#setislot mutex 5 #f)
     292                         (##sys#setislot mutex 4 #t))
     293                       (begin
     294                         (##sys#setslot mutex 2 t)
     295                         (##sys#setislot mutex 5 #t)
     296                         (##sys#setslot t 8 (cons mutex (##sys#slot t 8))) ) ) ) )
     297             (return #t))
     298           (dbg ct ": locking " mutex)
    283299           (cond [(not (##sys#slot mutex 5))
    284                   (if (and threadsup (not thread))
    285                       (begin
    286                         (##sys#setislot mutex 2 #f)
    287                         (##sys#setislot mutex 5 #t) )
    288                       (let* ([t (or thread ct)]
    289                              [ts (##sys#slot t 3)] )
    290                         (if (or (eq? 'terminated ts) (eq? 'dead ts))
    291                             (##sys#setislot mutex 4 #t)
    292                             (begin
    293                               (##sys#setislot mutex 5 #t)
    294                               (##sys#setslot t 8 (cons mutex (##sys#slot t 8)))
    295                               (##sys#setslot t 11 mutex)
    296                               (##sys#setslot mutex 2 t) ) ) ) )
    297                   (check)
    298                   (return #t) ]
     300                  (assign) ]
    299301                 [limit
    300302                  (check)
    301303                  (##sys#setslot
    302304                   ct 1
    303305                   (lambda ()
    304                      (##sys#setslot mutex 3 (##sys#delq ct (##sys#slot mutex 3)))
    305                      (unless (##sys#slot ct 13)  ; not unblocked by timeout
    306                        (##sys#remove-from-timeout-list ct))
    307                      (check)
    308                      (##sys#setslot ct 8 (cons mutex (##sys#slot ct 8)))
    309                      (##sys#setslot ct 11 #f)
    310                      (##sys#setslot mutex 2 thread)
    311                      (return #f) ))
     306                     (if (##sys#slot ct 13)  ; unblocked by timeout
     307                         (return #f)
     308                         (begin
     309                           (##sys#remove-from-timeout-list ct)
     310                           (assign))) ))
    312311                  (##sys#thread-block-for-timeout! ct limit)
    313312                  (switch) ]
    314313                 [else
    315314                  (##sys#setslot ct 3 'sleeping)
    316315                  (##sys#setslot ct 11 mutex)
    317                   (##sys#setslot ct 1 (lambda () (check) (return #t)))
     316                  (##sys#setslot ct 1 assign)
    318317                  (switch) ] ) ) ) ) ) ) )
    319318
    320319(define mutex-unlock!
    … …  
    334333           (##sys#setislot mutex 5 #f)  ; blocked
    335334           (let ((t (##sys#slot mutex 2)))
    336335             (when t
     336               (##sys#setislot mutex 2 #f)
    337337               (##sys#setslot t 8 (##sys#delq mutex (##sys#slot t 8))))) ; unown from owner
    338338           (when cvar
    339339             (##sys#setslot cvar 2 (##sys#append (##sys#slot cvar 2) (##sys#list ct)))
    … …  
    341341             (cond (limit
    342342                    (##sys#setslot
    343343                     ct 1
    344                      (lambda ()
    345                        (##sys#setslot cvar 2 (##sys#delq ct (##sys#slot cvar 2)))
    346                        (##sys#setslot ct 11 #f) ; block object
     344                     (lambda ()
     345                       (##sys#setislot ct 11 #f)
    347346                       (if (##sys#slot ct 13) ; unblocked by timeout
    348                            (return #f)
     347                           (begin
     348                             (##sys#setslot cvar 2 (##sys#delq ct (##sys#slot cvar 2)))
     349                             (return #f))
    349350                           (begin
    350351                             (##sys#remove-from-timeout-list ct)
    351352                             (return #t))) ) )
    … …  
    354355                    (##sys#setslot ct 1 (lambda () (return #t)))
    355356                    (##sys#setslot ct 3 'sleeping)) ) )
    356357           (unless (null? waiting)
    357              (let* ([wt (##sys#slot waiting 0)]
    358                     [wts (##sys#slot wt 3)] )
     358             (let* ((wt (##sys#slot waiting 0))
     359                    (wts (##sys#slot wt 3)) )
    359360               (##sys#setslot mutex 3 (##sys#slot waiting 1))
    360361               (##sys#setislot mutex 5 #t)
    361                (when (or (eq? wts 'blocked) (eq? wts 'sleeping))
    362                  (##sys#setslot mutex 2 wt)
    363                  (##sys#setslot wt 8 (cons mutex (##sys#slot wt 8)))
    364                  (##sys#setslot wt 11 #f)
    365                  (when (eq? wts 'sleeping) (##sys#add-to-ready-queue wt) ) ) ) )
     362               (case wts
     363                 ((blocked sleeping)
     364                  (##sys#setslot wt 11 #f)
     365                  (##sys#add-to-ready-queue wt))
     366                 (else
     367                  (##sys#error 'mutex-unlock "Internal scheduler error: unknown thread state: "
     368                               wt wts))) ) )
    366369           (if (eq? (##sys#slot ct 3) 'running)
    367370               (return #t)
    368371               (##sys#schedule)) ) ) ) ) ))

  • tests/mutex-test.scm 

    diff --git a/tests/mutex-test.scm b/tests/mutex-test.scm
index 8962a1e..ed2bfa6 100644
    a b  
    33
    44(require-extension srfi-18)
    55
     6; Make a locked mutex
     7(define mux (make-mutex 'foo))
     8(mutex-lock! mux #f #f)
     9
     10;; Have a thread waiting for it.
     11
     12(define t1
     13  (thread-start!
     14   (lambda ()
     15    (mutex-lock! mux #f #f)
     16    (when (not (eq? (mutex-state mux) 'not-owned))
     17      (print "Got " mux " state " (mutex-state mux) " expected " 'not-owned "\n")
     18      (exit 1)))))
     19
     20;; Give it time to actually wait.
     21
     22(thread-yield!)
     23
     24;; Let it lock the mux
     25
     26(mutex-unlock! mux)
     27
     28(thread-yield!)
     29
     30(or (eq? (mutex-state mux) 'not-owned)
     31    (error "Expected 'not-owned got" (mutex-state mux)))
     32
     33(set! t1
     34  (thread-start!
     35   (lambda ()
     36    (mutex-lock! mux)
     37    (when (not (eq? (mutex-state mux) (current-thread)))
     38      (print "Got " mux " state " (mutex-state mux) " expected " (current-thread) "\n")
     39      (exit 1)))))
     40
     41(mutex-unlock! mux)
     42
     43(thread-yield!)
     44
     45;; check that it is properly abandoned
     46
     47(when (not (handle-exceptions ex (abandoned-mutex-exception? ex) (and (mutex-lock! mux #f) #f)))
     48  (print "Abandoned Mutex not abandoned " mux "\n")
     49  (exit 1))
     50
     51(mutex-unlock! mux)
     52
     53(mutex-lock! mux)
     54
     55(when (not (eq? (mutex-state mux) (current-thread)))
     56  (print "Got " mux " state " (mutex-state mux) " expected " (current-thread) "\n")
     57  (exit 1))
     58
    659(cond-expand (dribble
    760(define-for-syntax count 0)
    861(define-syntax trail