81 lines
2.5 KiB
Racket
81 lines
2.5 KiB
Racket
#lang racket/base
|
|
;; Issue requests in order, process them in any order (or in
|
|
;; parallel), reassemble the ordering at the end.
|
|
|
|
;; What I'm doing here reminded me of the signal-notification
|
|
;; mechanism from [1], but is actually quite different.
|
|
;;
|
|
;; [1] O. Shivers, "Automatic management of operating-system
|
|
;; resources," in Proceedings of the Second ACM SIGPLAN International
|
|
;; Conference on Functional Programming (ICFP '97), 1997, vol. 32,
|
|
;; no. 8, pp. 274-279.
|
|
|
|
(require "functional-queue.rkt")
|
|
(require "conversation.rkt")
|
|
(require racket/class)
|
|
|
|
(provide make-transaction-manager
|
|
|
|
transaction-manager?
|
|
open-transaction
|
|
close-transaction!
|
|
transaction-available?
|
|
dequeue-transaction
|
|
|
|
transaction?
|
|
transaction-context
|
|
transaction-value
|
|
|
|
room-rpc
|
|
room-rpc-finish)
|
|
|
|
(struct transaction-manager (queue) #:transparent)
|
|
|
|
(struct transaction (context
|
|
[value* #:mutable]
|
|
[ready? #:mutable]))
|
|
|
|
(define (make-transaction-manager)
|
|
(transaction-manager (make-queue)))
|
|
|
|
(define (open-transaction manager context)
|
|
(define txn (transaction context #f #f))
|
|
(values txn (transaction-manager (enqueue (transaction-manager-queue manager) txn))))
|
|
|
|
(define (close-transaction! txn value)
|
|
(when (transaction-ready? txn)
|
|
(error 'close-transaction! "Attempt to close previously-closed transaction"))
|
|
(set-transaction-value*! txn value)
|
|
(set-transaction-ready?! txn #t)
|
|
value)
|
|
|
|
(define (transaction-available? manager)
|
|
(if (queue-empty? (transaction-manager-queue manager))
|
|
#f
|
|
(let-values (((txn rest) (dequeue (transaction-manager-queue manager))))
|
|
(transaction-ready? txn))))
|
|
|
|
(define (dequeue-transaction manager)
|
|
(let-values (((txn rest) (dequeue (transaction-manager-queue manager))))
|
|
(values txn (transaction-manager rest))))
|
|
|
|
(define (transaction-value txn)
|
|
(when (not (transaction-ready? txn))
|
|
(error 'transaction-value "Attempt to extract value from unclosed transaction"))
|
|
(transaction-value* txn))
|
|
|
|
(define (room-rpc handle manager message k)
|
|
(define-values (txn new-manager) (open-transaction manager k))
|
|
(send handle say (rpc-request (send handle reply-name) txn message))
|
|
new-manager)
|
|
|
|
(define (room-rpc-finish manager txn message)
|
|
(close-transaction! txn (lambda args (apply (transaction-context txn) message args)))
|
|
(collect-ready-work '() manager))
|
|
|
|
(define (collect-ready-work work manager)
|
|
(if (transaction-available? manager)
|
|
(let-values (((txn rest) (dequeue-transaction manager)))
|
|
(collect-ready-work (cons (transaction-value txn) work) rest))
|
|
(values (reverse work) manager)))
|