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

;;;; Rendezvous Concurrency Abstraction
;;;; MIT Scheme Compatibility Definitions

;;; 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.

;;; This ought to be split into several modules, but they would all be
;;; pretty small, and as long as mutually referential modules are
;;; available this is OK.  Make sure that this file is loaded before
;;; any other files in the rendezvous implementation, though, because
;;; it defines important macros.

(declare (usual-integrations))

;;;; Thread Suspension

(define-integrable (enter-critical-region body)
  (body (set-interrupt-enables! interrupt-mask/gc-ok)))

(define-integrable (exit-critical-region interrupt-mask continuation)
  (set-interrupt-enables! interrupt-mask)
  (continuation))

(define (suspend critical-token record-suspension)
  (let ((token (cons (current-thread) (new-suspension-uid))))
    (record-suspension (lambda (finalizer composition)
                         (make-suspension token finalizer composition)))
    (exit-critical-region critical-token
      (lambda ()
        (let loop ()
          (suspend-current-thread)
          (if (thread? (car token))
              (loop)
              ((car token))))))))

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

(set-record-type-unparser-method! <suspension>
  (standard-unparser-method 'SUSPENSION
    (lambda (suspension port)
      (write-char #\space port)
      (write (cdr (suspension-token suspension))
             port))))

(define *suspension-uid* 0)

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

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

(define-integrable (suspension-revived? suspension)
  (not (thread? (car (suspension-token suspension)))))

;;;;; Reviving Suspended Threads

(define (prepare-revival suspension . vals)
  (let* ((token (suspension-token suspension))
         (thread (car token)))
    (if (thread? thread)                ; Not revived yet.
        (%revive thread suspension token vals))))

(define (maybe-revive suspension critical-token
                      if-revived if-not-revived
                      . vals)
  (let* ((token (suspension-token suspension))
         (thread (car token)))
    (cond ((thread? thread)             ; Not revived yet.
           (%revive thread suspension token vals)
           (exit-critical-region critical-token if-revived))
          (else
           (if-not-revived)))))

(define-integrable (%revive thread suspension token vals)
  (set-car! token
            (let ((composition (suspension-composition suspension)))
              (lambda ()
                (apply composition vals))))
  (signal-thread-event thread #t)
  ((suspension-finalizer suspension) prepare-revival))

(define (revive-multiple enumerate-suspensions critical-token
                         continuation)
  (receive vals (enumerate-suspensions prepare-revival)
    (exit-critical-region critical-token
      (lambda ()
        (apply continuation vals)))))

;;;; Time Rendezvous

(define (after-time-rendezvous time-delta)
  (make-time-rendezvous (lambda () time-delta)))

(define (at-real-time-rendezvous time)
  (make-time-rendezvous (lambda () (- time (real-time-clock)))))

(define (make-time-rendezvous compute-revival-delta)
  (polling-rendezvous
   (lambda ()
     (let ((revival-delta (compute-revival-delta)))
       (if (not (positive? revival-delta))
           (values 0 (lambda (prepare-revival)
                       prepare-revival  ;ignore
                       ;; Trivially enabled; no revival.
                       (values)))
           (values #f
                   (lambda (suspension)
                     (register-timer-event
                      revival-delta
                      (lambda ()
                        ;; Even though this is already in a critical
                        ;; region -- interrupts are disabled when
                        ;; events are executed --, because of the way
                        ;; MAYBE-REVIVE is designed we must enter a
                        ;; nested one.
                        (enter-critical-region
                         (lambda (critical-token)
                           (maybe-revive suspension
                                         critical-token
                                         (lambda ()
                                           unspecific)
                                         (lambda ()
                                           unspecific)))))))))))))

;;;; Miscellaneous

(define-syntax define-synchronized-record-type
  (syntax-rules ()
    ((DEFINE-SYNCHRONIZED-RECORD-TYPE name conser sync-fields . more)
     (DEFINE-RECORD-TYPE name conser . more))))

(define (spawn thunk name)
  (let ((thread (create-thread #f thunk)))
    (1d-table/put! (thread/properties thread) 'NAME name)
    thread))

(define (thread/name thread)
  (1d-table/get (thread/properties thread) 'NAME #f))

(define (sleep interval)
  (sleep-current-thread interval))

;;; Unfortunately, MIT Scheme's multiple return value support is
;;; broken, so we have to resort to this crockery.

(define (values . args)
  (if (or (null? args)
          (and (pair? args)
               (pair? (cdr args))))
      (cons multiple-values-tag args)
      (car args)))

(define (call-with-values thunk procedure)
  (let ((result (thunk)))
    (if (and (pair? result)
             (eq? (car result)
                  multiple-values-tag))
        (apply procedure (cdr result))
        (procedure result))))

(define multiple-values-tag (list 'MULTIPLE-VALUES))