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

Switch to non-boxed, persistent impl of fields

This commit is contained in:
Tony Garnock-Jones 2016-07-21 16:50:16 -04:00
parent 970baf7a36
commit 4357424e78
1 changed files with 70 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

116
racket/syndicate/actor.rkt
View File

@ -86,10 +86,10 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Data Definitions and Structures ;; Data Definitions and Structures
;; A FieldTable is a (FieldDescriptor |-> Boxof Any) ;; A FieldTable is a (FieldDescriptor |-> Any)
;; (field-descriptor Symbol UniqueNatural) ;; (field-descriptor Symbol UniqueNatural (Option FID))
(struct field-descriptor (name id) #:prefab) (struct field-descriptor (name id defining-fid) #:prefab)
;; (field-handle FieldDescriptor) ;; (field-handle FieldDescriptor)
(struct field-handle (desc) (struct field-handle (desc)
@ -101,11 +101,11 @@
[(handle) [(handle)
(define desc (field-handle-desc handle)) (define desc (field-handle-desc handle))
(dataflow-record-observation! (actor-state-field-dataflow (current-actor-state)) desc) (dataflow-record-observation! (actor-state-field-dataflow (current-actor-state)) desc)
(unbox (get-field-box desc))] (field-ref desc)]
[(handle v) [(handle v)
(define desc (field-handle-desc handle)) (define desc (field-handle-desc handle))
(dataflow-record-damage! (actor-state-field-dataflow (current-actor-state)) desc) (dataflow-record-damage! (actor-state-field-dataflow (current-actor-state)) desc)
(set-box! (get-field-box desc) v)])) (field-set! desc v)]))
(define (make-field-proxy field guard wrap) (define (make-field-proxy field guard wrap)
(case-lambda (case-lambda
@ -166,7 +166,7 @@
field-dataflow ;; DataflowGraph field-dataflow ;; DataflowGraph
) #:prefab) ) #:prefab)
(struct facet (field-table ;; FieldTable (struct facet (field-descriptors ;; (Setof FieldDescriptor)
endpoints ;; (Hash EID Endpoint) endpoints ;; (Hash EID Endpoint)
stop-scripts ;; (Listof Script) -- IN REVERSE ORDER stop-scripts ;; (Listof Script) -- IN REVERSE ORDER
children ;; (Setof FID) children ;; (Setof FID)
@ -200,6 +200,7 @@
*query-priority* *query-priority*
*query-handler-priority* *query-handler-priority*
*normal-priority* *normal-priority*
*gc-priority*
#:count priority-count)) #:count priority-count))
(require (submod "." priorities)) (require (submod "." priorities))
@ -207,8 +208,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Parameters. Many of these are *updated* during facet execution! ;; Parameters. Many of these are *updated* during facet execution!
;; Parameterof FieldTable ;; Parameterof (Setof FieldDescriptor)
(define current-field-table (make-parameter 'unset:current-field-table)) (define current-field-descriptors (make-parameter 'unset:current-field-descriptors))
;; Parameterof ActorState ;; Parameterof ActorState
(define current-actor-state (make-parameter #f)) (define current-actor-state (make-parameter #f))
@ -693,24 +694,35 @@
(define field-counter 0) (define field-counter 0)
(define (make-field name initial-value) (define (make-field name initial-value)
(define desc (field-descriptor name field-counter)) (define fid (current-facet-id))
(define desc (field-descriptor name field-counter fid))
(set! field-counter (+ field-counter 1)) (set! field-counter (+ field-counter 1))
(define b (box initial-value)) (let ((a (current-actor-state)))
(if (current-facet-id) (current-actor-state
(current-field-table (hash-set (current-field-table) desc b)) (struct-copy actor-state a
(let ((a (current-actor-state))) [field-table (hash-set (actor-state-field-table a) desc initial-value)])))
(current-actor-state (when fid (current-field-descriptors (set-add (current-field-descriptors) desc)))
(struct-copy actor-state a
[field-table (hash-set (actor-state-field-table a) desc b)]))))
(field-handle desc)) (field-handle desc))
(define (get-field-box desc) (define (field-accessible? desc)
(hash-ref (current-field-table) (and (or (not (field-descriptor-defining-fid desc))
desc (set-member? (current-field-descriptors) desc))
(lambda () (hash-has-key? (actor-state-field-table (current-actor-state)) desc)))
(error 'get-field-box
"Field ~a used out-of-scope" (define (ensure-field-accessible! who desc)
(field-descriptor-name desc))))) (when (not (field-accessible? desc))
(error who "Field ~a used out-of-scope" (field-descriptor-name desc))))
(define (field-ref desc)
(ensure-field-accessible! 'field-ref desc)
(hash-ref (actor-state-field-table (current-actor-state)) desc))
(define (field-set! desc v)
(ensure-field-accessible! 'field-set! desc)
(define a (current-actor-state))
(define ft (actor-state-field-table a))
(current-actor-state
(struct-copy actor-state a [field-table (hash-set ft desc v)])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Facet Storage in an Actor ;; Facet Storage in an Actor
@ -735,17 +747,17 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Entering and Leaving Facet Context; Queueing of Work Items ;; Entering and Leaving Facet Context; Queueing of Work Items
(define-syntax-rule (with-current-facet fid field-table in? body ...) (define-syntax-rule (with-current-facet fid cfds in? body ...)
(parameterize ((current-field-table field-table) (parameterize ((current-facet-id fid)
(current-facet-id fid) (current-field-descriptors cfds)
(in-script? in?)) (in-script? in?))
body ...)) body ...))
(define (capture-facet-context proc) (define (capture-facet-context proc)
(let ((field-table (current-field-table)) (let ((fid (current-facet-id))
(fid (current-facet-id))) (cfds (current-field-descriptors)))
(lambda args (lambda args
(with-current-facet fid field-table #t (with-current-facet fid cfds #t
(call-with-syndicate-effects (call-with-syndicate-effects
(lambda () (apply proc args))))))) (lambda () (apply proc args)))))))
@ -818,25 +830,25 @@
(define parent-fid (current-facet-id)) (define parent-fid (current-facet-id))
(define fid next-fid) (define fid next-fid)
(set! next-fid (+ next-fid 1)) (set! next-fid (+ next-fid 1))
(define starting-field-descriptors
(if parent-fid
(cond [(lookup-facet parent-fid) => facet-field-descriptors]
[else (current-field-descriptors)]) ;; TODO: Is this correct???
(set)))
(update-facet! fid (lambda (_f) (facet 'not-yet-ready (update-facet! fid (lambda (_f) (facet 'not-yet-ready
(hasheqv) (hasheqv)
'() '()
(seteqv) (seteqv)
parent-fid))) parent-fid)))
(define starting-field-table (update-facet! parent-fid
(if parent-fid (lambda (pf)
(match (lookup-facet parent-fid) (and pf (struct-copy facet pf
[#f (current-field-table)] ;; TODO: Is this correct??? [children (set-add (facet-children pf) fid)]))))
[f (with-current-facet fid starting-field-descriptors #f
(store-facet! parent-fid (struct-copy facet f
[children (set-add (facet-children f) fid)]))
(facet-field-table f)])
(actor-state-field-table (current-actor-state))))
(with-current-facet fid starting-field-table #f
(setup-proc) (setup-proc)
(update-facet! fid (lambda (f) (and f (update-facet! fid (lambda (f)
(struct-copy facet f (and f (struct-copy facet f
[field-table (current-field-table)]))))) [field-descriptors (current-field-descriptors)])))))
(facet-handle-event! fid (facet-handle-event! fid
(lookup-facet fid) (lookup-facet fid)
(patch (actor-state-knowledge (current-actor-state)) trie-empty)) (patch (actor-state-knowledge (current-actor-state)) trie-empty))
@ -872,10 +884,22 @@
;; Run stop-scripts after terminating children. This means that ;; Run stop-scripts after terminating children. This means that
;; children's stop-scripts run before ours. ;; children's stop-scripts run before ours.
(with-current-facet fid (facet-field-table f) #t (with-current-facet fid (facet-field-descriptors f) #t
(for [(script (in-list (reverse (facet-stop-scripts f))))] (for [(script (in-list (reverse (facet-stop-scripts f))))]
(call-with-syndicate-effects script))) (call-with-syndicate-effects script)))
(push-script! *gc-priority*
(lambda ()
(let* ((a (current-actor-state))
(new-table
(for/fold [(t (actor-state-field-table a))]
[(desc (in-set (facet-field-descriptors f)))
#:when (equal? (field-descriptor-defining-fid desc)
fid)]
(hash-remove t desc))))
(current-actor-state
(struct-copy actor-state a [field-table new-table])))))
f))) f)))
(define (add-stop-script! script-proc) (define (add-stop-script! script-proc)
@ -896,7 +920,7 @@
(current-pending-patch patch-empty) (current-pending-patch patch-empty)
(current-pending-actions '()) (current-pending-actions '())
(current-pending-scripts (make-empty-pending-scripts))) (current-pending-scripts (make-empty-pending-scripts)))
(with-current-facet #f (hasheq) #f (with-current-facet #f (set) #f
(schedule-script! #f script-proc) (schedule-script! #f script-proc)
(run-scripts!)))) (run-scripts!))))
@ -929,7 +953,7 @@
(match-define (list fid eid) subject-id) (match-define (list fid eid) subject-id)
(define f (lookup-facet fid)) (define f (lookup-facet fid))
(when f (when f
(with-current-facet fid (facet-field-table f) #f (with-current-facet fid (facet-field-descriptors f) #f
(define ep (hash-ref (facet-endpoints f) eid)) (define ep (hash-ref (facet-endpoints f) eid))
(define new-patch ((endpoint-patch-fn ep))) (define new-patch ((endpoint-patch-fn ep)))
(update-stream! eid (compose-patch new-patch (update-stream! eid (compose-patch new-patch
@ -958,7 +982,7 @@
(run-scripts!)))) (run-scripts!))))
(define (facet-handle-event! fid f e) (define (facet-handle-event! fid f e)
(with-current-facet fid (facet-field-table f) #f (with-current-facet fid (facet-field-descriptors f) #f
(for [(ep (in-hash-values (facet-endpoints f)))] (for [(ep (in-hash-values (facet-endpoints f)))]
((endpoint-handler-fn ep) e)))) ((endpoint-handler-fn ep) e))))