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

;;;; timed-resource.scm
;;;; Kon Lovett, Mar '20
;;;; Kon Lovett, Jun '17
;;;; Kon Lovett, Oct '09

;; Issues
;;

(module timed-resource

(;export
  timed-resource-shutdown?
  default-timed-resource-timeout
  make-timed-resource
  timed-resource? check-timed-resource error-timed-resource
  timed-resource-open?
  timed-resource-name
  call-with-timed-resource
  use-timed-resource
  ;deprecated
  with-timed-resource)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (only (chicken string) ->string))
(import (only (chicken condition) abort handle-exceptions with-exception-handler))
(import (only (srfi 1) delete!))
(import (only (srfi 18) make-thread thread-start! thread-join! thread-sleep!
  thread-terminate! thread-signal! make-mutex mutex-name
  terminated-thread-exception? uncaught-exception?))
(import (only miscmacros let/cc define-parameter))
(import (only record-variants define-record-type-variant))
(import (only thread-utils print-exception-error thread-unblock!))
(import (only thread-reaper thread-reaper-shutdown? thread-reap!))
(import (only synch-object make-synch-with-object synch-with-object?))
(import (only synch-dynexn synch-with set!-synch-with record-synch))
(import (only synch-open %synch-with %set!-synch-with %record-synch))
(import (only type-checks check-procedure check-number check-positive-number
  define-check+error-type))

;;

(define-type timed-resource (struct timed-resource))

