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

Last change on this file since 13480 was 13480, checked in by Kon Lovett, 11 years ago

Save.

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