Delimited-continuation-based suspend-turn, react/suspend, until

This commit is contained in:
Tony Garnock-Jones 2021-06-11 09:58:26 +02:00
parent 5e1518c2bb
commit 3341862f05
3 changed files with 66 additions and 5 deletions

View File

@ -0,0 +1,24 @@
#lang syndicate
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
(require syndicate/drivers/racket-event)
(require racket/port)
(module+ main
(actor-system/dataspace (ds)
(spawn-racket-event-driver ds)
(spawn
(log-info "Enter a line ~v ~v" this-turn this-facet)
(until ds (message (RacketEvent (read-line-evt (current-input-port)) _))
(on-start (log-info "Waiting"))
(on-stop (log-info "Resuming")))
(log-info "Enter another line ~v ~v" this-turn this-facet)
(until ds (message (RacketEvent (read-line-evt (current-input-port)) _))
(on-start (log-info "Waiting"))
(on-stop (log-info "Resuming")))
(log-info "Enter a third line ~v ~v" this-turn this-facet)
(until ds (message (RacketEvent (read-line-evt (current-input-port)) _))
(on-start (log-info "Waiting"))
(on-stop (log-info "Resuming")))
(log-info "Well done. ~v ~v" this-turn this-facet))))

View File

@ -36,6 +36,7 @@
turn-active-facet
turn-committed?
turn!
suspend-turn
turn-freshen
turn-ref
turn-facet!
@ -277,6 +278,11 @@
;;---------------------------------------------------------------------------
(define prompt-tag (make-continuation-prompt-tag 'syndicate))
(define-syntax-rule (call-with-syndicate-prompt action)
(call-with-continuation-prompt action prompt-tag))
(define (turn-committed? t)
(not (turn-queues t)))
@ -289,10 +295,11 @@
(if (facet-live? f) "" ", dead facet"))
(when (or zombie-turn? (and (not (actor-exit-reason ac)) (facet-live? f)))
(let ((turn (turn (generate-turn-id) f (make-hasheq))))
;; (log-syndicate/actor-debug " ~v" turn)
(with-handlers ([exn? (lambda (e)
(turn! (actor-root ac) (lambda () (actor-terminate! ac e))))])
(parameterize ((current-turn turn))
(action)
(call-with-syndicate-prompt action)
(let loop ()
(dataflow-repair-damage! (actor-dataflow ac) (lambda (action) (action)))
(define pending (reverse (facet-end-of-turn-actions f)))
@ -303,13 +310,33 @@
(for [((ff qq) (in-hash (turn-queues turn)))]
(queue-task! (actor-engine (facet-actor ff))
(lambda () (turn! ff (lambda () (for [(a (in-list (reverse qq)))] (a)))))))
(set-turn-queues! turn #f)))
(set-turn-queues! turn #f))
;; (log-syndicate/actor-debug " ~v" turn)
)
(log-syndicate/actor-debug "end turn ~v\n" f)))
(define (suspend-turn proc)
(define f (turn-active-facet (current-turn)))
(call-with-composable-continuation
(lambda (k)
(abort-current-continuation
prompt-tag
(lambda ()
(proc (lambda results
(with-active-facet f
(lambda ()
;; (log-syndicate/actor-debug "TURN ~v FACET ~v" (current-turn) (turn-active-facet (current-turn)))
(apply k results))))))))
prompt-tag))
(define (with-active-facet f action)
(let ((inner-turn (turn (generate-turn-id) f (turn-queues (current-turn)))))
(parameterize ((current-turn inner-turn)) (action))
(set-turn-queues! inner-turn #f)))
;; (log-syndicate/actor-debug " ENTER ~a ~a" f inner-turn)
(parameterize ((current-turn inner-turn))
(call-with-syndicate-prompt action))
(set-turn-queues! inner-turn #f)
;; (log-syndicate/actor-debug " LEAVE ~a ~a (back to ~a)" f inner-turn (turn-active-facet (current-turn)))
))
(define (turn-enqueue! turn f action)
(define qs (turn-queues turn))
@ -495,4 +522,4 @@
(define (deliver maybe-proc . args)
(when maybe-proc
(apply maybe-proc args)))
(call-with-syndicate-prompt (lambda () (apply maybe-proc args)))))

View File

@ -13,6 +13,8 @@
ref
react
react/suspend
until
define-field
stop-facet
stop-current-facet
@ -150,6 +152,14 @@
(define-syntax-rule (react setup-expr ...)
(turn-facet! this-turn (lambda () setup-expr ...)))
(define-syntax-rule (react/suspend (resume-parent) setup-expr ...)
(suspend-turn (lambda (resume-parent) (react setup-expr ...))))
(define-syntax-rule (until ds event body ...)
(react/suspend (continue)
(at ds (stop-when event (continue (void))))
body ...))
(define-syntax-rule (define-field id initial-value)
(define id (turn-field! this-turn 'id initial-value)))