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