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

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

Save

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