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

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

Save

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