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

Progress on syntax veneer

This commit is contained in:
Tony Garnock-Jones 2018-04-08 11:44:32 +01:00
parent 0e2384514f
commit 0673d6d9b3
4 changed files with 615 additions and 992 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
imperative/dataspace.rkt
View File

@ -1,11 +1,52 @@
#lang racket/base
(provide )
(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??
add-facet!
stop-facet!
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??
dataspace-spawn! ;; TODO: should this be provided?
dataspace-send! ;; TODO: should this be provided?
)
(require syndicate/functional-queue)
(require syndicate/dataflow)
(require racket/match)
(require racket/set)
(require (only-in racket/exn exn->string))
(module+ test (require rackunit))
@ -13,6 +54,13 @@
(require "pattern.rkt")
(require "bag.rkt")
;; 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))
;; An `ActorID` uniquely identifies an actor in a `Dataspace`.
;; A `FID` is a Facet ID, uniquely identifying a facet in a `Dataspace`.
@ -65,8 +113,8 @@
[(define (write-proc e p mode)
(fprintf p "#<endpoint ~a>" (endpoint-id e)))])
;; TODO: field ownership: record actor (root facet) ID in field, check
;; it on access.
;; TODO: the field ownership checks during field-ref/field-set! might
;; be quite expensive. Are they worth it?
(struct field-handle (name ;; Symbol
id ;; Nat
owner ;; Actor
@ -78,12 +126,20 @@
#:property prop:procedure
(case-lambda
[(f)
(when (not (eq? (field-handle-owner f) (current-actor))) (field-scope-error 'field-ref f))
(dataflow-record-observation! (dataspace-dataflow (current-dataspace)) f)
(field-handle-value f)]
[(f v)
(when (not (eq? (field-handle-owner f) (current-actor))) (field-scope-error 'field-set! f))
(dataflow-record-damage! (dataspace-dataflow (current-dataspace)) f)
(set-field-handle-value! f v)]))
(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)))
;; Parameterof Dataspace
(define current-dataspace (make-parameter #f))
@ -173,7 +229,11 @@
(current-facet f)
(in-script? script?))
(with-handlers ([(lambda (e) (not (exn:break? e)))
(lambda (e) (terminate-actor! ds a))]) ;; TODO: tracing
(lambda (e)
(log-error "Actor ~a died with exception:\n~a"
(current-actor)
(exn->string e))
(terminate-actor! ds a))]) ;; TODO: tracing
body ...
(void)))))
@ -261,7 +321,7 @@
(set-actor-root-facet! actor f))
(with-current-facet [ds actor f #f]
(boot-proc))
(schedule-script!* ds (lambda ()
(push-script! ds (lambda ()
(when (and (facet-live? f)
(or (and parent (not (facet-live? parent)))
(facet-inert? ds f)))
@ -272,14 +332,14 @@
(set-empty? (facet-children f))))
(define (schedule-script! #:priority [priority *normal-priority*] ds thunk)
(schedule-script!* #:priority priority ds (capture-facet-context thunk)))
(push-script! #:priority priority ds (capture-facet-context thunk)))
(define (schedule-script!* #:priority [priority *normal-priority*] ds thunk)
(define (push-script! #:priority [priority *normal-priority*] ds thunk-with-context)
(define v (dataspace-pending-scripts ds))
(vector-set! v priority (enqueue (vector-ref v priority) thunk)))
(vector-set! v priority (enqueue (vector-ref v priority) thunk-with-context)))
(define (retract-facet-assertions-and-subscriptions! ds f)
(schedule-script!* ds (lambda ()
(push-script! ds (lambda ()
(for [((eid ep) (in-hash (facet-endpoints f)))]
(dataflow-forget-subject! (dataspace-dataflow ds) (list f eid))
(dataspace-retract! ds (endpoint-assertion ep))
@ -318,7 +378,7 @@
(retract-facet-assertions-and-subscriptions! ds f)
(schedule-script!*
(push-script!
#:priority *gc-priority*
ds
(lambda ()
@ -374,27 +434,28 @@
(define (dataspace-subscribe! ds h)
(add-interest! (dataspace-routing-table ds) h))
(define (ensure-in-script! who)
(when (not (in-script?))
(error who "Attempt to perform action outside script; are you missing an (on ...)?")))
(define (dataspace-send! ds body)
(ensure-in-script! 'dataspace-send!)
(enqueue-action! ds (message body)))
(define (dataspace-spawn! ds name boot-proc initial-assertions)
(ensure-in-script! 'dataspace-spawn!)
(enqueue-action! ds (spawn name boot-proc initial-assertions)))
(module+ test
;; 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))
(message-struct set-box (new-value))
(assertion-struct box-state (value))
;; TODO: move somewhere sensible
(assertion-struct observe (specification))
(define ds
(make-dataspace
'ground
(lambda ()
(schedule-script!
(current-dataspace)
(lambda ()
(dataspace-spawn!
ds
@ -402,7 +463,7 @@
(lambda ()
(define current-value (field-handle 'current-value
(generate-id! (current-dataspace))
(facet-actor (current-facet))
(current-actor)
0))
(add-endpoint! (current-dataspace)
'stop-when-ten
@ -469,7 +530,7 @@
(log-info "client: learned that box's value is now ~v" v)
(dataspace-send! (current-dataspace)
(set-box (+ v 1)))))))))))
(set)))))
(set)))))))
(require racket/pretty)
;; (pretty-print ds)

23
imperative/event-expander.rkt Normal file
View File

@ -0,0 +1,23 @@
#lang racket/base
(require auxiliary-macro-context)
(define-auxiliary-macro-context
#:context-name event-expander
#:prop-name prop:event-expander
#:prop-predicate-name event-expander?
#:prop-accessor-name event-expander-proc
#:macro-definer-name define-event-expander
#:introducer-parameter-name current-event-expander-introducer
#:local-introduce-name syntax-local-event-expander-introduce
#:expander-id-predicate-name event-expander-id?
#:expander-transform-name event-expander-transform)
(provide (for-syntax
prop:event-expander
event-expander?
event-expander-proc
syntax-local-event-expander-introduce
event-expander-id?
event-expander-transform)
define-event-expander)

42
imperative/pattern.rkt
View File

@ -2,16 +2,19 @@
(provide (struct-out discard)
(struct-out capture)
analyse-pattern
(for-syntax analyse-pattern
desc->key
desc->skeleton-proj
desc->capture-proj
desc->skeleton-stx
desc->assertion-stx)
desc->capture-proj
desc->capture-names
desc->assertion-stx))
(require racket/match)
(require racket/struct-info)
(require syntax/stx)
(require (for-syntax racket/base))
(require (for-syntax racket/match))
(require (for-syntax racket/struct-info))
(require (for-syntax syntax/stx))
(struct discard () #:prefab)
(struct capture (detail) #:prefab)
@ -30,6 +33,7 @@
;; The other `SkProj` generates a second `SkKey` which is used as the
;; input to a handler function.
(begin-for-syntax
(define (dollar-id? stx)
(and (identifier? stx)
(char=? (string-ref (symbol->string (syntax-e stx)) 0) #\$)))
@ -72,14 +76,16 @@
(list 'discard)]
[_
(list 'atom stx)]))
)
;;---------------------------------------------------------------------------
(begin-for-syntax
(define (select-pattern-leaves desc capture-fn atom-fn)
(define (walk-node key-rev desc)
(match desc
[`(compound ,_ ,pieces ...) (walk-edge 0 key-rev pieces)]
[`(capture ,_ ,p) (append (capture-fn key-rev) (walk-node key-rev p))]
[`(capture ,name-stx ,p) (append (capture-fn key-rev name-stx) (walk-node key-rev p))]
[`(discard) (list)]
[`(atom ,v) (atom-fn key-rev v)]))
(define (walk-edge index key-rev pieces)
@ -91,19 +97,14 @@
(define (desc->key desc)
(select-pattern-leaves desc
(lambda (key-rev) (list))
(lambda (key-rev name-stx) (list))
(lambda (key-rev atom) (list atom))))
(define (desc->skeleton-proj desc)
(select-pattern-leaves desc
(lambda (key-rev) (list))
(lambda (key-rev name-stx) (list))
(lambda (key-rev atom) (list (reverse key-rev)))))
(define (desc->capture-proj desc)
(select-pattern-leaves desc
(lambda (key-rev) (list (reverse key-rev)))
(lambda (key-rev atom) (list))))
(define (desc->skeleton-stx desc)
(match desc
[`(compound list ,pieces ...)
@ -112,7 +113,17 @@
#`(list #,struct-type #,@(map desc->skeleton-stx pieces))]
[`(capture ,_ ,p) (desc->skeleton-stx p)]
[`(discard) #'#f]
[`(atom ,_) #'#f]))
[`(atom ,atom-stx) #'#f]))
(define (desc->capture-proj desc)
(select-pattern-leaves desc
(lambda (key-rev name-stx) (list (reverse key-rev)))
(lambda (key-rev atom) (list))))
(define (desc->capture-names desc)
(select-pattern-leaves desc
(lambda (key-rev name-stx) (list name-stx))
(lambda (key-rev atom) (list))))
(define (desc->assertion-stx desc)
(match desc
@ -123,3 +134,4 @@
[`(capture ,_ ,p) #`(capture #,(desc->assertion-stx p))]
[`(discard) #'(discard)]
[`(atom ,v) v]))
)

1117
imperative/syntax.rkt
View File

File diff suppressed because it is too large Load Diff