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

Last change on this file since 38940 was 38940, checked in by Kon Lovett, 5 months ago

add -strict-types, type is interface

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