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

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

;;; This code is written by Taylor Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

(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)
         (error "placeholder 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))))