2018-04-06 10:37:59 +00:00
|
|
|
#lang racket/base
|
|
|
|
|
2018-04-08 10:44:32 +00:00
|
|
|
(provide make-dataspace ;; TODO: how to cleanly provide this?
|
|
|
|
run-scripts! ;; TODO: how to cleanly provide this?
|
|
|
|
|
|
|
|
message-struct
|
|
|
|
assertion-struct
|
|
|
|
(struct-out observe)
|
|
|
|
|
|
|
|
dataspace?
|
|
|
|
generate-id! ;; TODO: shouldn't be provided - inline syntax.rkt??
|
|
|
|
|
|
|
|
actor?
|
|
|
|
actor-id
|
|
|
|
actor-name
|
|
|
|
|
|
|
|
facet?
|
|
|
|
facet-actor
|
|
|
|
|
|
|
|
field-handle ;; TODO: shouldn't be provided - inline syntax.rkt??
|
|
|
|
field-handle?
|
|
|
|
field-handle-name
|
|
|
|
field-handle-id
|
|
|
|
field-handle-owner
|
|
|
|
field-handle-value
|
|
|
|
|
|
|
|
current-dataspace
|
|
|
|
current-actor
|
|
|
|
current-facet
|
|
|
|
in-script? ;; TODO: shouldn't be provided - inline syntax.rkt??
|
|
|
|
capture-facet-context ;; TODO: shouldn't be provided - inline syntax.rkt??
|
2018-04-09 09:23:22 +00:00
|
|
|
suspend-script* ;; TODO: shouldn't be provided - inline syntax.rkt??
|
2018-04-08 10:44:32 +00:00
|
|
|
|
|
|
|
add-facet!
|
|
|
|
stop-facet!
|
2018-04-19 16:55:52 +00:00
|
|
|
add-stop-script! ;; TODO: shouldn't be provided - inline syntax.rkt??
|
2018-04-08 10:44:32 +00:00
|
|
|
add-endpoint!
|
|
|
|
terminate-facet! ;; TODO: shouldn't be provided - inline syntax.rkt??
|
|
|
|
schedule-script! ;; TODO: shouldn't be provided - inline syntax.rkt??
|
|
|
|
push-script! ;; TODO: shouldn't be provided - inline syntax.rkt??
|
|
|
|
ensure-in-script! ;; TODO: shouldn't be provided - inline syntax.rkt??
|
|
|
|
|
2018-04-11 11:28:09 +00:00
|
|
|
spawn! ;; TODO: should this be provided?
|
|
|
|
enqueue-send! ;; TODO: should this be provided?
|
2018-04-19 16:55:52 +00:00
|
|
|
adhoc-retract! ;; TODO: should this be provided?
|
|
|
|
adhoc-assert! ;; TODO: should this be provided?
|
|
|
|
actor-adhoc-assertions ;; TODO: should this be provided?
|
2018-04-08 10:44:32 +00:00
|
|
|
)
|
2018-04-08 06:39:39 +00:00
|
|
|
|
2018-04-06 10:37:59 +00:00
|
|
|
(require syndicate/functional-queue)
|
|
|
|
(require syndicate/dataflow)
|
|
|
|
(require racket/match)
|
|
|
|
(require racket/set)
|
2018-04-08 10:44:32 +00:00
|
|
|
(require (only-in racket/exn exn->string))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
|
|
|
(module+ test (require rackunit))
|
|
|
|
|
|
|
|
(require "skeleton.rkt")
|
|
|
|
(require "pattern.rkt")
|
|
|
|
(require "bag.rkt")
|
|
|
|
|
2018-04-08 10:44:32 +00:00
|
|
|
;; TODO: move somewhere sensible
|
|
|
|
;; Thin veneers over `struct` for declaring intent.
|
|
|
|
(define-syntax-rule (assertion-struct item ...) (struct item ... #:prefab))
|
|
|
|
(define-syntax-rule (message-struct item ...) (struct item ... #:prefab))
|
|
|
|
|
|
|
|
(assertion-struct observe (specification))
|
|
|
|
|
2018-04-08 06:58:17 +00:00
|
|
|
;; An `ActorID` uniquely identifies an actor in a `Dataspace`.
|
2018-04-08 07:52:37 +00:00
|
|
|
;; A `FID` is a Facet ID, uniquely identifying a facet in a `Dataspace`.
|
2018-04-06 10:37:59 +00:00
|
|
|
|
|
|
|
;; A `Dataspace` is a ... TODO
|
|
|
|
|
|
|
|
;; An `Action` is either `(patch (Deltaof Assertion))` or `(message
|
2018-04-08 06:39:39 +00:00
|
|
|
;; Assertion)` or `(spawn Any BootProc (Set Assertion))`.
|
2018-04-06 10:37:59 +00:00
|
|
|
(struct patch (changes) #:prefab)
|
|
|
|
(struct message (body) #:prefab)
|
2018-04-08 06:39:39 +00:00
|
|
|
(struct spawn (name boot-proc initial-assertions) #:prefab)
|
2018-04-06 10:37:59 +00:00
|
|
|
|
|
|
|
(struct dataspace ([next-id #:mutable] ;; Nat
|
|
|
|
routing-table ;; Skeleton
|
2018-04-19 16:55:52 +00:00
|
|
|
;; v TODO: Caches have to be bags, not sets; once
|
|
|
|
;; this change is made, can I avoid keeping a bag
|
|
|
|
;; of assertions in the dataspace as a whole?
|
2018-04-06 10:37:59 +00:00
|
|
|
assertions ;; (Bagof Assertion)
|
|
|
|
dataflow ;; DataflowGraph
|
2018-04-11 11:28:09 +00:00
|
|
|
[runnable #:mutable] ;; (Listof Actor)
|
2018-04-22 20:02:40 +00:00
|
|
|
[pending-actions #:mutable] ;; (Queueof ActionGroup)
|
2018-04-11 11:28:09 +00:00
|
|
|
) #:transparent)
|
2018-04-06 10:37:59 +00:00
|
|
|
|
2018-04-08 07:52:37 +00:00
|
|
|
(struct actor (id ;; ActorID
|
|
|
|
name ;; Any
|
|
|
|
[root-facet #:mutable] ;; (Option Facet)
|
2018-04-11 11:28:09 +00:00
|
|
|
[runnable? #:mutable] ;; Boolean
|
|
|
|
pending-scripts ;; (MutableVectorof (Queueof (-> Any)))
|
|
|
|
[pending-actions #:mutable] ;; (Queueof Action)
|
2018-04-19 16:55:52 +00:00
|
|
|
;; TODO: consider using a bag, rather than set, of ad-hoc assertions.
|
|
|
|
[adhoc-assertions #:mutable] ;; (Setof Assertion)
|
2018-04-08 07:52:37 +00:00
|
|
|
)
|
|
|
|
#:methods gen:custom-write
|
|
|
|
[(define (write-proc a p mode)
|
|
|
|
(fprintf p "#<actor ~a ~v>" (actor-id a) (actor-name a)))])
|
|
|
|
|
2018-04-22 20:02:40 +00:00
|
|
|
(struct action-group (actor ;; (U Actor 'meta)
|
|
|
|
actions ;; (Listof Action)
|
|
|
|
)
|
|
|
|
#:transparent)
|
|
|
|
|
2018-04-08 07:52:37 +00:00
|
|
|
(struct facet (id ;; FID
|
|
|
|
[live? #:mutable] ;; Boolean
|
|
|
|
actor ;; Actor
|
|
|
|
parent ;; (Option Facet)
|
2018-04-06 10:37:59 +00:00
|
|
|
endpoints ;; (MutableHash EID Endpoint)
|
|
|
|
[stop-scripts #:mutable] ;; (Listof Script) -- IN REVERSE ORDER
|
2018-04-08 07:52:37 +00:00
|
|
|
[children #:mutable] ;; (Seteqof Facet)
|
2018-04-06 10:37:59 +00:00
|
|
|
)
|
2018-04-08 07:52:37 +00:00
|
|
|
#:methods gen:custom-write
|
|
|
|
[(define (write-proc f p mode)
|
2018-04-22 20:00:35 +00:00
|
|
|
(local-require (only-in racket/string string-join))
|
|
|
|
(define (facet-id-chain f)
|
|
|
|
(if f
|
|
|
|
(cons (number->string (facet-id f)) (facet-id-chain (facet-parent f)))
|
|
|
|
'()))
|
2018-04-08 07:52:37 +00:00
|
|
|
(fprintf p "#<facet ~a ~v ~a>"
|
|
|
|
(actor-id (facet-actor f))
|
|
|
|
(actor-name (facet-actor f))
|
2018-04-22 20:00:35 +00:00
|
|
|
(string-join (facet-id-chain f) ":")))])
|
2018-04-06 10:37:59 +00:00
|
|
|
|
|
|
|
(struct endpoint (id ;; EID
|
|
|
|
[assertion #:mutable] ;; Assertion
|
|
|
|
assertion-fn ;; (-> Assertion)
|
|
|
|
handler ;; (Option SkInterest)
|
|
|
|
)
|
2018-04-08 07:52:37 +00:00
|
|
|
#:methods gen:custom-write
|
|
|
|
[(define (write-proc e p mode)
|
|
|
|
(fprintf p "#<endpoint ~a>" (endpoint-id e)))])
|
2018-04-06 10:37:59 +00:00
|
|
|
|
2018-04-08 10:44:32 +00:00
|
|
|
;; TODO: the field ownership checks during field-ref/field-set! might
|
|
|
|
;; be quite expensive. Are they worth it?
|
2018-04-06 10:37:59 +00:00
|
|
|
(struct field-handle (name ;; Symbol
|
|
|
|
id ;; Nat
|
2018-04-08 07:52:37 +00:00
|
|
|
owner ;; Actor
|
2018-04-06 10:37:59 +00:00
|
|
|
[value #:mutable] ;; Any
|
|
|
|
)
|
|
|
|
#:methods gen:custom-write
|
|
|
|
[(define (write-proc f port mode)
|
|
|
|
(fprintf port "#<field-handle:~a:~a>" (field-handle-name f) (field-handle-id f)))]
|
|
|
|
#:property prop:procedure
|
|
|
|
(case-lambda
|
|
|
|
[(f)
|
2018-04-08 10:44:32 +00:00
|
|
|
(when (not (eq? (field-handle-owner f) (current-actor))) (field-scope-error 'field-ref f))
|
2018-04-06 10:37:59 +00:00
|
|
|
(dataflow-record-observation! (dataspace-dataflow (current-dataspace)) f)
|
|
|
|
(field-handle-value f)]
|
|
|
|
[(f v)
|
2018-04-08 10:44:32 +00:00
|
|
|
(when (not (eq? (field-handle-owner f) (current-actor))) (field-scope-error 'field-set! f))
|
2018-04-06 10:37:59 +00:00
|
|
|
(dataflow-record-damage! (dataspace-dataflow (current-dataspace)) f)
|
|
|
|
(set-field-handle-value! f v)]))
|
|
|
|
|
2018-04-08 10:44:32 +00:00
|
|
|
(define (field-scope-error who f)
|
|
|
|
(error who "Field ~a used out-of-scope; owner = ~a, current = ~a"
|
|
|
|
f
|
|
|
|
(field-handle-owner f)
|
|
|
|
(current-actor)))
|
|
|
|
|
2018-04-06 10:37:59 +00:00
|
|
|
;; Parameterof Dataspace
|
|
|
|
(define current-dataspace (make-parameter #f))
|
|
|
|
|
2018-04-08 07:52:37 +00:00
|
|
|
;; Parameterof Actor
|
|
|
|
(define current-actor (make-parameter #f))
|
|
|
|
|
|
|
|
;; Parameterof Facet
|
|
|
|
(define current-facet (make-parameter #f))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
|
|
|
;; Parameterof Boolean
|
|
|
|
(define in-script? (make-parameter #t))
|
|
|
|
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
|
|
|
|
;; Script priorities. These are used to ensure that the results of
|
|
|
|
;; some *side effects* are visible to certain pieces of code.
|
|
|
|
|
|
|
|
(module priorities racket/base
|
|
|
|
(require (for-syntax racket/base))
|
|
|
|
|
|
|
|
(define-syntax (define-priority-levels stx)
|
|
|
|
(let loop ((counter 0) (stx (syntax-case stx ()
|
|
|
|
[(_ level ...) #'(level ...)])))
|
|
|
|
(syntax-case stx ()
|
|
|
|
[()
|
|
|
|
#'(void)]
|
|
|
|
[(#:count c)
|
|
|
|
#`(begin (define c #,counter)
|
|
|
|
(provide c))]
|
|
|
|
[(this-level more ...)
|
|
|
|
#`(begin (define this-level #,counter)
|
|
|
|
(provide this-level)
|
|
|
|
#,(loop (+ counter 1) #'(more ...)))])))
|
|
|
|
|
|
|
|
(define-priority-levels ;; highest-priority to lowest-priority
|
|
|
|
*query-priority-high*
|
|
|
|
*query-priority*
|
|
|
|
*query-handler-priority*
|
|
|
|
*normal-priority*
|
|
|
|
*gc-priority*
|
|
|
|
*idle-priority*
|
|
|
|
#:count priority-count))
|
|
|
|
|
|
|
|
(require (submod "." priorities))
|
|
|
|
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
|
2018-04-25 18:30:45 +00:00
|
|
|
(define (make-dataspace boot-proc)
|
2018-04-11 11:28:09 +00:00
|
|
|
(dataspace 0
|
|
|
|
(make-empty-skeleton)
|
|
|
|
(make-bag)
|
|
|
|
(make-dataflow-graph)
|
|
|
|
'()
|
2018-04-25 18:30:45 +00:00
|
|
|
(enqueue (make-queue) (action-group 'meta (list (spawn #f boot-proc (set)))))))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
|
|
|
(define (generate-id! ds)
|
|
|
|
(let ((id (dataspace-next-id ds)))
|
|
|
|
(set-dataspace-next-id! ds (+ id 1))
|
|
|
|
id))
|
|
|
|
|
2018-04-08 06:39:39 +00:00
|
|
|
(define (add-actor! ds name boot-proc initial-assertions)
|
2018-04-08 07:52:37 +00:00
|
|
|
(define the-actor-id (generate-id! ds))
|
2018-04-11 11:28:09 +00:00
|
|
|
(define the-actor (actor the-actor-id
|
|
|
|
name
|
|
|
|
#f
|
|
|
|
#f
|
|
|
|
(make-vector priority-count (make-queue))
|
2018-04-19 16:55:52 +00:00
|
|
|
(make-queue)
|
|
|
|
(set)))
|
2018-04-08 06:39:39 +00:00
|
|
|
(for [(a initial-assertions)]
|
|
|
|
(match (bag-change! (dataspace-assertions ds) a 1)
|
|
|
|
['absent->present (add-assertion! (dataspace-routing-table ds) a)]
|
|
|
|
;; 'absent->absent and 'present->absent absurd
|
|
|
|
['present->present (void)])) ;; i.e. no visible change
|
2018-04-08 07:52:37 +00:00
|
|
|
(add-facet! ds
|
|
|
|
#f
|
|
|
|
the-actor
|
|
|
|
#f
|
|
|
|
(lambda ()
|
|
|
|
(boot-proc)
|
2018-04-11 11:28:09 +00:00
|
|
|
(for [(a initial-assertions)] (retract! the-actor a)))))
|
2018-04-08 07:52:37 +00:00
|
|
|
|
|
|
|
(define-syntax-rule (with-current-facet [ds0 a0 f0 script?] body ...)
|
2018-04-08 06:39:39 +00:00
|
|
|
(let ((ds ds0)
|
2018-04-08 07:52:37 +00:00
|
|
|
(a a0)
|
|
|
|
(f f0))
|
2018-04-08 06:39:39 +00:00
|
|
|
(parameterize ((current-dataspace ds)
|
2018-04-08 07:52:37 +00:00
|
|
|
(current-actor a)
|
|
|
|
(current-facet f)
|
2018-04-08 06:39:39 +00:00
|
|
|
(in-script? script?))
|
|
|
|
(with-handlers ([(lambda (e) (not (exn:break? e)))
|
2018-04-08 10:44:32 +00:00
|
|
|
(lambda (e)
|
2018-04-11 11:28:09 +00:00
|
|
|
(log-error "Actor ~a died with exception:\n~a" a (exn->string e))
|
|
|
|
(abandon-queued-work! a)
|
2018-04-08 10:44:32 +00:00
|
|
|
(terminate-actor! ds a))]) ;; TODO: tracing
|
2018-04-09 09:23:22 +00:00
|
|
|
(call-with-syndicate-prompt
|
|
|
|
(lambda ()
|
|
|
|
body ...))
|
2018-04-08 06:39:39 +00:00
|
|
|
(void)))))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
|
|
|
(define (capture-facet-context proc)
|
|
|
|
(let ((ds (current-dataspace))
|
2018-04-08 07:52:37 +00:00
|
|
|
(a (current-actor))
|
|
|
|
(f (current-facet)))
|
2018-04-06 10:37:59 +00:00
|
|
|
(lambda args
|
2018-04-08 07:52:37 +00:00
|
|
|
(with-current-facet [ds a f #t]
|
2018-04-06 10:37:59 +00:00
|
|
|
(apply proc args)))))
|
|
|
|
|
2018-04-11 11:28:09 +00:00
|
|
|
(define (pop-next-script! ac)
|
|
|
|
(define priority-levels (actor-pending-scripts ac))
|
2018-04-06 10:37:59 +00:00
|
|
|
(let loop ((level 0))
|
|
|
|
(and (< level (vector-length priority-levels))
|
|
|
|
(let ((q (vector-ref priority-levels level)))
|
|
|
|
(if (queue-empty? q)
|
|
|
|
(loop (+ level 1))
|
|
|
|
(let-values (((script q) (dequeue q)))
|
|
|
|
(vector-set! priority-levels level q)
|
|
|
|
script))))))
|
|
|
|
|
2018-04-11 11:28:09 +00:00
|
|
|
(define (run-actor-pending-scripts! ds ac)
|
|
|
|
(let loop ()
|
|
|
|
(let ((script (pop-next-script! ac)))
|
|
|
|
(and script
|
|
|
|
(begin (script)
|
|
|
|
(refresh-facet-assertions! ds)
|
|
|
|
(loop))))))
|
|
|
|
|
|
|
|
(define (refresh-facet-assertions! ds)
|
|
|
|
(dataflow-repair-damage! (dataspace-dataflow ds)
|
|
|
|
(lambda (subject-id)
|
|
|
|
(match-define (list f eid) subject-id)
|
|
|
|
(when (facet-live? f) ;; TODO: necessary test, or tautological?
|
|
|
|
(define ac (facet-actor f))
|
|
|
|
(with-current-facet [ds ac f #f]
|
|
|
|
(define ep (hash-ref (facet-endpoints f) eid))
|
|
|
|
(define old-assertion (endpoint-assertion ep))
|
|
|
|
(define new-assertion ((endpoint-assertion-fn ep)))
|
|
|
|
(when (not (equal? old-assertion new-assertion))
|
|
|
|
(set-endpoint-assertion! ep new-assertion)
|
|
|
|
(retract! ac old-assertion)
|
|
|
|
(assert! ac new-assertion)
|
|
|
|
(define h (endpoint-handler ep))
|
|
|
|
(when h
|
|
|
|
(dataspace-unsubscribe! ds h)
|
|
|
|
(dataspace-subscribe! ds h))))))))
|
|
|
|
|
|
|
|
(define (commit-actions! ds ac)
|
|
|
|
(define pending (actor-pending-actions ac))
|
|
|
|
;; (log-info "commit-actions!: ~a actions ~a" ac (queue->list pending))
|
2018-04-22 20:02:40 +00:00
|
|
|
(set-dataspace-pending-actions! ds (enqueue (dataspace-pending-actions ds)
|
|
|
|
(action-group ac (queue->list pending))))
|
2018-04-11 11:28:09 +00:00
|
|
|
(set-actor-pending-actions! ac (make-queue)))
|
|
|
|
|
2018-04-06 10:37:59 +00:00
|
|
|
(define (run-all-pending-scripts! ds)
|
2018-04-11 11:28:09 +00:00
|
|
|
(define runnable (dataspace-runnable ds))
|
|
|
|
(set-dataspace-runnable! ds '())
|
|
|
|
(for [(ac (in-list runnable))]
|
|
|
|
(run-actor-pending-scripts! ds ac)
|
|
|
|
(set-actor-runnable?! ac #f)
|
|
|
|
(commit-actions! ds ac)))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
|
|
|
(define (perform-pending-actions! ds)
|
2018-04-22 20:02:40 +00:00
|
|
|
(define groups (queue->list (dataspace-pending-actions ds)))
|
2018-04-06 10:37:59 +00:00
|
|
|
(set-dataspace-pending-actions! ds (make-queue))
|
2018-04-22 20:02:40 +00:00
|
|
|
(for [(group (in-list groups))]
|
|
|
|
(match-define (action-group ac actions) group)
|
|
|
|
(for [(action (in-list actions))]
|
|
|
|
;; (log-info "~a performing ~a" ac action)
|
|
|
|
(match action
|
|
|
|
[(patch delta)
|
|
|
|
(for [((a count) (in-bag/count delta))]
|
|
|
|
(match (bag-change! (dataspace-assertions ds) a count)
|
|
|
|
['present->absent (remove-assertion! (dataspace-routing-table ds) a)]
|
|
|
|
['absent->present (add-assertion! (dataspace-routing-table ds) a)]
|
|
|
|
;; 'absent->absent absurd
|
|
|
|
['present->present (void)]))] ;; i.e. no visible change
|
|
|
|
[(message body)
|
|
|
|
(send-assertion! (dataspace-routing-table ds) body)]
|
|
|
|
[(spawn name boot-proc initial-assertions)
|
|
|
|
(add-actor! ds name boot-proc initial-assertions)]))))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
|
|
|
(define (run-scripts! ds)
|
2018-04-11 11:28:09 +00:00
|
|
|
(run-all-pending-scripts! ds)
|
|
|
|
(perform-pending-actions! ds)
|
2018-04-06 10:37:59 +00:00
|
|
|
;; TODO: figure out when a dataspace should quit itself. Given the
|
|
|
|
;; mutable nature of the implementation, maybe never? It might be
|
|
|
|
;; being held elsewhere!
|
2018-04-11 11:28:09 +00:00
|
|
|
(not (null? (dataspace-runnable ds))))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
2018-04-08 07:52:37 +00:00
|
|
|
(define (add-facet! ds where actor parent boot-proc)
|
2018-04-08 06:39:39 +00:00
|
|
|
(when (and (not (in-script?)) where)
|
|
|
|
(error 'add-facet!
|
|
|
|
"~a: Cannot add facet outside script; are you missing an (on ...)?"
|
|
|
|
where))
|
2018-04-08 07:52:37 +00:00
|
|
|
(define f (facet (generate-id! ds)
|
|
|
|
#t
|
|
|
|
actor
|
|
|
|
parent
|
2018-04-06 10:37:59 +00:00
|
|
|
(make-hash)
|
|
|
|
'()
|
2018-04-08 07:52:37 +00:00
|
|
|
(seteq)))
|
|
|
|
(if parent
|
|
|
|
(set-facet-children! parent (set-add (facet-children parent) f))
|
2018-04-22 20:03:01 +00:00
|
|
|
(begin
|
|
|
|
(when (actor-root-facet actor)
|
|
|
|
;; TODO: consider whether this is legit. For example, (stop-facet the-root-facet
|
|
|
|
;; (react ...) (react ...)) should probably be admissible, so perhaps more than one
|
|
|
|
;; root facet should be allowed?
|
|
|
|
(error 'add-facet! "INTERNAL ERROR: Attempt to add second root facet"))
|
|
|
|
(set-actor-root-facet! actor f)))
|
2018-04-08 07:52:37 +00:00
|
|
|
(with-current-facet [ds actor f #f]
|
2018-04-06 10:37:59 +00:00
|
|
|
(boot-proc))
|
2018-04-11 11:28:09 +00:00
|
|
|
(push-script! ds actor (lambda ()
|
2018-04-25 18:40:53 +00:00
|
|
|
(when (or (and parent (not (facet-live? parent)))
|
|
|
|
(facet-inert? ds f))
|
2018-04-11 11:28:09 +00:00
|
|
|
(terminate-facet! ds f)))))
|
2018-04-08 07:52:37 +00:00
|
|
|
|
|
|
|
(define (facet-inert? ds f)
|
|
|
|
(and (hash-empty? (facet-endpoints f))
|
2018-04-06 10:37:59 +00:00
|
|
|
(set-empty? (facet-children f))))
|
|
|
|
|
2018-04-11 11:28:09 +00:00
|
|
|
(define (schedule-script! #:priority [priority *normal-priority*] ds ac thunk)
|
|
|
|
(push-script! #:priority priority ds ac (capture-facet-context thunk)))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
2018-04-11 11:28:09 +00:00
|
|
|
(define (push-script! #:priority [priority *normal-priority*] ds ac thunk-with-context)
|
|
|
|
(when (not (actor-runnable? ac))
|
|
|
|
(set-actor-runnable?! ac #t)
|
|
|
|
(set-dataspace-runnable! ds (cons ac (dataspace-runnable ds))))
|
|
|
|
(define v (actor-pending-scripts ac))
|
2018-04-08 10:44:32 +00:00
|
|
|
(vector-set! v priority (enqueue (vector-ref v priority) thunk-with-context)))
|
2018-04-08 06:39:39 +00:00
|
|
|
|
2018-04-08 07:52:37 +00:00
|
|
|
(define (retract-facet-assertions-and-subscriptions! ds f)
|
2018-04-11 11:28:09 +00:00
|
|
|
(define ac (facet-actor f))
|
|
|
|
(push-script! ds
|
|
|
|
ac
|
|
|
|
(lambda ()
|
|
|
|
(for [((eid ep) (in-hash (facet-endpoints f)))]
|
|
|
|
(dataflow-forget-subject! (dataspace-dataflow ds) (list f eid))
|
|
|
|
(retract! ac (endpoint-assertion ep))
|
|
|
|
(define h (endpoint-handler ep))
|
|
|
|
(when h (dataspace-unsubscribe! ds h))))))
|
|
|
|
|
|
|
|
(define (abandon-queued-work! ac)
|
|
|
|
(set-actor-pending-actions! ac (make-queue))
|
|
|
|
(let ((scripts (actor-pending-scripts ac)))
|
|
|
|
(for [(i (in-range (vector-length scripts)))]
|
|
|
|
(vector-set! scripts i (make-queue)))))
|
2018-04-08 06:39:39 +00:00
|
|
|
|
|
|
|
;; Abruptly terminates an entire actor, without running stop-scripts etc.
|
2018-04-08 07:52:37 +00:00
|
|
|
(define (terminate-actor! ds the-actor)
|
2018-04-19 16:55:52 +00:00
|
|
|
(push-script! ds the-actor
|
|
|
|
(lambda () (for [(a (actor-adhoc-assertions the-actor))] (retract! the-actor a))))
|
2018-04-08 07:52:37 +00:00
|
|
|
(let ((f (actor-root-facet the-actor)))
|
2018-04-08 06:39:39 +00:00
|
|
|
(when f
|
2018-04-08 07:52:37 +00:00
|
|
|
(let abort-facet! ((f f))
|
|
|
|
(set-facet-live?! f #f)
|
|
|
|
(for [(child (in-set (facet-children f)))] (abort-facet! child))
|
|
|
|
(retract-facet-assertions-and-subscriptions! ds f)))))
|
2018-04-08 06:39:39 +00:00
|
|
|
|
|
|
|
;; Cleanly terminates a facet and its children, running stop-scripts etc.
|
2018-04-08 07:52:37 +00:00
|
|
|
(define (terminate-facet! ds f)
|
|
|
|
(when (facet-live? f)
|
2018-04-11 11:28:09 +00:00
|
|
|
(define ac (facet-actor f))
|
2018-04-08 07:52:37 +00:00
|
|
|
(define parent (facet-parent f))
|
|
|
|
(if parent
|
|
|
|
(set-facet-children! parent (set-remove (facet-children parent) f))
|
2018-04-11 11:28:09 +00:00
|
|
|
(set-actor-root-facet! ac #f))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
2018-04-08 07:52:37 +00:00
|
|
|
(set-facet-live?! f #f)
|
2018-04-06 10:37:59 +00:00
|
|
|
|
2018-04-08 07:52:37 +00:00
|
|
|
(for [(child (in-set (facet-children f)))] (terminate-facet! ds child))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
|
|
|
;; Run stop-scripts after terminating children. This means that
|
|
|
|
;; children's stop-scripts run before ours.
|
|
|
|
(for [(script (reverse (facet-stop-scripts f)))]
|
2018-04-08 06:39:39 +00:00
|
|
|
(schedule-script! ds
|
2018-04-11 11:28:09 +00:00
|
|
|
ac
|
2018-04-08 06:39:39 +00:00
|
|
|
(lambda ()
|
2018-04-11 11:28:09 +00:00
|
|
|
(with-current-facet [ds ac f #t]
|
2018-04-08 06:39:39 +00:00
|
|
|
(script)))))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
2018-04-08 07:52:37 +00:00
|
|
|
(retract-facet-assertions-and-subscriptions! ds f)
|
2018-04-06 10:37:59 +00:00
|
|
|
|
2018-04-11 11:28:09 +00:00
|
|
|
(push-script! #:priority *gc-priority* ds ac
|
|
|
|
(lambda ()
|
|
|
|
(if parent
|
|
|
|
(when (facet-inert? ds parent) (terminate-facet! ds parent))
|
|
|
|
(terminate-actor! ds ac))))))
|
2018-04-06 10:58:49 +00:00
|
|
|
|
2018-04-08 07:52:37 +00:00
|
|
|
(define (stop-facet! ds f stop-script)
|
2018-04-11 11:28:09 +00:00
|
|
|
(define ac (facet-actor f))
|
2018-04-22 20:03:21 +00:00
|
|
|
(with-current-facet [ds ac (facet-parent f) #t] ;; run in parent context wrt terminating facet
|
2018-04-11 11:28:09 +00:00
|
|
|
(schedule-script! ds ac (lambda ()
|
|
|
|
(terminate-facet! ds f)
|
|
|
|
(schedule-script! ds ac stop-script)))))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
2018-04-08 06:39:39 +00:00
|
|
|
(define (add-stop-script! ds script-proc)
|
2018-04-08 07:52:37 +00:00
|
|
|
(define f (current-facet))
|
|
|
|
(set-facet-stop-scripts! f (cons script-proc (facet-stop-scripts f))))
|
2018-04-08 06:39:39 +00:00
|
|
|
|
2018-04-06 10:37:59 +00:00
|
|
|
(define (add-endpoint! ds where assertion-fn handler)
|
|
|
|
(when (in-script?)
|
|
|
|
(error 'add-endpoint!
|
|
|
|
"~a: Cannot add endpoint in script; are you missing a (react ...)?"
|
|
|
|
where))
|
2018-04-08 07:52:37 +00:00
|
|
|
(define f (current-facet))
|
2018-04-06 10:37:59 +00:00
|
|
|
(define eid (generate-id! ds))
|
|
|
|
(define assertion
|
2018-04-08 07:52:37 +00:00
|
|
|
(parameterize ((current-dataflow-subject-id (list f eid)))
|
2018-04-09 09:23:22 +00:00
|
|
|
(call-with-syndicate-prompt assertion-fn)))
|
2018-04-06 10:37:59 +00:00
|
|
|
(define ep (endpoint eid assertion assertion-fn handler))
|
2018-04-11 11:28:09 +00:00
|
|
|
(assert! (facet-actor f) assertion)
|
2018-04-06 10:37:59 +00:00
|
|
|
(when handler (dataspace-subscribe! ds handler))
|
2018-04-08 07:52:37 +00:00
|
|
|
(hash-set! (facet-endpoints f) eid ep))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
2018-04-11 11:28:09 +00:00
|
|
|
(define (enqueue-action! ac action)
|
|
|
|
(set-actor-pending-actions! ac (enqueue (actor-pending-actions ac) action)))
|
2018-04-08 06:39:39 +00:00
|
|
|
|
2018-04-11 11:28:09 +00:00
|
|
|
(define (ensure-patch-action! ac)
|
|
|
|
(let ((q (actor-pending-actions ac)))
|
2018-04-08 06:39:39 +00:00
|
|
|
(when (or (queue-empty? q) (not (patch? (queue-last q))))
|
2018-04-11 11:28:09 +00:00
|
|
|
(enqueue-action! ac (patch (make-bag)))))
|
|
|
|
(patch-changes (queue-last (actor-pending-actions ac))))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
2018-04-11 11:28:09 +00:00
|
|
|
(define (retract! ac assertion)
|
2018-04-06 10:37:59 +00:00
|
|
|
(when (not (void? assertion))
|
2018-04-11 11:28:09 +00:00
|
|
|
(bag-change! (ensure-patch-action! ac) assertion -1)))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
2018-04-11 11:28:09 +00:00
|
|
|
(define (assert! ac assertion)
|
2018-04-06 10:37:59 +00:00
|
|
|
(when (not (void? assertion))
|
2018-04-11 11:28:09 +00:00
|
|
|
(bag-change! (ensure-patch-action! ac) assertion +1)))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
2018-04-19 16:55:52 +00:00
|
|
|
(define (adhoc-retract! ac assertion)
|
2018-04-25 18:46:08 +00:00
|
|
|
(define adhoc-assertions (actor-adhoc-assertions ac))
|
|
|
|
(when (and (not (void? assertion)) (set-member? adhoc-assertions assertion))
|
|
|
|
(set-actor-adhoc-assertions! ac (set-remove adhoc-assertions assertion))
|
2018-04-19 16:55:52 +00:00
|
|
|
(retract! ac assertion)))
|
|
|
|
|
|
|
|
(define (adhoc-assert! ac assertion)
|
2018-04-25 18:46:08 +00:00
|
|
|
(define adhoc-assertions (actor-adhoc-assertions ac))
|
|
|
|
(when (and (not (void? assertion)) (not (set-member? adhoc-assertions assertion)))
|
|
|
|
(set-actor-adhoc-assertions! ac (set-add adhoc-assertions assertion))
|
2018-04-19 16:55:52 +00:00
|
|
|
(assert! ac assertion)))
|
|
|
|
|
2018-04-06 10:37:59 +00:00
|
|
|
(define (dataspace-unsubscribe! ds h)
|
|
|
|
(remove-interest! (dataspace-routing-table ds) h))
|
|
|
|
|
|
|
|
(define (dataspace-subscribe! ds h)
|
|
|
|
(add-interest! (dataspace-routing-table ds) h))
|
|
|
|
|
2018-04-08 10:44:32 +00:00
|
|
|
(define (ensure-in-script! who)
|
|
|
|
(when (not (in-script?))
|
|
|
|
(error who "Attempt to perform action outside script; are you missing an (on ...)?")))
|
|
|
|
|
2018-04-11 11:28:09 +00:00
|
|
|
(define (enqueue-send! ac body)
|
|
|
|
(ensure-in-script! 'enqueue-send!)
|
|
|
|
(enqueue-action! ac (message body)))
|
2018-04-08 06:39:39 +00:00
|
|
|
|
2018-04-11 11:28:09 +00:00
|
|
|
(define (spawn! ac name boot-proc initial-assertions)
|
|
|
|
(ensure-in-script! 'spawn!)
|
|
|
|
(enqueue-action! ac (spawn name boot-proc initial-assertions)))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
2018-04-09 09:23:22 +00:00
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
;; 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)
|
2018-04-11 11:28:09 +00:00
|
|
|
(current-actor)
|
|
|
|
(lambda () (apply raw-resume-parent results)))))
|
2018-04-09 09:23:22 +00:00
|
|
|
(proc resume-parent))))
|
|
|
|
prompt-tag))
|
|
|
|
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
|
2018-04-06 10:37:59 +00:00
|
|
|
(module+ test
|
|
|
|
(message-struct set-box (new-value))
|
|
|
|
(assertion-struct box-state (value))
|
|
|
|
|
2018-04-08 06:39:39 +00:00
|
|
|
(define ds
|
|
|
|
(make-dataspace
|
|
|
|
(lambda ()
|
2018-04-08 10:44:32 +00:00
|
|
|
(schedule-script!
|
|
|
|
(current-dataspace)
|
2018-04-11 11:28:09 +00:00
|
|
|
(current-actor)
|
2018-04-08 06:39:39 +00:00
|
|
|
(lambda ()
|
2018-04-11 11:28:09 +00:00
|
|
|
(spawn!
|
|
|
|
(current-actor)
|
2018-04-08 10:44:32 +00:00
|
|
|
'box
|
|
|
|
(lambda ()
|
|
|
|
(define current-value (field-handle 'current-value
|
|
|
|
(generate-id! (current-dataspace))
|
|
|
|
(current-actor)
|
|
|
|
0))
|
|
|
|
(add-endpoint! (current-dataspace)
|
|
|
|
'stop-when-ten
|
|
|
|
(lambda ()
|
|
|
|
(when (= (current-value) 10)
|
|
|
|
(stop-facet! (current-dataspace)
|
|
|
|
(current-facet)
|
|
|
|
(lambda ()
|
|
|
|
(log-info "box: terminating"))))
|
|
|
|
(void))
|
|
|
|
#f)
|
|
|
|
(add-endpoint! (current-dataspace)
|
|
|
|
'assert-box-state
|
|
|
|
(lambda () (box-state (current-value)))
|
|
|
|
#f)
|
|
|
|
(add-endpoint! (current-dataspace)
|
|
|
|
'on-message-set-box
|
|
|
|
(lambda () (observe (set-box (capture (discard)))))
|
|
|
|
(skeleton-interest (list struct:set-box #f)
|
|
|
|
'()
|
|
|
|
'()
|
|
|
|
'((0 0))
|
|
|
|
(capture-facet-context
|
|
|
|
(lambda (op new-value)
|
|
|
|
(when (eq? '! op)
|
|
|
|
(schedule-script!
|
|
|
|
(current-dataspace)
|
2018-04-11 11:28:09 +00:00
|
|
|
(current-actor)
|
2018-04-08 10:44:32 +00:00
|
|
|
(lambda ()
|
|
|
|
(log-info "box: taking on new-value ~v" new-value)
|
|
|
|
(current-value new-value)))))))))
|
|
|
|
(set))
|
2018-04-11 11:28:09 +00:00
|
|
|
(spawn!
|
|
|
|
(current-actor)
|
2018-04-08 10:44:32 +00:00
|
|
|
'client
|
|
|
|
(lambda ()
|
|
|
|
(add-endpoint! (current-dataspace)
|
|
|
|
'stop-when-retracted-observe-set-box
|
|
|
|
(lambda () (observe (observe (set-box (discard)))))
|
|
|
|
(skeleton-interest (list struct:observe (list struct:set-box #f))
|
|
|
|
'()
|
|
|
|
'()
|
|
|
|
'()
|
|
|
|
(capture-facet-context
|
|
|
|
(lambda (op)
|
|
|
|
(when (eq? '- op)
|
|
|
|
(stop-facet!
|
|
|
|
(current-dataspace)
|
|
|
|
(current-facet)
|
|
|
|
(lambda ()
|
|
|
|
(log-info "client: box has gone"))))))))
|
|
|
|
(add-endpoint! (current-dataspace)
|
|
|
|
'on-asserted-box-state
|
|
|
|
(lambda () (observe (box-state (capture (discard)))))
|
|
|
|
(skeleton-interest (list struct:box-state #f)
|
|
|
|
'()
|
|
|
|
'()
|
|
|
|
'((0 0))
|
|
|
|
(capture-facet-context
|
|
|
|
(lambda (op v)
|
|
|
|
(when (eq? '+ op)
|
|
|
|
(schedule-script!
|
|
|
|
(current-dataspace)
|
2018-04-11 11:28:09 +00:00
|
|
|
(current-actor)
|
2018-04-08 10:44:32 +00:00
|
|
|
(lambda ()
|
|
|
|
(log-info "client: learned that box's value is now ~v" v)
|
2018-04-11 11:28:09 +00:00
|
|
|
(enqueue-send! (current-actor)
|
|
|
|
(set-box (+ v 1)))))))))))
|
2018-04-08 10:44:32 +00:00
|
|
|
(set)))))))
|
2018-04-06 10:37:59 +00:00
|
|
|
|
|
|
|
(require racket/pretty)
|
2018-04-06 11:07:09 +00:00
|
|
|
;; (pretty-print ds)
|
2018-04-08 06:39:39 +00:00
|
|
|
(#;time values
|
|
|
|
(let loop ((i 0))
|
|
|
|
;; (printf "--- i = ~v\n" i)
|
|
|
|
(when (run-scripts! ds)
|
|
|
|
;; (pretty-print ds)
|
|
|
|
(loop (+ i 1)))))
|
2018-04-06 11:07:09 +00:00
|
|
|
;; (pretty-print ds)
|
2018-04-06 10:37:59 +00:00
|
|
|
)
|