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

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

Save.

File size: 10.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 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        (syntax-rules ()
171                [(_ ?binding . ?body) ] ) )
172        (if (pair? ?binding)
173                        (let ([?var (car ?binding)]
174                                                [?mutex (cadr ?binding)])
175                                `(synch-with ,?mutex ,?var
176                                         (mutex-specific-set! ,?mutex (begin ,@?body))
177                                         (mutex-specific ,?mutex) ) )
178                        (syntax-error 'set!/synch "invalid binding form" ?binding) ) )
179
180(define-syntax synch/lock
181        (syntax-rules ()
182                [(_ ?mtx ?body ...)
183                  (let ([mtx ?mtx] [ok? #f])
184                          (dynamic-wind
185                                  (lambda () (mutex-lock! mtx))
186                                  (lambda () (let ([res (begin ?body ...)]) (set! ok? #t) res))
187                                  (lambda () (unless ok? (mutex-unlock! mtx))) ) ) ] ) )
188
189(define-syntax synch/unlock
190        (syntax-rules ()
191                [(_ ?mtx ?body ...)
192                  (let ([mtx ?mtx])
193                          (dynamic-wind
194                                  (lambda ()
195                                          (unless (thread? (mutex-state mtx))
196                                                  (warning 'synch/unlock "mutex is not locked - locking")
197                                                  (mutex-lock! mtx)))
198                                  (lambda () ?body ...)
199                                  (lambda () (mutex-unlock! mtx)) ) ) ] ) )
200
201(define-syntax object/synch
202        (syntax-rules ()
203                [(_ ?mtx ?body ...) ] ) )
204        (let ([?var (gensym)])
205                (let body-loop ([unparsed BODY] [PARSED '()])
206                        (cond [(null? unparsed)
207                                                        `(synch-with ?mtx ,?var ,@(reverse PARSED))]
208                                                [(pair? unparsed)
209                                                        (let ([expr (car unparsed)]
210                                                                                [next (cdr unparsed)])
211                                                                (let expr-loop ([rest expr] [EXPR '()])
212                                                                        (cond [(null? rest)
213                                                                                                        (body-loop next (cons (reverse EXPR) PARSED))]
214                                                                                                [(pair? rest)
215                                                                                                        (let ([arg (car rest)]
216                                                                                                                                [next (cdr rest)])
217                                                                                                                (if (eq? '>< arg)
218                                                                                                                                (expr-loop next (cons ?var EXPR))
219                                                                                                                                (expr-loop next (cons arg EXPR)) ) )]
220                                                                                                [(eq? '>< rest)
221                                                                                                        (body-loop next (cons ?var PARSED))]
222                                                                                                [else
223                                                                                                        (body-loop next (cons rest PARSED))] ) ) )]
224                                                [else
225                                                        (syntax-error 'object/synch "invalid form?body ...)] ) ) ) )
226
227(define-syntax record/synch
228        (syntax-rules ()
229                [(_ ?sym ?rec ?body ...) ] ) )
230        `(synch (,(string->symbol (conc ?sym #\- 'mutex)) ,?rec)
231                ?body ...) )
232
233(define-syntax record-synch/lock
234        (syntax-rules ()
235                [(_ ?sym ?rec ?body ...) ] ) )
236        `(synch/lock (,(string->symbol (conc ?sym #\- 'mutex)) ,?rec)
237                ?body ...) )
238
239(define-syntax record-synch/unlock
240        (syntax-rules ()
241                [(_ ?sym ?rec ?body ...) ] ) )
242        `(synch/unlock (,(string->symbol (conc ?sym #\- 'mutex)) ,?rec)
243                ?body ...) )
244
245;;; Unprotected
246
247(define-syntax %synch-mutex*
248        (syntax-rules ()
249                [(_ ?mtx ?body ...)
250                  (let ([mtx ?mtx])
251        (mutex-lock! mtx)
252                                (call-with-values
253                                        (lambda () ?body ...)
254                                        (lambda ret
255                                                (mutex-unlock! mtx)
256                                                (apply values ret))) ) ] ) )
257
258(define-syntax %synch-mutex-with*
259        (syntax-rules ()
260                [(_ ?mtx ?var ?body ...) ] ) )
261        (let ([RET-?var (gensym)]
262              [?mtx-?var (gensym 'mtx)])
263                `(let ([mtx ?mtx])
264                         (let ([,?var (mutex-specific mtx)])
265                                 (mutex-lock! mtx)
266                                 (call-with-values
267                                         (lambda () ?body ...)
268                                         (lambda ret
269                                                 (mutex-unlock! mtx)
270                                                 (apply values ret))))) ) )
271
272(define-syntax %synch
273        (syntax-rules ()
274                [(_ ?mtx ?body ...) (%synch-mutex* ?mtx ?body ...) ] ) )
275
276(define-syntax %synch-with
277        (syntax-rules ()
278                [(_ ?mtx ?var ?body ...) (%synch-mutex-with* ?mtx ?var ?body ...) ] ) )
279
280(define-syntax %call/synch
281        (syntax-rules ()
282                [(_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (?proc ?arg0 ...)) ] ) )
283
284(define-syntax %call-with/synch
285        (syntax-rules ()
286                [(_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (?proc var ?arg0 ...)) ] ) )
287
288(define-syntax %apply/synch
289        (syntax-rules ()
290                [(_ ?mtx ?proc ?arg0 ...) (%synch-mutex* ?mtx (apply ?proc ?arg0 ...)) ] ) )
291
292(define-syntax %apply-with/synch
293        (syntax-rules ()
294                [(_ ?mtx ?proc ?arg0 ...) (%synch-mutex-with* ?mtx var (apply ?proc var ?arg0 ...)) ] ) )
295
296(define-syntax %let/synch
297        (syntax-rules ()
298                [(_ BINDINGS ?body ...) ] ) )
299        (car (let loop ([bnds BINDINGS])
300         (cond [(null? bnds)
301               ?body ...]
302               [(pair? (car bnds))
303                 (let ([bnd (car bnds)])
304                   (if (pair? bnd)
305                       `((%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr bnds))))
306                       (syntax-error '%let/synch "invalid binding form" bnd) ) )]
307               [else
308                 (syntax-error '%let/synch "invalid binding form" bnds)] ) )) )
309
310(define-syntax %set!/synch
311        (syntax-rules ()
312                [(_ ?binding . ?body) ] ) )
313        (if (pair? ?binding)
314                        (let ([?var (car ?binding)]
315                                                [?mutex (cadr ?binding)])
316                                `(%synch-with ,?mutex ,?var
317                                         (mutex-specific-set! ,?mutex (begin ,@?body))
318                                         (mutex-specific ,?mutex) ) )
319                        (syntax-error '%set!/synch "invalid binding form" ?binding) ) )
320
321(define-syntax %synch/lock
322        (syntax-rules ()
323                [(_ ?mtx ?body ...) ] ) )
324        (let ([RET-?var (gensym)] [?mtx-?var (gensym 'mtx)] [OK-?var (gensym)] [RES-?var (gensym)])
325                `(let ([mtx ?mtx] [ok? #f])
326                        (begin
327                                (mutex-lock! mtx)
328                                (call-with-values
329                                        (lambda () (let ([res (begin ?body ...)]) (set! ok? #t) res))
330                                        (lambda ret
331                                                (unless ok? (mutex-unlock! mtx))
332                                                (apply values ret))) ) ) ) )
333
334(define-syntax %synch/unlock
335        (syntax-rules ()
336                [(_ ?mtx ?body ...) ] ) )
337        (let ([RET-?var (gensym)] [?mtx-?var (gensym 'mtx)])
338                `(let ([mtx ?mtx])
339                         (begin
340                                 (unless (thread? (mutex-state mtx))
341                                         (warning '%synch/unlock "mutex is not locked")
342                                         (mutex-lock! mtx))
343                                 (call-with-values
344                                         (lambda () ?body ...)
345                                         (lambda ret
346                                                 (mutex-unlock! mtx)
347                                                 (apply values ret)) ) ) ) ) )
348
349(define-syntax %object/synch
350        (syntax-rules ()
351                [(_ ?mtx ?body ...) ] ) )
352        (let ([?var (gensym)])
353                (let body-loop ([unparsed BODY] [PARSED '()])
354                        (cond [(null? unparsed)
355                                                        `(%synch-with ?mtx ,?var ,@(reverse PARSED))]
356                                                [(pair? unparsed)
357                                                        (let ([expr (car unparsed)]
358                                                                                [next (cdr unparsed)])
359                                                                (let expr-loop ([rest expr] [EXPR '()])
360                                                                        (cond [(null? rest)
361                                                                                                        (body-loop next (cons (reverse EXPR) PARSED))]
362                                                                                                [(pair? rest)
363                                                                                                        (let ([arg (car rest)]
364                                                                                                                                [next (cdr rest)])
365                                                                                                                (if (eq? '>< arg)
366                                                                                                                                (expr-loop next (cons ?var EXPR))
367                                                                                                                                (expr-loop next (cons arg EXPR)) ) )]
368                                                                                                [(eq? '>< rest)
369                                                                                                        (body-loop next (cons ?var PARSED))]
370                                                                                                [else
371                                                                                                        (body-loop next (cons rest PARSED))] ) ) )]
372                                                [else
373                                                        (syntax-error 'object/synch "invalid form?body ...)] ) ) ) )
374
375(define-syntax %record/synch
376        (syntax-rules ()
377                [(_ ?sym ?rec ?body ...) ] ) )
378        `(%synch (,(string->symbol (conc ?sym #\- 'mutex)) ,?rec)
379                ?body ...) )
380
381(define-syntax %record-synch/lock
382        (syntax-rules ()
383                [(_ ?sym ?rec ?body ...) ] ) )
384        `(%synch/lock (,(string->symbol (conc ?sym #\- 'mutex)) ,?rec)
385                ?body ...) )
386
387(define-syntax %record-synch/unlock
388        (syntax-rules ()
389                [(_ ?sym ?rec ?body ...)
390                  (%synch/unlock (,(string->symbol (conc ?sym #\- 'mutex)) ?rec)
391                    ?body ...) ] ) )
392
393) ;module synch
Note: See TracBrowser for help on using the repository browser.