Compare commits
1 Commits
main
...
tonyg/susp
Author | SHA1 | Date |
---|---|---|
Tony Garnock-Jones | 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-active-facet
|
||||||
turn-committed?
|
turn-committed?
|
||||||
turn!
|
turn!
|
||||||
|
suspend-turn
|
||||||
turn-freshen
|
turn-freshen
|
||||||
turn-ref
|
turn-ref
|
||||||
turn-facet!
|
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)
|
(define (turn-committed? t)
|
||||||
(not (turn-queues t)))
|
(not (turn-queues t)))
|
||||||
|
|
||||||
|
@ -289,10 +295,11 @@
|
||||||
(if (facet-live? f) "" ", dead facet"))
|
(if (facet-live? f) "" ", dead facet"))
|
||||||
(when (or zombie-turn? (and (not (actor-exit-reason ac)) (facet-live? f)))
|
(when (or zombie-turn? (and (not (actor-exit-reason ac)) (facet-live? f)))
|
||||||
(let ((turn (turn (generate-turn-id) f (make-hasheq))))
|
(let ((turn (turn (generate-turn-id) f (make-hasheq))))
|
||||||
|
;; (log-syndicate/actor-debug " ~v" turn)
|
||||||
(with-handlers ([exn? (lambda (e)
|
(with-handlers ([exn? (lambda (e)
|
||||||
(turn! (actor-root ac) (lambda () (actor-terminate! ac e))))])
|
(turn! (actor-root ac) (lambda () (actor-terminate! ac e))))])
|
||||||
(parameterize ((current-turn turn))
|
(parameterize ((current-turn turn))
|
||||||
(action)
|
(call-with-syndicate-prompt action)
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(dataflow-repair-damage! (actor-dataflow ac) (lambda (action) (action)))
|
(dataflow-repair-damage! (actor-dataflow ac) (lambda (action) (action)))
|
||||||
(define pending (reverse (facet-end-of-turn-actions f)))
|
(define pending (reverse (facet-end-of-turn-actions f)))
|
||||||
|
@ -303,13 +310,33 @@
|
||||||
(for [((ff qq) (in-hash (turn-queues turn)))]
|
(for [((ff qq) (in-hash (turn-queues turn)))]
|
||||||
(queue-task! (actor-engine (facet-actor ff))
|
(queue-task! (actor-engine (facet-actor ff))
|
||||||
(lambda () (turn! ff (lambda () (for [(a (in-list (reverse qq)))] (a)))))))
|
(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)))
|
(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)
|
(define (with-active-facet f action)
|
||||||
(let ((inner-turn (turn (generate-turn-id) f (turn-queues (current-turn)))))
|
(let ((inner-turn (turn (generate-turn-id) f (turn-queues (current-turn)))))
|
||||||
(parameterize ((current-turn inner-turn)) (action))
|
;; (log-syndicate/actor-debug " ENTER ~a ~a" f inner-turn)
|
||||||
(set-turn-queues! inner-turn #f)))
|
(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 (turn-enqueue! turn f action)
|
||||||
(define qs (turn-queues turn))
|
(define qs (turn-queues turn))
|
||||||
|
@ -495,4 +522,4 @@
|
||||||
|
|
||||||
(define (deliver maybe-proc . args)
|
(define (deliver maybe-proc . args)
|
||||||
(when maybe-proc
|
(when maybe-proc
|
||||||
(apply maybe-proc args)))
|
(call-with-syndicate-prompt (lambda () (apply maybe-proc args)))))
|
||||||
|
|
|
@ -13,6 +13,8 @@
|
||||||
|
|
||||||
ref
|
ref
|
||||||
react
|
react
|
||||||
|
react/suspend
|
||||||
|
until
|
||||||
define-field
|
define-field
|
||||||
stop-facet
|
stop-facet
|
||||||
stop-current-facet
|
stop-current-facet
|
||||||
|
@ -150,6 +152,14 @@
|
||||||
(define-syntax-rule (react setup-expr ...)
|
(define-syntax-rule (react setup-expr ...)
|
||||||
(turn-facet! this-turn (lambda () 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-syntax-rule (define-field id initial-value)
|
||||||
(define id (turn-field! this-turn 'id initial-value)))
|
(define id (turn-field! this-turn 'id initial-value)))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue