Changeset 33191 in project


Ignore:
Timestamp:
02/14/16 15:04:42 (3 years ago)
Author:
sjamaan
Message:

srfi-18: Apply #1231 fix from master to egg. Thanks to Felix Winkelmann and Joerg Wittenberger

Location:
release/5/srfi-18/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/5/srfi-18/trunk/srfi-18.scm

    r32925 r33191  
    11;;;; srfi-18.scm - Simple thread unit - felix
    22;
    3 ; Copyright (c) 2008-2014, The Chicken Team
     3; Copyright (c) 2008-2016, The Chicken Team
    44; Copyright (c) 2000-2007, Felix L. Winkelmann
    55; All rights reserved.
     
    9797        (else (##sys#signal-hook #:type-error loc "invalid timeout argument" tm))))
    9898
     99(define (delq x lst)
     100  (let loop ([lst lst])
     101    (cond ((null? lst) lst)
     102          ((eq? x (##sys#slot lst 0)) (##sys#slot lst 1))
     103          (else (cons (##sys#slot lst 0) (loop (##sys#slot lst 1)))) ) ) )
     104
    99105
    100106;;; Time objects:
     
    318324           (define (switch)
    319325             (dbg ct " sleeping on mutex " (mutex-name mutex))
     326             (##sys#setslot ct 11 mutex)
    320327             (##sys#setslot mutex 3 (##sys#append (##sys#slot mutex 3) (list ct)))
    321328             (##sys#schedule) )
    322329           (define (check)
    323330             (when (##sys#slot mutex 4) ; abandoned
    324                (return
    325                 (##sys#signal
    326                  (##sys#make-structure 'condition '(abandoned-mutex-exception) '()))) ) )
    327            (dbg ct ": locking " (mutex-name mutex))
     331               (return (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) (list (##sys#slot mutex 1))))) ) )
     332           (define (assign)
     333             (##sys#setislot ct 11 #f)
     334             (check)
     335             (if (and threadsup (not thread))
     336                 (begin
     337                   (##sys#setislot mutex 2 #f)
     338                   (##sys#setislot mutex 5 #t) )
     339                 (let* ([t (or thread ct)]
     340                        [ts (##sys#slot t 3)] )
     341                   (if (or (eq? 'terminated ts) (eq? 'dead ts))
     342                       (begin
     343                         (##sys#setislot mutex 2 #f)
     344                         (##sys#setislot mutex 5 #f)
     345                         (##sys#setislot mutex 4 #t)
     346                         (check))
     347                       (begin
     348                         (##sys#setslot mutex 2 t)
     349                         (##sys#setislot mutex 5 #t)
     350                         (##sys#setslot t 8 (cons mutex (##sys#slot t 8))) ) ) ) )
     351             (return #t))
     352           (dbg ct ": locking " mutex)
    328353           (cond [(not (##sys#slot mutex 5))
    329                   (if (and threadsup (not thread))
    330                       (begin
    331                         (##sys#setislot mutex 2 #f)
    332                         (##sys#setislot mutex 5 #t) )
    333                       (let* ([t (or thread ct)]
    334                              [ts (##sys#slot t 3)] )
    335                         (if (or (eq? 'terminated ts) (eq? 'dead ts))
    336                             (##sys#setislot mutex 4 #t)
    337                             (begin
    338                               (##sys#setislot mutex 5 #t)
    339                               (##sys#setslot t 8 (cons mutex (##sys#slot t 8)))
    340                               (##sys#setslot t 11 mutex)
    341                               (##sys#setslot mutex 2 t) ) ) ) )
    342                   (check)
    343                   (return #t) ]
     354                  (assign) ]
    344355                 [limit
    345356                  (check)
     
    347358                   ct 1
    348359                   (lambda ()
    349                      (##sys#setslot mutex 3 (##sys#delq ct (##sys#slot mutex 3)))
    350                      (unless (##sys#slot ct 13)  ; not unblocked by timeout
    351                        (##sys#remove-from-timeout-list ct))
    352                      (check)
    353                      (##sys#setslot ct 8 (cons mutex (##sys#slot ct 8)))
    354                      (##sys#setslot ct 11 #f)
    355                      (##sys#setslot mutex 2 thread)
    356                      (return #f) ))
     360                     (if (##sys#slot ct 13)  ; unblocked by timeout
     361                         (begin
     362                           (##sys#setslot mutex 3 (delq ct (##sys#slot mutex 3)))
     363                           (##sys#setislot ct 11 #f)
     364                           (return #f))
     365                         (begin
     366                           (##sys#remove-from-timeout-list ct)
     367                           (assign))) ))
    357368                  (##sys#thread-block-for-timeout! ct limit)
    358369                  (switch) ]
    359370                 [else
    360371                  (##sys#setslot ct 3 'sleeping)
    361                   (##sys#setslot ct 11 mutex)
    362                   (##sys#setslot ct 1 (lambda () (check) (return #t)))
     372                  (##sys#setslot ct 1 assign)
    363373                  (switch) ] ) ) ) ) ) ) )
    364374
     
    380390           (let ((t (##sys#slot mutex 2)))
    381391             (when t
    382                (##sys#setslot t 8 (##sys#delq mutex (##sys#slot t 8))))) ; unown from owner
     392               (##sys#setislot mutex 2 #f)
     393               (##sys#setslot t 8 (delq mutex (##sys#slot t 8))))) ; unown from owner
    383394           (when cvar
    384395             (##sys#setslot cvar 2 (##sys#append (##sys#slot cvar 2) (##sys#list ct)))
     
    387398                    (##sys#setslot
    388399                     ct 1
    389                      (lambda ()
    390                        (##sys#setslot cvar 2 (##sys#delq ct (##sys#slot cvar 2)))
    391                        (##sys#setslot ct 11 #f) ; block object
     400                     (lambda ()
     401                       (##sys#setislot ct 11 #f)
    392402                       (if (##sys#slot ct 13) ; unblocked by timeout
    393                            (return #f)
     403                           (begin
     404                             (##sys#setslot cvar 2 (delq ct (##sys#slot cvar 2)))
     405                             (return #f))
    394406                           (begin
    395407                             (##sys#remove-from-timeout-list ct)
     
    400412                    (##sys#setslot ct 3 'sleeping)) ) )
    401413           (unless (null? waiting)
    402              (let* ([wt (##sys#slot waiting 0)]
    403                     [wts (##sys#slot wt 3)] )
     414             (let* ((wt (##sys#slot waiting 0))
     415                    (wts (##sys#slot wt 3)) )
    404416               (##sys#setslot mutex 3 (##sys#slot waiting 1))
    405417               (##sys#setislot mutex 5 #t)
    406                (when (or (eq? wts 'blocked) (eq? wts 'sleeping))
    407                  (##sys#setslot mutex 2 wt)
    408                  (##sys#setslot wt 8 (cons mutex (##sys#slot wt 8)))
    409                  (##sys#setslot wt 11 #f)
    410                  (when (eq? wts 'sleeping) (##sys#add-to-ready-queue wt) ) ) ) )
     418               (case wts
     419                 ((blocked sleeping)
     420                  (##sys#setslot wt 11 #f)
     421                  (##sys#add-to-ready-queue wt))
     422                 (else
     423                  (##sys#error 'mutex-unlock "Internal scheduler error: unknown thread state: "
     424                               wt wts))) ) )
    411425           (if (eq? (##sys#slot ct 3) 'running)
    412426               (return #t)
     
    474488        (cond
    475489         ((##sys#structure? blocked 'condition-variable)
    476           (##sys#setslot blocked 2 (##sys#delq thread (##sys#slot blocked 2))))
     490          (##sys#setslot blocked 2 (delq thread (##sys#slot blocked 2))))
    477491         ((##sys#structure? blocked 'mutex)
    478           (##sys#setslot blocked 3 (##sys#delq thread (##sys#slot blocked 3))))
     492          (##sys#setslot blocked 3 (delq thread (##sys#slot blocked 3))))
    479493         ((##sys#structure? blocked 'thread)
    480           (##sys#setslot blocked 12 (##sys#delq thread (##sys#slot blocked 12)))))
     494          (##sys#setslot blocked 12 (delq thread (##sys#slot blocked 12)))))
    481495        (##sys#setslot
    482496         thread 1
  • release/5/srfi-18/trunk/tests/mutex-test.scm

    r31403 r33191  
    11;;;; mutex-test.scm
    22
     3(require-extension srfi-18)
    34
    4 (require-extension srfi-18)
     5(define test-has-failed #f)
     6
     7(define (test-error x . more)
     8  (set! test-has-failed #t)
     9  (apply print x more))
     10
     11(define (test-exit x)
     12  (set! test-has-failed #t)
     13  x)
     14
     15#|  The mutex data structure.
     16
     17Slot  Type                           Meaning
     181     *                              name
     192     (or false (struct thread))     owner
     203     (list-of (struct thread))      waiting thread
     214     boolean                        abandoned
     225     boolean                        blocked
     23
     24|#
     25
     26(define-record-printer (mutex x out)
     27  (format out "<mutex ~a ~a~a ~a (owner ~a) waiting ~a>"
     28          (mutex-name x)
     29          (if (##sys#slot x 5) "LOCKED" "FREE")
     30          (if (##sys#slot x 4) "/ABANDONED" "")
     31          (mutex-state x)
     32          (if (##sys#slot x 2) (##sys#slot x 2) "none")
     33          (##sys#slot x 3)
     34          ))
     35
     36(define (dbg l v)
     37  (format (current-error-port) "D ~a: ~a\n" l v) v)
     38
     39(define mux1 (make-mutex 'test-lock-fail-with-timeout))
     40
     41(mutex-lock! mux1)
     42
     43(define owner1 (mutex-state mux1))
     44
     45(thread-join!
     46 (thread-start!
     47  (lambda ()
     48    (assert (eq? (mutex-lock! mux1 0.1) #f))
     49    (when
     50     (memq (current-thread) (##sys#slot mux1 3))
     51     (print "Got " mux1 " found this thread still waiting!\n")
     52     (test-exit 1))
     53    (when
     54     (not (eq? (mutex-state mux1) owner1))
     55     (print "Got " mux1 " state " (mutex-state mux1) " expected " owner1 "\n")
     56     (test-exit 1)))))
     57
     58(set! mux1 (make-mutex 'unlock-leaves-no-memory-leak))
     59(mutex-lock! mux1)
     60(mutex-unlock! mux1)
     61(when
     62 (not (eq? (##sys#slot mux1 2) #f))
     63 (test-error "thread still held in mutex after unlock: " mux1))
     64
     65;;============
     66; Make a locked mutex
     67(define mux (make-mutex 'foo))
     68(mutex-lock! mux #f #f)
     69
     70;; Have a thread waiting for it.
     71
     72(define t1
     73  (thread-start!
     74   (lambda ()
     75    (mutex-lock! mux #f #f)
     76    (when (not (eq? (mutex-state mux) 'not-owned))
     77      (print "Got " mux " state " (mutex-state mux) " expected " 'not-owned "\n")
     78      (test-exit 1)))))
     79
     80;; Give it time to actually wait.
     81
     82(thread-yield!)
     83
     84;; Let it lock the mux
     85
     86(mutex-unlock! mux)
     87
     88(thread-yield!)
     89
     90(or (eq? (mutex-state mux) 'not-owned)
     91    (test-error "Expected 'not-owned got " (mutex-state mux) mux))
     92
     93(set! t1
     94  (thread-start!
     95   (lambda ()
     96    (mutex-lock! mux)
     97    (when (not (eq? (mutex-state mux) (current-thread)))
     98      (print "Got " mux " state " (mutex-state mux) " expected " (current-thread) "\n")
     99      (test-exit 1)))))
     100
     101(mutex-unlock! mux)
     102
     103(thread-yield!)
     104
     105;; check that it is properly abandoned
     106
     107(when (not (handle-exceptions ex (abandoned-mutex-exception? ex) (and (mutex-lock! mux #f) #f)))
     108  (print "Abandoned Mutex not abandoned " mux "\n")
     109  (test-exit 1))
     110
     111(mutex-unlock! mux)
     112
     113(mutex-lock! mux)
     114
     115(when (not (eq? (mutex-state mux) (current-thread)))
     116  (print "Got " mux " state " (mutex-state mux) " expected " (current-thread) "\n")
     117  (test-exit 1))
    5118
    6119(cond-expand (dribble
     
    75188(thread-sleep! 3)
    76189;(tprint 'exit)
     190
     191(if test-has-failed (exit 1) (exit 0))
Note: See TracChangeset for help on using the changeset viewer.