;;; -*- mode: scheme; scheme48-package: suspensions -*-

;;;; Rendezvous Concurrency Abstraction
;;;; Thread Suspension in Scheme48

;;; Copyright (c) 2005-2009, Taylor R. Campbell
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; * Redistributions of source code must retain the above copyright
;;;   notice, this list of conditions and the following disclaimer.
;;;
;;; * Redistributions in binary form must reproduce the above copyright
;;;   notice, this list of conditions and the following disclaimer in
;;;   the documentation and/or other materials provided with the
;;;   distribution.
;;;
;;; * Neither the names of the authors nor the names of contributors
;;;   may be used to endorse or promote products derived from this
;;;   software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(define-record-type transaction :transaction
  (make-transaction original-proposal procedure)
  transaction?
  (original-proposal    original-proposal)
  (procedure            transaction-procedure))

(define (enter-critical-region body)
  (let ((proposal (current-proposal)))
    (let loop ()
      (set-current-proposal! (make-proposal))
      (body (make-transaction proposal loop)))))

(define-syntax commit
  (syntax-rules ()
    ((COMMIT transaction committer continuation)
     (COND (committer
            (SET-CURRENT-PROPOSAL! (ORIGINAL-PROPOSAL transaction))
            continuation)
           (ELSE ((TRANSACTION-PROCEDURE transaction)))))))

(define (exit-critical-region transaction continuation)
  (commit transaction (maybe-commit)
          (continuation)))

(define (suspend transaction setup)
  (let* ((cell (make-cell (current-thread)))
         (token (cons cell (new-suspension-uid))))
    (setup (lambda (finalizer composition)
             (make-suspension token finalizer composition)))
    ;; Whoever revives us will set the car of TOKEN to be a value-
    ;; producing thunk.
    (commit transaction (maybe-commit-and-block cell)
            ((car token)))))

(define *suspension-uid* (make-cell 0))

(define (new-suspension-uid)
  (let ((uid (provisional-cell-ref *suspension-uid*)))
    (provisional-cell-set! *suspension-uid* (+ uid 1))
    uid))

(define (reset-suspension-uid)
  (cell-set! *suspension-uid* 0))

(define-record-type suspension :suspension
  (make-suspension token finalizer composition)
  suspension?
  (token        suspension-token)
  (finalizer    suspension-finalizer)
  (composition  suspension-composition))

(define-record-discloser :suspension
  (lambda (suspension)
    (list 'suspension
          (cdr (suspension-token suspension)))))

(define (suspension-revived? suspension)
  (not (cell? (provisional-car (suspension-token suspension)))))

;;;; Reviving Suspended Threads

(define (suspension-reviver queue)
  (define (prepare-revival suspension . vals)
    (let* ((token (suspension-token suspension))
           (cell (provisional-car token)))
      (cond ((cell? cell)               ; Not revived yet.
             (provisional-set-car!
              token
              (let ((composition (suspension-composition suspension)))
                (lambda ()
                  (apply composition vals))))
             (enqueue! queue cell)
             ((suspension-finalizer suspension) prepare-revival)))))
  prepare-revival)

(define (maybe-revive suspension transaction if-revived if-not-revived
                      . vals)
  (let* ((token (suspension-token suspension))
         (maybe-cell (provisional-car token)))
    (cond ((cell? maybe-cell)
           (provisional-set-car!
            token
            (let ((composition (suspension-composition suspension)))
              (lambda ()
                (apply composition vals))))
           (let ((queue (make-queue)))
             (enqueue! queue maybe-cell)
             ((suspension-finalizer suspension)
              (suspension-reviver queue))
             (commit transaction (maybe-commit-and-make-ready queue)
                     (if-revived))))
          (else
           (if-not-revived)))))

(define (revive-multiple enumerate-suspensions transaction
                         continuation)
  (let ((queue (make-queue)))
    (receive results (enumerate-suspensions (suspension-reviver queue))
      (commit transaction (maybe-commit-and-make-ready queue)
              (apply continuation results)))))