;;; -*- Mode: Scheme -*-

;;;; Rendezvous Concurrency Abstraction
;;;; Placeholders: Single-Assignment Synchronized Cells

;;; 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-synchronized-record-type :placeholder
    (%make-placeholder priority contents)
    (priority contents)
    placeholder?
  (priority placeholder-priority set-placeholder-priority!)
  (contents placeholder-contents set-placeholder-contents!))

(define (make-placeholder) (%make-placeholder #f '()))

(define (placeholder-value placeholder)
  (synchronize (placeholder-value-rendezvous placeholder)))

(define (placeholder-value-rendezvous placeholder)
  (polling-rendezvous
   (lambda ()
     (cond ((placeholder-priority placeholder)
            => (lambda (priority)
                 ;; If the priority is not #F, we have a value, which
                 ;; is stored in the CONTENTS field.  Enable.
                 (set-placeholder-priority! placeholder (+ priority 1))
                 (values priority
                         (lambda (prepare-revival)
                           (set-placeholder-priority! placeholder 1)
                           (placeholder-contents placeholder)))))
           (else
            ;; The priority is #F: we're still waiting for a value, so
            ;; the CONTENTS field is a list of suspensions.  Block; add
            ;; a new suspension to the list.
            (values
             #f
             (lambda (suspension)
               (set-placeholder-contents!
                placeholder
                (cons suspension (placeholder-contents placeholder))))))))))

(define (set-placeholder! placeholder value)
  (enter-critical-region
   (lambda (critical-token)
     (set-placeholder!/critical placeholder value critical-token values))))

(define (set-placeholder!/critical placeholder value critical-token
                                   continuation)
  (cond ((placeholder-priority placeholder)
         (exit-critical-region critical-token
           (lambda ()
             (error "Placeholder is already assigned:" placeholder))))
        (else
         (set-placeholder-priority! placeholder 1)
         (revive-multiple
          (lambda (prepare-revival)
            (let ((waiters (placeholder-contents placeholder)))
              (set-placeholder-contents! placeholder value)
              (for-each (lambda (waiter)
                          (prepare-revival waiter value))
                        (reverse waiters)))
            (values))
          critical-token
          continuation))))