source: project/release/5/timed-resource/trunk/timed-resource.scm @ 38579

Last change on this file since 38579 was 38579, checked in by Kon Lovett, 6 months ago

add glossn/glossnf to test-gloss, deprecate with-timed-resource

File size: 8.9 KB
Line 
1;;;; timed-resource.scm
2;;;; Kon Lovett, Mar '20
3;;;; Kon Lovett, Jun '17
4;;;; Kon Lovett, Oct '09
5
6;; Issues
7;;
8
9(module timed-resource
10
11(;export
12  timed-resource-shutdown?
13  default-timed-resource-timeout
14  make-timed-resource
15  timed-resource? check-timed-resource error-timed-resource
16  timed-resource-open?
17  timed-resource-name
18  call-with-timed-resource
19  with-timed-resource)
20
21(import scheme)
22(import (chicken base))
23(import (chicken type))
24(import (only (chicken string) ->string))
25(import (only (chicken condition) abort handle-exceptions with-exception-handler))
26(import (only (srfi 1) delete!))
27(import (only (srfi 18) make-thread thread-start! thread-join! thread-sleep!
28  thread-terminate! thread-signal! make-mutex mutex-name
29  terminated-thread-exception? uncaught-exception?))
30(import (only miscmacros let/cc define-parameter))
31(import (only record-variants define-record-type-variant))
32(import (only thread-utils print-exception-error thread-unblock!))
33(import (only thread-reaper thread-reaper-shutdown? thread-reap!))
34(import (only synch-object make-synch-with-object synch-with-object?))
35(import (only synch-dynexn synch-with set!-synch-with record-synch))
36(import (only synch-open %synch-with %set!-synch-with %record-synch))
37(import (only type-checks check-procedure check-number check-positive-number
38  define-check+error-type))
39
40;; Deprecations
41
42(: with-timed-resource (deprecated call-with-timed-resource))
43
44(define with-timed-resource call-with-timed-resource)
45
46;;
47
48(define-inline (->boolean x) (and x #t))
49
50(define-constant DEFAULT-SHUTDOWN-TIMEOUT #f)
51
52(: default-timed-resource-timeout (#!optional (or boolean number) -> (or boolean number)))
53
54(define-parameter default-timed-resource-timeout DEFAULT-SHUTDOWN-TIMEOUT (lambda (x)
55  (and x (check-positive-number 'default-timed-resource-timeout x))))
56
57;;
58
59(define-type timed-resource (struct timed-resource))
60
61(define-constant timed-resource 'timed-resource) ;type tag variable
62(define-record-type-variant timed-resource (unsafe unchecked inline)
63  (%make-timed-resource op cl to mtx th it)
64  %timed-resource?
65  (op @timed-resource-open)
66  (cl @timed-resource-close)
67  (to timed-resource-timeout)
68  (mtx timed-resource-mutex)
69  (th timed-resource-thread timed-resource-thread-set!)
70  (it timed-resource-item timed-resource-item-set!) )
71
72;;
73
74(: check-timed-resource (* * #!rest --> timed-resource))
75
76(define-check+error-type timed-resource %timed-resource?)
77
78(: timed-resource?      (* -> boolean : timed-resource))
79(: timed-resource-name  (timed-resource --> *))
80(: timed-resource-open?  (timed-resource -> boolean))
81
82(define (timed-resource? obj) (%timed-resource? obj))
83(define (timed-resource-name tr)
84  (mutex-name (timed-resource-mutex (check-timed-resource 'timed-resource-name tr))) )
85(define (timed-resource-open? tr)
86  (->boolean (timed-resource-item (check-timed-resource 'timed-resource-open? tr))) )
87
88;; Open & close a Resource
89
90(define (timed-resource-close tr)
91  (let ((res (timed-resource-item tr)))
92    ;Drop the ref just in case the closer blows up
93    (timed-resource-item-set! tr #f)
94    ((@timed-resource-close tr) res) ) )
95
96(define (timed-resource-open! tr)
97  (timed-resource-item-set! tr ((@timed-resource-open tr))) )
98
99;catches & returns exception conditions
100(define (checked-timed-resource-close tr succflag)
101  (let/cc return
102    (with-exception-handler
103      (lambda (exn) (return exn))
104      (lambda () (timed-resource-close tr) succflag))) )
105
106;; Set of timed resources
107
108(define *timed-resources* #f) ;The set of timed resource objects
109(define *shutdown?* #f)       ;Program shutdown?
110
111(define-inline (*timed-resource-shutdown?) (or *shutdown?* (thread-reaper-shutdown?)))
112
113;Cleanly shutdown remaining timed-resources.
114;Cannot use the reaper since it can shutdown before we do!
115
116(define UNBLOCKED-TAG '(timed-resource-unblocked))
117(define CLOSED-TAG '(timed-resource-closed))
118
119;note that the set of timed resource objects is kept only for shutdown
120;processing.
121(define (shutdown-timed-resources!)
122  (set! *shutdown?* #t)
123  (when *timed-resources*
124    (%synch-with *timed-resources* trs
125      ;release every blocked timed-resource and "manually" reap. Note that if
126      ;the tr is still in the list then it is not queued by the reaper!
127      (for-each
128        (lambda (tr)
129          (let ((th (timed-resource-thread tr)))
130            (thread-unblock! th)
131            (thread-signal! th UNBLOCKED-TAG)
132            (thread-join! th (default-timed-resource-timeout)) ) )
133        trs) ) ) )
134
135#; ;UNUSED
136(define (timed-resource-terminate! tr)
137  (let (
138    (th (timed-resource-thread tr)) )
139    (thread-terminate! th)
140    (when (timed-resource-item tr)
141      (let (
142        (res (checked-timed-resource-close tr CLOSED-TAG)) )
143        (unless (eq? CLOSED-TAG res)
144          (print-exception-error res) ) ) )
145    (handle-exceptions exn
146        (cond
147          ((and
148            (uncaught-exception? exn)
149            (terminated-thread-exception? (uncaught-exception-reason exn)))
150            ;expecting so ignore
151            (void) )
152          (else
153            (print-exception-error exn) ) )
154      (thread-join! th) ) ) )
155
156(define (setup-timed-resource)
157  (set! *timed-resources* (make-synch-with-object '() 'timed-resources))
158  (on-exit shutdown-timed-resources!) )
159
160(define (add-timed-resource! tr)
161  (unless *timed-resources* (setup-timed-resource)) ;done once
162  (%set!-synch-with *timed-resources* trs (cons tr trs)) )
163
164(define (remove-timed-resource! tr)
165  (%set!-synch-with *timed-resources* trs (delete! tr trs eq?)) )
166
167;; The timer thread
168
169;returns CLOSED-TAG for success, otherwise an exception object
170(define (release-timed-resource! tr)
171  ;(assert (eq? (current-thread) (timed-resource-thread tr))) ;used only by a tr!
172  ;(can use weaker synch since close catches exceptions)
173  (%record-synch tr timed-resource
174    ;(returns any exception conditions or CLOSED-TAG for success)
175    (let (
176      (res (checked-timed-resource-close tr CLOSED-TAG))
177      (th (timed-resource-thread tr)) )
178      (cond
179        ;when teminating anyway no exceptions but make a note of any problem
180        ((*timed-resource-shutdown?)
181          (unless (eq? CLOSED-TAG res)
182            (print-exception-error res th) )
183          CLOSED-TAG )
184        (else
185          (remove-timed-resource! tr)
186          (thread-reap! th)
187          res ) ) ) ) )
188
189(define ((make-timed-resource-timer-thunk tr))
190  ;We're active
191  (add-timed-resource! tr)
192  ;allow "timeout" seconds of access
193  (handle-exceptions
194    ;as
195    exn
196    ;with
197    (unless (eq? UNBLOCKED-TAG exn) ;early unblock only "handled exception"
198      (abort exn) )
199    ;in
200    (thread-sleep! (timed-resource-timeout tr)) )
201  ;release the resource but propagate any exceptions
202  (let ((res (release-timed-resource! tr)))
203    (unless (eq? CLOSED-TAG res)
204      (abort res) ) ) )
205
206(define (start-timed-resource-timer! tr)
207  (let (
208    (th
209      (make-thread
210        (make-timed-resource-timer-thunk tr)
211        (timed-resource-name tr))) )
212    (timed-resource-thread-set! tr th)
213    (thread-start! th) ) )
214
215;; Get a timed resource
216
217(define (timed-resource-start! tr)
218  ;open resource before starting the timer thread so the overhead doesn't count
219  ;(and any exceptions can propagate in caller's thread)
220  (timed-resource-open! tr)
221  (start-timed-resource-timer! tr) )
222
223;; Get a resource object
224
225(define (timed-resource-aquire tr)
226  (or
227    ;just return resource if already open
228    (timed-resource-item tr)
229    ;otherwise begin a timed open of the resource
230    (begin
231      (timed-resource-start! tr)
232      (timed-resource-item tr) ) ) )
233
234;(string-append (->string name) "-")
235(define (make-timed-resource-name name) (gensym name))
236
237;;;
238
239(: timed-resource-shutdown? (-> boolean))
240(: make-timed-resource (procedure procedure number #!optional * -> timed-resource))
241(: with-timed-resource (timed-resource (* -> *) -> *))
242
243(define (timed-resource-shutdown?) (*timed-resource-shutdown?))
244
245(define (make-timed-resource opener closer timeout #!optional (name 'timed-resource))
246  (and
247    (not (*timed-resource-shutdown?)) ;Shouldn't be necessary
248    (%make-timed-resource
249      (check-procedure 'make-timed-resource opener 'open-procedure)
250      (check-procedure 'make-timed-resource closer 'close-procedure)
251      (check-positive-number 'make-timed-resource timeout 'timeout)
252      (make-mutex (make-timed-resource-name name))
253      #f #f) ) )
254
255#; ;FIXME struct tag (timed-resource) & check-
256(define-syntax use-timed-resource
257  (syntax-rules ()
258    ((use-timed-resource (?tr ?v) ?body ...)
259      (let ((tr (check-timed-resource 'use-timed-resource ?tr)))
260        (unless (timed-resource-shutdown?) ;Shouldn't be necessary
261          (record-synch tr timed-resource
262            (let ((?v (timed-resource-aquire tr)))
263              ?body ...) ) ) ) ) ) )
264
265(define ( call-with-timed-resource tr proc)
266  (check-timed-resource 'with-timed-resource tr)
267  (check-procedure 'with-timed-resource proc)
268  (unless (*timed-resource-shutdown?) ;Shouldn't be necessary
269    (record-synch tr timed-resource (proc (timed-resource-aquire tr))) ) )
270
271) ;module timed-resource
Note: See TracBrowser for help on using the repository browser.