(: check-timed-resource (* * #!rest --> timed-resource))
(: timed-resource? (* -> boolean : timed-resource))
(: timed-resource-name (timed-resource --> *))
(: timed-resource-open? (timed-resource -> boolean))
(: timed-resource-shutdown? (-> boolean))
(: make-timed-resource (procedure procedure number #!optional * -> timed-resource))
(: call-with-timed-resource (timed-resource (* -> *) -> *))

;;

(define-inline (->boolean x) (and x #t))

(define-constant DEFAULT-SHUTDOWN-TIMEOUT #f)

(: default-timed-resource-timeout (#!optional (or boolean number) -> (or boolean number)))

(define-parameter default-timed-resource-timeout DEFAULT-SHUTDOWN-TIMEOUT (lambda (x)
  (and x (check-positive-number 'default-timed-resource-timeout x))))

;;

(define-constant timed-resource 'timed-resource) ;type tag variable
(define-record-type-variant timed-resource (unsafe unchecked inline)
  (%make-timed-resource op cl to mtx th it)
  %timed-resource?
  (op @timed-resource-open)
  (cl @timed-resource-close)
  (to timed-resource-timeout)
  (mtx timed-resource-mutex)
  (th timed-resource-thread timed-resource-thread-set!)
  (it timed-resource-item timed-resource-item-set!) )

;;

(define-check+error-type timed-resource %timed-resource?)

(define (timed-resource? obj) (%timed-resource? obj))
(define (timed-resource-name tr)
  (mutex-name (timed-resource-mutex (check-timed-resource 'timed-resource-name tr))) )
(define (timed-resource-open? tr)
  (->boolean (timed-resource-item (check-timed-resource 'timed-resource-open? tr))) )

;; Open & close a Resource

(define (timed-resource-close tr)
  (let ((res (timed-resource-item tr)))
    ;Drop the ref just in case the closer blows up
    (timed-resource-item-set! tr #f)
    ((@timed-resource-close tr) res) ) )

(define (timed-resource-open! tr)
  (timed-resource-item-set! tr ((@timed-resource-open tr))) )

;catches & returns exception conditions
(define (checked-timed-resource-close tr succflag)
  (let/cc return
    (with-exception-handler
      (lambda (exn) (return exn))
      (lambda () (timed-resource-close tr) succflag))) )

;; Set of timed resources

(define *timed-resources* #f) ;The set of timed resource objects
(define *shutdown?* #f)       ;Program shutdown?

(define-inline (*timed-resource-shutdown?) (or *shutdown?* (thread-reaper-shutdown?)))

;Cleanly shutdown remaining timed-resources.
;Cannot use the reaper since it can shutdown before we do!

(define UNBLOCKED-TAG '(timed-resource-unblocked))
(define CLOSED-TAG '(timed-resource-closed))

;note that the set of timed resource objects is kept only for shutdown
;processing.
(define (shutdown-timed-resources!)
  (set! *shutdown?* #t)
  (when *timed-resources*
    (%synch-with *timed-resources* trs
      ;release every blocked timed-resource and "manually" reap. Note that if
      ;the tr is still in the list then it is not queued by the reaper!
      (for-each
        (lambda (tr)
          (let ((th (timed-resource-thread tr)))
            (thread-unblock! th)
            (thread-signal! th UNBLOCKED-TAG)
            (thread-join! th (default-timed-resource-timeout)) ) )
        trs) ) ) )

#; ;UNUSED
(define (timed-resource-terminate! tr)
  (let (
    (th (timed-resource-thread tr)) )
    (thread-terminate! th)
    (when (timed-resource-item tr)
      (let (
        (res (checked-timed-resource-close tr CLOSED-TAG)) )
        (unless (eq? CLOSED-TAG res)
          (print-exception-error res) ) ) )
    (handle-exceptions exn
        (cond
          ((and
            (uncaught-exception? exn)
            (terminated-thread-exception? (uncaught-exception-reason exn)))
            ;expecting so ignore
            (void) )
          (else
            (print-exception-error exn) ) )
      (thread-join! th) ) ) )

(define (setup-timed-resource)
  (set! *timed-resources* (make-synch-with-object '() 'timed-resources))
  (on-exit shutdown-timed-resources!) )

(define (add-timed-resource! tr)
  (unless *timed-resources* (setup-timed-resource)) ;done once
  (%set!-synch-with *timed-resources* trs (cons tr trs)) )

(define (remove-timed-resource! tr)
  (%set!-synch-with *timed-resources* trs (delete! tr trs eq?)) )

;; The timer thread

;returns CLOSED-TAG for success, otherwise an exception object
(define (release-timed-resource! tr)
  ;(assert (eq? (current-thread) (timed-resource-thread tr))) ;used only by a tr!
  ;(can use weaker synch since close catches exceptions)
  (%record-synch tr timed-resource
    ;(returns any exception conditions or CLOSED-TAG for success)
    (let (
      (res (checked-timed-resource-close tr CLOSED-TAG))
      (th (timed-resource-thread tr)) )
      (cond
        ;when teminating anyway no exceptions but make a note of any problem
        ((*timed-resource-shutdown?)
          (unless (eq? CLOSED-TAG res)
            (print-exception-error res th) )
          CLOSED-TAG )
        (else
          (remove-timed-resource! tr)
          (thread-reap! th)
          res ) ) ) ) )

(define ((make-timed-resource-timer-thunk tr))
  ;We're active
  (add-timed-resource! tr)
  ;allow "timeout" seconds of access
  (handle-exceptions
    ;as
    exn
    ;with
    (unless (eq? UNBLOCKED-TAG exn) ;early unblock only "handled exception"
      (abort exn) )
    ;in
    (thread-sleep! (timed-resource-timeout tr)) )
  ;release the resource but propagate any exceptions
  (let ((res (release-timed-resource! tr)))
    (unless (eq? CLOSED-TAG res)
      (abort res) ) ) )

(define (start-timed-resource-timer! tr)
  (let (
    (th
      (make-thread
        (make-timed-resource-timer-thunk tr)
        (timed-resource-name tr))) )
    (timed-resource-thread-set! tr th)
    (thread-start! th) ) )

;; Get a timed resource

(define (timed-resource-start! tr)
  ;open resource before starting the timer thread so the overhead doesn't count
  ;(and any exceptions can propagate in caller's thread)
  (timed-resource-open! tr)
  (start-timed-resource-timer! tr) )

;; Get a resource object

(define (timed-resource-aquire tr)
  (or
    ;just return resource if already open
    (timed-resource-item tr)
    ;otherwise begin a timed open of the resource
    (begin
      (timed-resource-start! tr)
      (timed-resource-item tr) ) ) )

;(string-append (->string name) "-")
(define (make-timed-resource-name name) (gensym name))

;;;

(define (timed-resource-shutdown?) (*timed-resource-shutdown?))

(define (make-timed-resource opener closer timeout #!optional (name 'timed-resource))
  (and
    (not (*timed-resource-shutdown?)) ;Shouldn't be necessary
    (%make-timed-resource
      (check-procedure 'make-timed-resource opener 'open-procedure)
      (check-procedure 'make-timed-resource closer 'close-procedure)
      (check-positive-number 'make-timed-resource timeout 'timeout)
      (make-mutex (make-timed-resource-name name))
      #f #f) ) )

(define (call-with-timed-resource tr proc)
  (check-timed-resource 'with-timed-resource tr)
  (check-procedure 'with-timed-resource proc)
  (unless (*timed-resource-shutdown?) ;Shouldn't be necessary
    (record-synch tr timed-resource (proc (timed-resource-aquire tr))) ) )

(define-syntax use-timed-resource
  (syntax-rules ()
    ((use-timed-resource (?tr ?v) ?body ...)
      (call-with-timed-resource ?tr (lambda (?v) ?body ...)) ) ) )

;; Deprecations

(: with-timed-resource (deprecated call-with-timed-resource))
(define with-timed-resource call-with-timed-resource)

) ;module timed-resource