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

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

Release.

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