source: project/release/5/srfi-18/trunk/tests/mutex-test.scm @ 34718

Last change on this file since 34718 was 34718, checked in by sjamaan, 18 months ago

release/5: Replace use by import in eggs

File size: 4.7 KB
Line 
1;;;; mutex-test.scm
2
3(import (chicken format) (chicken time) srfi-18)
4
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))
118
119(cond-expand (dribble
120(define-for-syntax count 0)
121(define-syntax trail
122  (lambda (form r c)                    ; doesn't bother much with renaming
123    (let ((loc (cadr form))
124          (expr (caddr form)))
125      (set! count (add1 count))
126      `(,(r 'begin)
127        (print "(" ,count ") " ,loc ": " ',expr ": get: " (##sys#slot get-mutex 5) ", put: " (##sys#slot put-mutex 5))
128        (let ((xxx ,expr))
129          (print "  (" ,count ") " ,loc ": " ',expr ": get: " (##sys#slot get-mutex 5) ", put: " (##sys#slot put-mutex 5))
130          xxx) ) ))))
131(else (define-syntax trail (syntax-rules () ((_ loc expr) expr)))))
132
133(define (tprint . x)
134 (printf "~a " (current-milliseconds))
135 (apply print x))
136
137(define (make-empty-mailbox)
138 (let ((put-mutex (make-mutex))        ; allow put! operation
139       (get-mutex (make-mutex))
140       (cell #f))
141
142   (define (put! obj)
143     (trail 'put! (mutex-lock! put-mutex #f #f))     ; prevent put! operation
144     (set! cell obj)
145     (trail 'put! (mutex-unlock! get-mutex)) )
146
147   (define (get!)
148     (trail 'get! (mutex-lock! get-mutex #f #f))     ; wait until object in mailbox
149     (let ((result cell))
150       (set! cell #f)                  ; prevent space leaks
151       (trail 'get! (mutex-unlock! put-mutex))       ; allow put! operation
152       result))
153
154   (trail 'main (mutex-lock! get-mutex #f #f))       ; prevent get! operation
155
156   (lambda (print)
157     (case print
158       ((put!) put!)
159       ((get!) get!)
160       (else (error "unknown message"))))))
161
162(define (mailbox-put! m obj) ((m 'put!) obj))
163(define (mailbox-get! m) ((m 'get!)))
164
165;(tprint 'start)
166
167(define mb (make-empty-mailbox))
168
169(thread-start!
170 (make-thread
171 (lambda ()
172   (let lp ()
173     ;(print "1: get")
174     (let ((x (mailbox-get! mb)))
175       ;(tprint "read: " x)
176       (assert x)
177       (lp))))))
178
179(thread-start!
180 (make-thread
181 (lambda ()
182   (thread-sleep! 1)
183   ;(tprint 'put)
184   ;(print "2: put")
185   (mailbox-put! mb 'test)
186   #;(print "2: endput"))))
187
188(thread-sleep! 3)
189;(tprint 'exit)
190
191(if test-has-failed (exit 1) (exit 0))
Note: See TracBrowser for help on using the repository browser.