source: project/release/4/synch/trunk/synch.scm @ 13482

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

Save.

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