syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Script suspend and resume

This commit is contained in:
Tony Garnock-Jones 2018-04-09 10:23:22 +01:00
parent bd9dcb61ca
commit 3452f1fe6e
2 changed files with 39 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
syndicate/dataspace.rkt
View File

@ -29,6 +29,7 @@
current-facet
in-script? ;; TODO: shouldn't be provided - inline syntax.rkt??
capture-facet-context ;; TODO: shouldn't be provided - inline syntax.rkt??
suspend-script* ;; TODO: shouldn't be provided - inline syntax.rkt??
add-facet!
stop-facet!
@ -234,7 +235,9 @@
(current-actor)
(exn->string e))
(terminate-actor! ds a))]) ;; TODO: tracing
body ...
(call-with-syndicate-prompt
(lambda ()
body ...))
(void)))))
(define (capture-facet-context proc)
@ -405,7 +408,7 @@
(define eid (generate-id! ds))
(define assertion
(parameterize ((current-dataflow-subject-id (list f eid)))
(assertion-fn)))
(call-with-syndicate-prompt assertion-fn)))
(define ep (endpoint eid assertion assertion-fn handler))
(dataspace-assert! ds assertion)
(when handler (dataspace-subscribe! ds handler))
@ -446,6 +449,40 @@
(ensure-in-script! 'dataspace-spawn!)
(enqueue-action! ds (spawn name boot-proc initial-assertions)))
;;---------------------------------------------------------------------------
;; Script suspend-and-resume.
(define prompt-tag (make-continuation-prompt-tag 'syndicate))
(define (call-with-syndicate-prompt thunk)
(call-with-continuation-prompt thunk prompt-tag))
(define (suspend-script* where proc)
(when (not (in-script?))
(error 'suspend-script
"~a: Cannot suspend script outside script; are you missing an (on ...)?"
where))
(call-with-composable-continuation
(lambda (k)
(abort-current-continuation
prompt-tag
(lambda ()
(define in? (in-script?))
(define raw-resume-parent
(capture-facet-context
(lambda results
(parameterize ((in-script? in?))
(apply k results)))))
(define resume-parent
(lambda results
(push-script! (current-dataspace)
(lambda ()
(apply raw-resume-parent results)))))
(proc resume-parent))))
prompt-tag))
;;---------------------------------------------------------------------------
(module+ test
(message-struct set-box (new-value))
(assertion-struct box-state (value))

44
syndicate/syntax.rkt
View File

@ -561,50 +561,6 @@
;; (define query-result (op query-result args ...)) ...
;; (on-start (flush!) (k (query-result) ...)))))]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Script suspend-and-resume.
(define prompt-tag (make-continuation-prompt-tag 'syndicate))
(define (call-with-syndicate-effects thunk)
(call-with-continuation-prompt thunk prompt-tag))
;; TODO: this is completely bogus -- it's the old Syndicate/rkt implementation. Needs rewriting
(define (suspend-script* where proc)
(when (not (in-script?))
(error 'suspend-script
"~a: Cannot suspend script outside script; are you missing an (on ...)?"
where))
(call-with-composable-continuation
(lambda (k)
(abort-current-continuation
prompt-tag
(lambda ()
(define suspended-f (current-facet))
(define in? (in-script?))
(define stale? #f)
(define raw-resume-parent
(capture-facet-context
(lambda results
(parameterize ((in-script? in?))
(apply k results)))))
(define resume-parent
(lambda results
(when stale? (error 'suspend-script
"Attempt to resume suspension (suspended at ~a) more than once"
where))
(set! stale? #t)
(abort-current-continuation
prompt-tag
(lambda ()
(let ((invoking-f (current-facet)))
(when (not (eq? invoking-f suspended-f))
(terminate-facet! (current-dataspace) invoking-f)))
(push-script! (current-dataspace)
(lambda () (apply raw-resume-parent results)))))))
(proc resume-parent))))
prompt-tag))
(define (send! m)
(dataspace-send! (current-dataspace) m))