source: project/release/4/synch/tags/2.0.0/synch.scm

Last change on this file was 13666, checked in by Kon Lovett, 12 years ago

Save.

File size: 13.7 KB
Line 
1;;;; synch.scm
2;;;; Kon Lovett, Mar '06
3
4(declare
5  (usual-integrations)
6  (disable-interrupts)
7  (inline)
8  (fixnum)
9  (local)
10  (no-procedure-checks) )
11
12;;;
13
14(require-library data-structures srfi-18)
15
16;;;
17
18(define-for-syntax (recmuxnam nam)
19  (string->symbol (conc nam #\- 'mutex)) )
20
21;;;
22
23(module synch (;export
24  make-object/synch
25  object?/synch
26  synch
27  synch-with
28  call/synch
29  call-with/synch
30  apply/synch
31  apply-with/synch
32  let/synch
33  set!/synch
34  synch/lock
35  synch/unlock
36  object/synch
37  record/synch
38  record-synch/lock
39  record-synch/unlock
40  %synch-mutex*
41  %synch-mutex-with*
42  %synch
43  %synch-with
44  %call/synch
45  %call-with/synch
46  %apply/synch
47  %apply-with/synch
48  %let/synch
49  %set!/synch
50  %synch/lock
51  %synch/unlock
52  %object/synch
53  %record/synch
54  %record-synch/lock
55  %record-synch/unlock)
56
57(import
58  scheme
59  (only chicken
60    optional  ;due to #!optional implementation
61    void
62    unless
63    warning
64    gensym
65    dynamic-wind)
66  (only data-structures
67    conc
68    constantly)
69  (only srfi-18
70    thread?
71    make-mutex
72    mutex?
73    mutex-specific mutex-specific-set!
74    mutex-lock! mutex-unlock!
75    mutex-state) )
76
77;;;
78
79(define (make-object/synch obj #!optional (name '(synchobj)))
80  (let ((mutex (make-mutex (if (pair? name) (gensym (car name)) name))))
81    (mutex-specific-set! mutex obj)
82    mutex ) )
83
84(define object?/synch
85  (let ((tpred (constantly #t)))
86    (lambda (obj #!optional (pred tpred))
87      (and (mutex? obj)
88           (let ((ms (mutex-specific obj)))
89             (and (not (eq? (void) ms))
90                  (pred ms)) ) ) ) ) )
91
92;;; Protected
93
94(define-syntax synch
95        (syntax-rules ()
96                ((_ ?mtx ?body ...)
97        (let ((mtx ?mtx))
98        (dynamic-wind
99          (lambda () (mutex-lock! mtx))
100          (lambda () ?body ...)
101          (lambda () (mutex-unlock! mtx)) ) ) ) ) )
102
103(define-syntax synch-with
104  (lambda (form r c)
105    (##sys#check-syntax 'synch-with form '(_ _ variable . #(_ 0)))
106    (let (($dynamic-wind (r 'dynamic-wind))
107          ($let (r 'let))
108          ($lambda (r 'lambda))
109          ($mutex-unlock! (r 'mutex-unlock!))
110          ($mutex-specific (r 'mutex-specific))
111          ($mutex-lock! (r 'mutex-lock!))
112          (mtxvar (r (gensym))))
113      (let ((?mtx (cadr form)) (?var (caddr form)) (?body (cdddr form)))
114                    `(,$let ((,mtxvar ,?mtx))
115           (,$let ((,?var (,$mutex-specific ,mtxvar)))
116             (,$dynamic-wind
117               (,$lambda () (,$mutex-lock! ,mtxvar))
118                                             (,$lambda () ,@?body)
119                                             (,$lambda () (,$mutex-unlock! ,mtxvar)) ) ) ) ) ) ) )
120
121(define-syntax call/synch
122        (syntax-rules ()
123                ((_ ?mtx ?proc ?arg0 ...)
124                  (let ((mtx ?mtx))
125                          (dynamic-wind
126                                  (lambda () (mutex-lock! mtx))
127                                  (lambda () (?proc ?arg0 ...))
128                                  (lambda () (mutex-unlock! mtx)) ) ) ) ) )
129
130(define-syntax call-with/synch
131        (syntax-rules ()
132                ((_ ?mtx ?proc ?arg0 ...)
133                  (let ((mtx ?mtx))
134                          (dynamic-wind
135                                  (lambda () (mutex-lock! mtx))
136                                  (lambda () (?proc (mutex-specific mtx) ?arg0 ...))
137                                  (lambda () (mutex-unlock! mtx)) ) ) ) ) )
138
139(define-syntax apply/synch
140        (syntax-rules ()
141                ((_ ?mtx ?proc ?arg0 ...)
142                  (let ((mtx ?mtx))
143                          (dynamic-wind
144                                  (lambda () (mutex-lock! mtx))
145                                  (lambda () (apply ?proc ?arg0 ...))
146                                  (lambda () (mutex-unlock! mtx)) ) ) ) ) )
147
148(define-syntax apply-with/synch
149        (syntax-rules ()
150                ((_ ?mtx ?proc ?arg0 ...)
151                  (let ((mtx ?mtx))
152                          (dynamic-wind
153                                  (lambda () (mutex-lock! mtx))
154                                  (lambda () (apply ?proc (mutex-specific mtx) ?arg0 ...))
155                                  (lambda () (mutex-unlock! mtx)) ) ) ) ) )
156
157(define-syntax let/synch
158  (lambda (form r c)
159    (##sys#check-syntax 'let/synch form '(_ list . _))
160    (let (($synch-with (r 'synch-with)))
161      (let ((?body (cddr form)))
162        (car
163          (let loop ((?bnds (cadr form)))
164            (if (not (null? ?bnds))
165                (let ((bnd (car ?bnds)))
166                  (##sys#check-syntax 'let/synch bnd '(variable _))
167                  `((,$synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) )
168                ?body ) ) ) ) ) ) )
169
170(define-syntax set!/synch
171  (lambda (form r c)
172    (##sys#check-syntax 'set!/synch form '(_ pair . _))
173    (let (($synch-with (r 'synch-with))
174          ($mutex-specific (r 'mutex-specific))
175          ($mutex-specific-set! (r 'mutex-specific-set!))
176          ($begin (r 'begin)))
177      (let ((?bnd (cadr form)) (?body (cddr form)))
178        (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
179          `(,$synch-with ,?mtx ,?var
180             (,$mutex-specific-set! ,?mtx (,$begin ,@?body))
181             (,$mutex-specific ,?mtx) ) ) ) ) ) )
182
183#; ;Since not capturing anything shouldn't need to do this
184(define-syntax synch/lock
185  (lambda (form r c)
186    (##sys#check-syntax 'synch/lock form '(_ _ . _))
187    (let (($dynamic-wind (r 'dynamic-wind))
188          ($unless (r 'unless))
189          ($begin (r 'begin))
190          ($let (r 'let))
191          ($set! (r 'set!))
192          ($lambda (r 'lambda))
193          ($mutex-unlock! (r 'mutex-unlock!))
194          ($mutex-specific (r 'mutex-specific))
195          ($mutex-lock! (r 'mutex-lock!))
196          (mtxvar (r (gensym)))
197          (okvar (r (gensym)))
198          (resvar (r (gensym))))
199      (let ((?mtx (cadr form)) (?body (cddr form)))
200        `(,$let ((,mtxvar ,?mtx) (,okvar #f))
201           (,$dynamic-wind
202             (,$lambda () (,$mutex-lock! ,mtxvar))
203             (,$lambda () (,$let ((,resvar (,$begin ,@?body))) (,$set! ,okvar #t) ,resvar))
204             (,$lambda () (,$unless ,okvar (,$mutex-unlock! ,mtxvar))) ) ) ) ) ) )
205
206(define-syntax synch/lock
207        (syntax-rules ()
208                ((_ ?mtx ?body ...)
209                  (let ((mtx ?mtx) (ok? #f))
210                                (mutex-lock! mtx)
211                                (dynamic-wind
212                                  (lambda () (mutex-lock! mtx))
213                                        (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
214                                        (lambda () (unless ok? (mutex-unlock! mtx)))) ) ) ) )
215
216(define-syntax synch/unlock
217        (syntax-rules ()
218                ((_ ?mtx ?body ...)
219                  (let ((mtx ?mtx))
220                          (dynamic-wind
221                                  (lambda ()
222                                          (unless (thread? (mutex-state mtx))
223                                                  (warning 'synch/unlock "mutex is not locked - locking")
224                                                  (mutex-lock! mtx)))
225                                  (lambda () ?body ...)
226                                  (lambda () (mutex-unlock! mtx)) ) ) ) ) )
227
228(define-syntax object/synch
229  (lambda (form r c)
230    (##sys#check-syntax 'object/synch form '(_ _ . _))
231    (let (($synch-with (r 'synch-with))
232          ($>< (r '><))
233          (var (r (gensym)))
234          (mtx (cadr form)))
235      (let body-loop ((unparsed (cddr form)) (parsed '()))
236        (if (not (null? unparsed))
237            (let ((expr (car unparsed))
238                  (next (cdr unparsed)))
239              (let expr-loop ((rest expr) (parsedexpr '()))
240                (cond ((null? rest)
241                        (body-loop next (cons (reverse parsedexpr) parsed)))
242                      ((pair? rest)
243                        (let ((arg (car rest))
244                              (next (cdr rest)))
245                          (if (c $>< arg)
246                              (expr-loop next (cons var parsedexpr))
247                              (expr-loop next (cons arg parsedexpr)) ) ))
248                      ((c $>< rest)
249                        (body-loop next (cons var parsed)))
250                      (else
251                        (body-loop next (cons rest parsed))) ) ) )
252            `(,$synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )
253
254(define-syntax record/synch
255  (lambda (form r c)
256    (##sys#check-syntax 'record/synch form '(_ symbol _ . _))
257    (let (($synch (r 'synch)))
258      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
259        `(,$synch (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
260
261(define-syntax record-synch/lock
262  (lambda (form r c)
263    (##sys#check-syntax 'record-synch/lock form '(_ symbol _ . _))
264    (let (($synch/lock (r 'synch/lock)))
265      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
266        `(,$synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
267
268(define-syntax record-synch/unlock
269  (lambda (form r c)
270    (##sys#check-syntax 'record-synch/unlock form '(_ symbol _ . _))
271    (let (($synch/unlock (r 'synch/unlock)))
272      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
273        `(,$synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
274
275;;; Unprotected
276
277(define-syntax %synch-mutex*
278        (syntax-rules ()
279                ((_ ?mtx ?body ...)
280                  (let ((mtx ?mtx))
281        (mutex-lock! mtx)
282                                (call-with-values
283                                        (lambda () ?body ...)
284                                        (lambda ret
285                                                (mutex-unlock! mtx)
286                                                (apply values ret))) ) ) ) )
287
288(define-syntax %synch-mutex-with*
289  (lambda (form r c)
290    (##sys#check-syntax '%synch-mutex-with* form '(_ _ variable . _))
291    (let (($call-with-values (r 'call-with-values))
292          ($mutex-specific (r 'mutex-specific))
293          ($mutex-lock! (r 'mutex-lock!))
294          ($mutex-unlock! (r 'mutex-unlock!))
295          ($let (r 'let))
296          ($apply (r 'apply))
297          ($values (r 'values))
298          ($lambda (r 'lambda))
299          ($ret (r 'ret))
300          (mtxvar (r (gensym))))
301      (let ((?mtx (cadr form)) (?var (caddr form)) (?body (cdddr form)))
302        `(,$let ((,mtxvar ,?mtx))
303           (,$let ((,?var (,$mutex-specific ,mtxvar)))
304             (,$mutex-lock! ,mtxvar)
305             (,$call-with-values
306               (,$lambda () ,@?body)
307               (,$lambda ,$ret
308                 (,$mutex-unlock! ,mtxvar)
309                 (,$apply ,$values ,$ret)) ) ) ) ) ) ) )
310
311(define-syntax %synch
312        (syntax-rules ()
313                ((_ ?mtx ?body ...) (%synch-mutex* ?mtx ?body ...) ) ) )
314
315(define-syntax %synch-with
316        (syntax-rules ()
317                ((_ ?mtx ?var ?body ...) (%synch-mutex-with* ?mtx ?var ?body ...) ) ) )
318
319(define-syntax %call/synch
320        (syntax-rules ()
321                ((_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (?proc ?arg0 ...)) ) ) )
322
323(define-syntax %call-with/synch
324        (syntax-rules ()
325                ((_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (?proc var ?arg0 ...)) ) ) )
326
327(define-syntax %apply/synch
328        (syntax-rules ()
329                ((_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (apply ?proc ?arg0 ...)) ) ) )
330
331(define-syntax %apply-with/synch
332        (syntax-rules ()
333                ((_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
334
335(define-syntax %let/synch
336  (lambda (form r c)
337    (##sys#check-syntax '%let/synch form '(_ list . _))
338    (let (($%synch-with (r '%synch-with)))
339      (let ((?body (cddr form)))
340        (car
341          (let loop ((?bnds (cadr form)))
342            (if (not (null? ?bnds))
343                (let ((bnd (car ?bnds)))
344                  (##sys#check-syntax '%let/synch bnd '(variable _))
345                  `((,$%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) )
346                ?body ) ) ) ) ) ) )
347
348(define-syntax %set!/synch
349  (lambda (form r c)
350    (##sys#check-syntax '%set!/synch form '(_ pair . _))
351    (let (($%synch-with (r '%synch-with))
352          ($mutex-specific (r 'mutex-specific))
353          ($mutex-specific-set! (r 'mutex-specific-set!))
354          ($let (r 'let))
355          ($begin (r 'begin))
356          (mtxvar (r (gensym))))
357      (let ((?bnd (cadr form)) (?body (cddr form)))
358        (let ((?var (car ?bnd)) (?mtx (cadr ?bnd)))
359          `(,$let ((,mtxvar ,?mtx))
360             (,$%synch-with ,mtxvar ,?var
361               (,$mutex-specific-set! ,mtxvar (,$begin ,@?body))
362               (,$mutex-specific ,mtxvar) ) ) ) ) ) ) )
363
364(define-syntax %synch/lock
365        (syntax-rules ()
366                ((_ ?mtx ?body ...)
367                  (let ((mtx ?mtx) (ok? #f))
368                                (mutex-lock! mtx)
369                                (call-with-values
370                                        (lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
371                                        (lambda ret
372                                                (unless ok? (mutex-unlock! mtx))
373                                                (apply values ret))) ) ) ) )
374
375(define-syntax %synch/unlock
376        (syntax-rules ()
377                ((_ ?mtx ?body ...)
378      (let ((mtx ?mtx))
379        (unless (thread? (mutex-state mtx))
380          (warning '%synch/unlock "mutex is not locked - locking")
381          (mutex-lock! mtx))
382        (call-with-values
383          (lambda () ?body ...)
384          (lambda ret
385            (mutex-unlock! mtx)
386            (apply values ret)) ) ) ) ) )
387
388(define-syntax %object/synch
389  (lambda (form r c)
390    (##sys#check-syntax '%object/synch form '(_ _ . _))
391    (let (($%synch-with (r '%synch-with))
392          ($>< (r '><))
393          (var (r (gensym)))
394          (mtx (cadr form)))
395      (let body-loop ((unparsed (cddr form)) (parsed '()))
396        (if (not (null? unparsed))
397            (let ((expr (car unparsed))
398                  (next (cdr unparsed)))
399              (let expr-loop ((rest expr) (parsedexpr '()))
400                (cond ((null? rest)
401                        (body-loop next (cons (reverse parsedexpr) parsed)))
402                      ((pair? rest)
403                        (let ((arg (car rest))
404                              (next (cdr rest)))
405                          (if (c $>< arg)
406                              (expr-loop next (cons var parsedexpr))
407                              (expr-loop next (cons arg parsedexpr)) ) ))
408                      ((c $>< rest)
409                        (body-loop next (cons var parsed)))
410                      (else
411                        (body-loop next (cons rest parsed))) ) ) )
412            `(,$%synch-with ,mtx ,var ,@(reverse parsed)) ) ) ) ) )
413
414(define-syntax %record/synch
415  (lambda (form r c)
416    (##sys#check-syntax '%record/synch form '(_ symbol _ . _))
417    (let (($%synch (r '%synch)))
418      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
419        `(,$%synch (,(recmuxnam ?sym) ,?rec) ?body ...) ) ) ) )
420
421(define-syntax %record-synch/lock
422  (lambda (form r c)
423    (##sys#check-syntax '%record-synch/lock form '(_ symbol _ . _))
424    (let (($%synch/lock (r '%synch/lock)))
425      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
426        `(,$%synch/lock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
427
428(define-syntax %record-synch/unlock
429  (lambda (form r c)
430    (##sys#check-syntax '%record-synch/unlock form '(_ symbol _ . _))
431    (let (($%synch/unlock (r '%synch/unlock)))
432      (let ((?sym (cadr form)) (?rec (caddr form)) (?body (cdddr form)))
433        `(,$%synch/unlock (,(recmuxnam ?sym) ,?rec) ,@?body) ) ) ) )
434
435) ;module synch
Note: See TracBrowser for help on using the repository browser.