source: project/release/5/synch/tags/3.3.0/critical-region.scm @ 38609

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

rel 3.3.0

File size: 6.1 KB
Line 
1;;;; critical-region.scm
2;;;; Kon Lovett, Feb '18
3
4;;Issues
5;;
6;;- your kidding?
7
8(declare (disable-interrupts))
9
10(module critical-region
11
12(;export
13  make-exchanger
14  ;
15  interrupts-enabled?
16  ;
17  critical-region-call critical-region-apply
18  %critical-region-call %critical-region-apply
19  critical-region-call* critical-region-apply*
20  %critical-region-call* %critical-region-apply*
21  (critical-region $disable-interrupts$ $enable-interrupts$)
22  (%critical-region $disable-interrupts$ $enable-interrupts$)
23  (critical-region* $disable-interrupts$ $enable-interrupts$)
24  (%critical-region* $disable-interrupts$ $enable-interrupts$))
25
26(import scheme)
27(import (chicken syntax))
28(import (chicken condition))
29(import (chicken foreign))
30
31;;;
32
33;; SRFI-96 Mutual Exclusion
34
35(define (make-exchanger v)
36  (let ((+v+ v))
37    (lambda (x)
38      (let ((v +v+))
39        (set! +v+ x)
40        v ) ) ) )
41
42;;
43
44(define (interrupts-enabled?) (foreign-value "C_interrupts_enabled" bool))
45
46(define $disable-interrupts$ (foreign-lambda* void () "C_disable_interrupts();"))
47(define $enable-interrupts$ (foreign-lambda* void () "C_enable_interrupts();"))
48
49;body can invoke an exit continuation
50(define-syntax critical-region
51  (syntax-rules ()
52    ((critical-region body ...)
53      (dynamic-wind
54        $disable-interrupts$
55        (lambda () body ...)
56        $enable-interrupts$) ) ) )
57
58;body cannot invoke an exit continuation or raise an exception
59;returns the single-valued result
60(define-syntax %critical-region
61  (syntax-rules ()
62    ((%critical-region body ...)
63      (begin
64        ($disable-interrupts$)
65        (let (
66          (res (begin body ...)) )
67          ($enable-interrupts$)
68          res ) ) ) ) )
69
70;body can invoke an exit continuation
71;returns <flag> <result> where
72;flag is #t & result is the single-valued result
73;flag is #f & result is the exception-condition
74(define-syntax critical-region*
75  (syntax-rules ()
76    ((critical-region* body ...)
77      (let* (
78        (flag #t)
79        (res
80          (critical-region
81            (handle-exceptions exn
82              (begin (set! flag #f) (values flag exn))
83              body ...))) )
84        (values flag res) ) ) ) )
85
86;body cannot invoke an exit continuation
87;returns <flag> <result> where
88;flag is #t & result is the single-valued result
89;flag is #f & result is the exception-condition
90(define-syntax %critical-region*
91  (syntax-rules ()
92    ((%critical-region* body ...)
93      (let* (
94        (flag #t)
95        (res
96          (%critical-region
97            (handle-exceptions
98              exn (begin (set! flag #f) (values flag exn))
99              body ...))) )
100        (values flag res) ) ) ) )
101
102;;;
103
104(define (critical-region-apply* proc . rest)
105  (critical-region* (apply proc rest)) )
106
107(define (critical-region-call* thunk)
108  (critical-region* (thunk)) )
109
110(define (critical-region-apply proc . rest)
111  (critical-region (apply proc rest)) )
112
113(define (critical-region-call thunk)
114  (critical-region (thunk)) )
115
116(define (%critical-region-apply* proc . rest)
117  (%critical-region* (apply proc rest)) )
118
119(define (%critical-region-call* thunk)
120  (%critical-region* (thunk)) )
121
122(define (%critical-region-apply proc . rest)
123  (%critical-region (apply proc rest)) )
124
125(define (%critical-region-call thunk)
126  (%critical-region (thunk)) )
127
128) ;module critical-region
129
130#|
131=== Remote Critical Region
132
133==== Usage
134
135<enscript language=scheme>
136(import critical-region)
137</enscript>
138
139==== critical-region-apply
140
141<procedure>(critical-region-apply PROC ARG0 ...) -> *</procedure>
142
143Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may exit via
144continuation.
145
146==== critical-region-call
147
148<procedure>(critical-region-call PROC) -> *</procedure>
149
150Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may exit via continuation.
151
152==== critical-region-apply*
153
154<procedure>(critical-region-apply PROC ARG0 ...) -> boolean *</procedure>
155
156Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may exit via
157continuation.
158
159The first value indicates whether the 2nd value is, {{#t}}, the
160single-valued result, or, {{#f}}, the captured exception condition.
161
162==== critical-region-call*
163
164<procedure>(critical-region-call* PROC) -> boolean *</procedure>
165
166Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may exit via continuation.
167
168==== %critical-region-apply
169
170<procedure>(%critical-region-apply PROC ARG0 ...) -> *</procedure>
171
172Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may '''not'''
173exit via continuation or raise an exception.
174
175==== %critical-region-call
176
177<procedure>(%critical-region-call PROC) -> *</procedure>
178
179Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may '''not''' exit via
180continuation or raise an exception.
181
182==== %critical-region-apply*
183
184<procedure>(%critical-region-apply* PROC ARG0 ...) -> boolean *</procedure>
185
186Evaluates {{(apply PROC ARG0 ...)}} w/o interrupts. {{PROC}} may '''not'''
187exit via continuation.
188
189The first value indicates whether the 2nd value is, {{#t}}, the
190single-valued result, or, {{#f}}, the captured exception condition.
191
192==== %critical-region-call*
193
194<procedure>(%critical-region-call* PROC) -> boolean *</procedure>
195
196Evaluates {{(PROC)}} w/o interrupts. {{PROC}} may '''not''' exit via
197continuation.
198
199The first value indicates whether the 2nd value is, {{#t}}, the
200single-valued result, or, {{#f}}, the captured exception condition.
201
202=== Local Critical Region
203
204==== critical-region
205
206<syntax>(critical-region EXPR ...) -> *</syntax>
207
208Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may exit via continuation.
209
210==== %critical-region
211
212<syntax>(%critical-region EXPR ...) -> *</syntax>
213
214Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may '''not''' exit via
215continuation.
216
217==== critical-region*
218
219<syntax>(critical-region* EXPR ...) -> *</syntax>
220
221Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may exit via continuation.
222
223The first value indicates whether the 2nd value is, {{#t}}, the
224single-valued result, or, {{#f}}, the captured exception condition.
225
226==== %critical-region*
227
228<syntax>(%critical-region* EXPR ...) -> *</syntax>
229
230Evaluates {{EXPR ...}} w/o interrupts. {{EXPR ...}} may '''not''' exit via
231continuation or raise an exception.
232
233The first value indicates whether the 2nd value is, {{#t}}, the
234single-valued result, or, {{#f}}, the captured exception condition.
235|#
Note: See TracBrowser for help on using the repository browser.