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

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

Save. Has prob w/ '#!optional'. Seen as undefined symbol 'optional'.

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 (
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    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.