;;;; timed-resource.scm
;;;; Kon Lovett, Oct '09

;; Issues
;;
;; - Uses thread-terminate!

; Chicken Generic Arithmetic!

(module timed-resource

  (;export
    make-timed-resource
    timed-resource?
    timed-resource-name
    with-timed-resource)

  (import scheme
          chicken
          (only srfi-1
            delete!)
          (only srfi-18
            make-thread
            thread-start! thread-join!
            thread-sleep! thread-terminate! thread-signal!
            make-mutex mutex-name
            terminated-thread-exception? uncaught-exception?)
          (only synch
            make-object/synch object?/synch
            synch-with set!/synch record/synch
            %synch-with %set!/synch %record/synch)
          (only type-checks
            check-procedure check-number define-check+error-type)
          (only thread-support
            print-exception-error
            thread-block-timeout? make-thread-timeout
            thread-unblock!)
          (only thread-reaper
            thread-reaper-shutdown? thread-reap!))

  (require-library
    srfi-1 srfi-18
    synch thread-support thread-reaper
    type-checks)

;;

(define-record-type timed-resource
  (*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)

(define (timed-resource-name tr) (mutex-name (timed-resource-mutex tr)))

;; Open & close a Resource

(define (timed-resource-close tr)
  (let ((res (timed-resource-item tr)))
    (timed-resource-item-set! tr #f)
    ((@timed-resource-close tr) res) ) )

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

(define (checked-timed-resource-close tr)
  (handle-exceptions exn
      (print-exception-error exn)
    (timed-resource-close tr) ) )

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

;; Set of timed resources

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

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

(define UNBLOCKED-TAG (make-vector 1 'unblocked))

(define (shutdown-timed-resources!)
  (set! +shutdown?+ #t)
  (when +timed-resources+
    (%synch-with +timed-resources+ trs 
      ; Release every blocked timed-resource
      ; and "manually" reap
      (for-each
        (lambda (tr)
          (let ((th (timed-resource-thread tr)))
            (thread-unblock! th)
            (thread-signal! th UNBLOCKED-TAG)
            (thread-join! th) ) )
        trs) ) ) )

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

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

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

;; The timer thread

(define ((make-timed-resource-timer-thunk tr))
  (let ((early? #f))
    ; We're active
    (add-timed-resource! tr)
    ; Allow "timeout" seconds of access
    (handle-exceptions exn
        ; Unless unblocked early we have a real exception
        (if (eq? UNBLOCKED-TAG exn) (set! early? #t)
            (signal exn) )
      (thread-sleep! (make-thread-timeout (timed-resource-timeout tr))) )
    ; Release the resource (can use weaker synch since close is checked)
    (%record/synch timed-resource tr
      (checked-timed-resource-close tr)
      (unless (or +shutdown?+ (thread-reaper-shutdown?))
        (remove-timed-resource! tr)
        (thread-reap! (timed-resource-thread tr)) ) ) ) )

(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)
  (let ((res (timed-resource-open tr)))
    (start-timed-resource-timer! tr)
    res ) )

;; Get a resource object

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

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

;;;

(define (make-timed-resource opener closer timeout #!optional (name 'timed-resource))
  (unless (or +shutdown?+ (thread-reaper-shutdown?)) ; Shouldn't be necessary
    (check-procedure 'make-timed-resource opener 'open-procedure)
    (check-procedure 'make-timed-resource closer 'close-procedure)
    (check-number 'make-timed-resource timeout 'timeout)
    (*make-timed-resource
      opener closer timeout
      (make-mutex (make-timed-resource-name name))
      #f #f) ) )

(define (with-timed-resource tr proc)
  (unless (or +shutdown?+ (thread-reaper-shutdown?)) ; Shouldn't be necessary
    (check-timed-resource 'with-timed-resource tr)
    (check-procedure 'with-timed-resource proc)
    (record/synch timed-resource tr (proc (timed-resource-aquire tr))) ) )

) ;module timed-resource