source: project/release/5/synch/trunk/synch-open.scm @ 38608

Last change on this file since 38608 was 38608, checked in by Kon Lovett, 3 months ago

add make-exchanger (in only module w/ disable-interrupts), strict-types, style, use symbol-append

File size: 9.3 KB
Line 
1;;;; synch-open.scm
2;;;; Kon Lovett, Dec '18
3
4;; Issues
5;;
6;; - syntax checking is minimal so expansion errors are cryptic
7
8(module synch-open
9
10(;export
11  ;;
12  %synch
13  %synch-lock
14  %synch-unlock
15  ;;
16  %synch-with
17  %call-synch
18  %call-synch-with
19  %apply-synch
20  %apply-synch-with
21  %let-synch-with
22  %set!-synch-with
23  ;;
24  %object-synch-cut-with
25  %record-synch
26  %record-synch-lock
27  %record-synch-unlock
28  ;;
29  define-operation-%synch)
30
31(import scheme)
32(import (chicken base))
33(import (chicken syntax))
34(import (only (srfi 18)
35  thread?
36  make-mutex mutex?
37  mutex-specific mutex-specific-set!
38  mutex-lock! mutex-unlock!
39  mutex-state))
40
41;;; Unprotected
42
43;;
44
45(define-for-syntax (suffix-symbol sym suf)
46  (import-for-syntax (only (chicken base) symbol-append))
47  (symbol-append sym '- suf) )
48
49(define-syntax %synch
50  (syntax-rules ()
51    ;
52    ((%synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
53      (let ((mtx ?mtx))
54        (when (mutex-lock! mtx ?lock-arg0 ...)
55          (call-with-values
56            (lambda ()
57              ?body ...)
58            (lambda ret
59              (mutex-unlock! mtx ?unlock-arg0 ...)
60              (apply values ret))) ) ) )
61    ;
62    ((%synch ?mtx ?body ...)
63      (%synch (?mtx () ()) ?body ...) ) ) )
64
65;;
66
67(define-syntax %synch-with
68  (er-macro-transformer
69    (lambda (frm rnm cmp)
70      (##sys#check-syntax '%synch-with frm '(_ _ variable . _))
71      (let (
72        (_call-with-values (rnm 'call-with-values))
73        (_mutex-specific (rnm 'mutex-specific))
74        (_mutex-lock! (rnm 'mutex-lock!))
75        (_mutex-unlock! (rnm 'mutex-unlock!))
76        (_let (rnm 'let))
77        (_apply (rnm 'apply))
78        (_values (rnm 'values))
79        (_lambda (rnm 'lambda))
80        (_when (rnm 'when))
81        (_ret (rnm 'ret))
82        (mtxvar (rnm (gensym))) )
83        (let (
84          (?mtx (cadr frm))
85          (?var (caddr frm))
86          (?body (cdddr frm)) )
87          (call-with-values
88            (lambda ()
89              (if (not (pair? ?mtx))
90                (values ?mtx '() '())
91                (let (
92                  (mtx (car ?mtx))
93                  (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
94                  (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
95                  (values mtx lock-args unlock-args) ) ) )
96            (lambda (?mtx ?lock-args ?unlock-args)
97              `(,_let ((,mtxvar ,?mtx))
98                (,_let ((,?var (,_mutex-specific ,mtxvar)))
99                  (,_when (,_mutex-lock! ,mtxvar ,@?lock-args)
100                    (,_call-with-values
101                      (,_lambda ()
102                        ,@?body)
103                      (,_lambda ,_ret
104                        (,_mutex-unlock! ,mtxvar ,@?unlock-args)
105                        (,_apply ,_values ,_ret))) ) ) ) ) ) ) ) ) ) )
106
107;;
108
109(define-syntax %call-synch
110  (syntax-rules ()
111    ((%call-synch ?mtx ?proc ?arg0 ...)
112      (%synch ?mtx (?proc ?arg0 ...)) ) ) )
113
114(define-syntax %call-synch-with
115  (syntax-rules ()
116    ((%call-synch-with ?mtx ?proc ?arg0 ...)
117      (%synch-with ?mtx var (?proc var ?arg0 ...)) ) ) )
118
119(define-syntax %apply-synch
120  (syntax-rules ()
121    ((%apply-synch ?mtx ?proc ?arg0 ...)
122      (%synch ?mtx (apply ?proc ?arg0 ...)) ) ) )
123
124(define-syntax %apply-synch-with
125  (syntax-rules ()
126    ((%apply-synch-with ?mtx ?proc ?arg0 ...)
127      (%synch-with ?mtx var (apply ?proc var ?arg0 ...)) ) ) )
128
129(define-syntax %let-synch-with
130  (er-macro-transformer
131    (lambda (frm rnm cmp)
132      (##sys#check-syntax '%let-synch-with frm '(_ list . _))
133      (let ((_%synch-with (rnm '%synch-with)))
134        (let ((?body (cddr frm)))
135          (car
136            (let loop ((?bnds (cadr frm)))
137              (if (null? ?bnds)
138                ?body
139                (let ((bnd (car ?bnds)))
140                  (##sys#check-syntax '%let-synch-with bnd '(variable _))
141                  `((,_%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) ) ) ) ) ) ) ) ) )
142
143(define-syntax %set!-synch-with
144  (er-macro-transformer
145    (lambda (frm rnm cmp)
146      (##sys#check-syntax 'set!-synch-with frm '(_ _ variable . #(_ 0)))
147      (let (
148        (_%synch-with (rnm '%synch-with) )
149        (_mutex-specific (rnm 'mutex-specific) )
150        (_mutex-specific-set! (rnm 'mutex-specific-set!) )
151        (_let (rnm 'let) )
152        (_begin (rnm 'begin) )
153        (mtxvar (rnm (gensym)) ) )
154        (let (
155          (?mtx (cadr frm) )
156          (?var (caddr frm) )
157          (?body (cdddr frm) ) )
158          `(,_let ((,mtxvar ,?mtx))
159             (,_%synch-with ,mtxvar ,?var
160               (,_mutex-specific-set! ,mtxvar (,_begin ,@?body))
161               (,_mutex-specific ,mtxvar) ) ) ) ) ) ) )
162
163;;
164
165(define-syntax %synch-lock
166  (syntax-rules ()
167    ;
168    ((%synch-lock (?mtx (?lock-arg0 ...)) ?body ...)
169      (let ((mtx ?mtx) (ok? #f))
170        (when (mutex-lock! mtx ?lock-arg0 ...)
171          (call-with-values
172            (lambda ()
173              (let ((res (begin ?body ...)))
174                (set! ok? #t)
175                res))
176            (lambda ret
177              (unless ok? (mutex-unlock! mtx))
178              (apply values ret))) ) ) )
179    ;
180    ((%synch-lock ?mtx ?body ...)
181      (%synch-lock (?mtx ()) ?body ...) ) ) )
182
183(define-syntax %synch-unlock
184  (syntax-rules ()
185    ;
186    ((%synch-unlock (?mtx (?unlock-arg0 ...)) ?body ...)
187      (let ((mtx ?mtx))
188        (let ((st (mutex-state mtx)))
189          (if (or (eq 'abandoned st) (eq 'not-abandoned st))
190            (error '%synch-unlock "mutex unlocked" mtx)
191            (call-with-values
192              (lambda ()
193                ?body ...)
194              (lambda ret
195                (mutex-unlock! mtx ?unlock-arg0 ...)
196                (apply values ret)) ) ) ) ) )
197    ;
198    ((%synch-unlock ?mtx ?body ...)
199      (%synch-unlock (?mtx ()) ?body ...) ) ) )
200
201;;
202
203(define-syntax %object-synch-cut-with
204  (er-macro-transformer
205    (lambda (frm rnm cmp)
206      (##sys#check-syntax '%object-synch-cut-with frm '(_ _ . _))
207      (let (
208        (_%synch-with (rnm '%synch-with))
209        (_>< (rnm '><))
210        (var (rnm (gensym)))
211        (mtx (cadr frm)) )
212        (let body-loop ((unparsed (cddr frm)) (parsed '()))
213          (if (null? unparsed)
214            ;code walked
215            `(,_%synch-with ,mtx ,var ,@(reverse parsed))
216            ;walk code
217            (let (
218              (expr (car unparsed))
219              (next (cdr unparsed)) )
220              (let expr-loop ((rest expr) (parsed-expr '()))
221                (cond
222                  ((null? rest)
223                    (body-loop next (cons (reverse parsed-expr) parsed)))
224                  ((pair? rest)
225                    (let (
226                      (arg (car rest))
227                      (next (cdr rest)))
228                      (if (cmp _>< arg)
229                        (expr-loop next (cons var parsed-expr))
230                        (expr-loop next (cons arg parsed-expr)) ) ))
231                  ((cmp _>< rest)
232                    (body-loop next (cons var parsed)))
233                  (else
234                    (body-loop next (cons rest parsed))) ) ) ) ) ) ) ) ) )
235
236;;
237
238(define-for-syntax (record-mutex-name sym) (suffix-symbol sym 'mutex))
239
240;;
241
242(define-syntax %record-synch
243  (er-macro-transformer
244    (lambda (frm rnm cmp)
245      (##sys#check-syntax '%record-synch frm '(_ _ symbol . _))
246      (let (
247        (_let (rnm 'let))
248        (_recvar (rnm 'recvar))
249        (_%synch (rnm '%synch)) )
250        (let (
251          (?rec (cadr frm))
252          (?sym (caddr frm))
253          (?body (cdddr frm)) )
254          `(,_let ((,_recvar ,?rec))
255            (,_%synch (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )
256
257(define-syntax %record-synch-lock
258  (er-macro-transformer
259    (lambda (frm rnm cmp)
260      (##sys#check-syntax '%record-synch-lock frm '(_ _ symbol . _))
261      (let (
262        (_let (rnm 'let))
263        (_recvar (rnm 'recvar))
264        (_%synch-lock (rnm '%synch-lock)) )
265        (let (
266          (?rec (cadr frm))
267          (?sym (caddr frm))
268          (?body (cdddr frm)) )
269          `(,_let ((,_recvar ,?rec))
270            (,_%synch-lock (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )
271
272(define-syntax %record-synch-unlock
273  (er-macro-transformer
274    (lambda (frm rnm cmp)
275      (##sys#check-syntax '%record-synch-unlock frm '(_ _ symbol . _))
276      (let (
277        (_let (rnm 'let))
278        (_recvar (rnm 'recvar))
279        (_%synch-unlock (rnm '%synch-unlock)) )
280        (let (
281          (?rec (cadr frm))
282          (?sym (caddr frm))
283          (?body (cdddr frm)) )
284          `(,_let ((,_recvar ,?rec))
285            (,_%synch-unlock (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )
286
287;;; Synch Object
288
289;;
290
291(define-for-syntax (%synch-wrapper-name sym) (suffix-symbol sym '%synch))
292
293;operand must be the 1st argument
294(define-syntax define-operation-%synch
295  (er-macro-transformer
296    (lambda (frm rnm cmp)
297      (##sys#check-syntax 'define-operation-%synch frm '(_ symbol))
298      (let (
299        (_define (rnm 'define))
300        (_apply (rnm 'apply))
301        (_let (rnm 'let))
302        (_car (rnm 'car))
303        (_cdr (rnm 'cdr))
304        (_if (rnm 'if))
305        (_pair? (rnm 'pair?))
306        (_%synch-with (rnm '%synch-with))
307        (_mtx-w-obj (rnm (gensym 'mtx-w-obj)))
308        (_args (rnm (gensym 'args)))
309        (_obj (rnm (gensym 'obj))) )
310        (let* (
311          (prcnam (cadr frm))
312          (newnam (%synch-wrapper-name prcnam)) )
313          `(,_define (,newnam ,_mtx-w-obj . ,_args)
314            (,_%synch-with ,_mtx-w-obj ,_obj (,_apply ,prcnam ,_obj ,_args)) ) ) ) ) ) )
315
316) ;module synch-open
Note: See TracBrowser for help on using the repository browser.