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

Last change on this file since 38141 was 38141, checked in by Kon Lovett, 7 months ago

complexify test, fix make-... return

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