Delimited-continuation-based suspend-turn, react/suspend, until
This commit is contained in:
parent
5e1518c2bb
commit
3341862f05
|
@ -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))))
|
|
@ -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)))))
|
||||
|
|
|
@ -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)))
|
||||
|
||||
|
|
Loading…
Reference in New Issue