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

First pass at converting to untyped

This commit is contained in:
Tony Garnock-Jones 2014-08-06 12:16:50 -07:00
parent d511d41040
commit da7851d451
46 changed files with 722 additions and 1689 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
action-add-endpoint.rkt
View File

@ -1,16 +1,15 @@
#lang typed/racket/base #lang racket/base
(require racket/match) (require racket/match)
(require "types.rkt") (require "structs.rkt")
(require "roles.rkt") (require "roles.rkt")
(require "vm.rkt") (require "vm.rkt")
(require "process.rkt") (require "process.rkt")
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
(provide do-add-endpoint) (provide do-add-endpoint)
(: do-add-endpoint : (All (State) PreEID Role (Handler State) (process State) vm ;; do-add-endpoint : (All (State) PreEID Role (Handler State) (process State) vm
-> (values (Option (process State)) vm))) ;; -> (values (Option (process State)) vm))
(define (do-add-endpoint pre-eid role h p state) (define (do-add-endpoint pre-eid role h p state)
(define new-eid (eid (process-pid p) pre-eid)) (define new-eid (eid (process-pid p) pre-eid))
(define old-endpoint (hash-ref (process-endpoints p) pre-eid (lambda () #f))) (define old-endpoint (hash-ref (process-endpoints p) pre-eid (lambda () #f)))
@ -35,7 +34,7 @@
state))) state)))
(values p state)))) (values p state))))
(: install-endpoint : (All (State) (process State) (endpoint State) -> (process State))) ;; install-endpoint : (All (State) (process State) (endpoint State) -> (process State))
(define (install-endpoint p ep) (define (install-endpoint p ep)
(define pre-eid (eid-pre-eid (endpoint-id ep))) (define pre-eid (eid-pre-eid (endpoint-id ep)))
(struct-copy process p [endpoints (hash-set (process-endpoints p) pre-eid ep)])) (struct-copy process p [endpoints (hash-set (process-endpoints p) pre-eid ep)]))

26
action-delete-endpoint.rkt
View File

@ -1,46 +1,44 @@
#lang typed/racket/base #lang racket/base
(require racket/match) (require racket/match)
(require "types.rkt") (require "structs.rkt")
(require "roles.rkt") (require "roles.rkt")
(require "vm.rkt") (require "vm.rkt")
(require "process.rkt") (require "process.rkt")
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround (require "quasiqueue.rkt")
(provide do-delete-endpoint (provide do-delete-endpoint
delete-all-endpoints) delete-all-endpoints)
(: do-delete-endpoint : (All (State) PreEID Reason (process State) vm ;; do-delete-endpoint : (All (State) PreEID Reason (process State) vm
-> (values (process State) vm))) ;; -> (values (process State) vm))
(define (do-delete-endpoint pre-eid reason p state) (define (do-delete-endpoint pre-eid reason p state)
(cond (cond
[(hash-has-key? (process-endpoints p) pre-eid) [(hash-has-key? (process-endpoints p) pre-eid)
(define old-endpoint (hash-ref (process-endpoints p) pre-eid)) (define old-endpoint (hash-ref (process-endpoints p) pre-eid))
(let-values (((p state) (notify-route-change-vm (remove-endpoint p old-endpoint) (let-values (((p state) (notify-route-change-vm (remove-endpoint p old-endpoint)
old-endpoint old-endpoint
(lambda: ([t : Role]) (absence-event t reason)) (lambda (t) (absence-event t reason))
state))) state)))
(values p state))] (values p state))]
[else [else
(values p state)])) (values p state)]))
(: remove-endpoint : (All (State) (process State) (endpoint State) -> (process State))) ;; remove-endpoint : (All (State) (process State) (endpoint State) -> (process State))
(define (remove-endpoint p ep) (define (remove-endpoint p ep)
(define pre-eid (eid-pre-eid (endpoint-id ep))) (define pre-eid (eid-pre-eid (endpoint-id ep)))
(struct-copy process p [endpoints (hash-remove (process-endpoints p) pre-eid)])) (struct-copy process p [endpoints (hash-remove (process-endpoints p) pre-eid)]))
(: delete-all-endpoints : (All (State) Reason (process State) vm ;; delete-all-endpoints : (All (State) Reason (process State) vm
-> (values (process State) vm (QuasiQueue (Action vm))))) ;; -> (values (process State) vm (QuasiQueue (Action vm))))
(define (delete-all-endpoints reason p state) (define (delete-all-endpoints reason p state)
(let-values (((p state) (let-values (((p state)
(for/fold: : (values (process State) vm) (for/fold ([p p] [state state])
([p p] [state state])
([pre-eid (in-hash-keys (process-endpoints p))]) ([pre-eid (in-hash-keys (process-endpoints p))])
(do-delete-endpoint pre-eid reason p state)))) (do-delete-endpoint pre-eid reason p state))))
(values p (values p
state state
(list->quasiqueue (list->quasiqueue
(map (lambda (#{pre-eid : PreEID}) (map (lambda (pre-eid)
(delete-endpoint (cast (eid (process-pid p) pre-eid) PreEID) (delete-endpoint (eid (process-pid p) pre-eid) reason))
reason))
(hash-keys (process-meta-endpoints p))))))) (hash-keys (process-meta-endpoints p)))))))

21
action-quit.rkt
View File

@ -1,24 +1,23 @@
#lang typed/racket/base #lang racket/base
(require racket/match) (require racket/match)
(require "types.rkt") (require "structs.rkt")
(require "roles.rkt") (require "roles.rkt")
(require "vm.rkt") (require "vm.rkt")
(require "log-typed.rkt") (require "log.rkt")
(require "process.rkt") (require "process.rkt")
(require "action-delete-endpoint.rkt") (require "action-delete-endpoint.rkt")
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround (require "quasiqueue.rkt")
(require/typed web-server/private/util (require (only-in web-server/private/util exn->string))
[exn->string (exn -> String)])
(provide do-quit) (provide do-quit)
(: do-quit : (All (State) PID Reason (process State) vm ;; do-quit : (All (State) PID Reason (process State) vm
-> (values (Option (process State)) vm (QuasiQueue (Action vm))))) ;; -> (values (Option (process State)) vm (QuasiQueue (Action vm))))
(define (do-quit killed-pid reason p state) (define (do-quit killed-pid reason p state)
(: log-quit : (All (KilledState) (process KilledState) -> Void)) ;; log-quit : (All (KilledState) (process KilledState) -> Void)
(define (log-quit p) (define (log-quit p)
(marketplace-log (if reason 'warning 'info) (marketplace-log (if reason 'warning 'info)
"PID ~v (~a) quits with reason: ~a" "PID ~v (~a) quits with reason: ~a"
@ -36,9 +35,7 @@
(if (not maybe-killed-wp) (if (not maybe-killed-wp)
(values p state (empty-quasiqueue)) (values p state (empty-quasiqueue))
(apply values (apply values
(unwrap-process KilledState (let ((killed-p maybe-killed-wp))
(List (Option (process State)) vm (QuasiQueue (Action vm)))
(killed-p maybe-killed-wp)
(log-quit killed-p) (log-quit killed-p)
(let-values (((killed-p state meta-actions) (let-values (((killed-p state meta-actions)
(delete-all-endpoints reason killed-p state))) (delete-all-endpoints reason killed-p state)))

14
action-send-message.rkt
View File

@ -1,24 +1,22 @@
#lang typed/racket/base #lang racket/base
(require racket/match) (require racket/match)
(require "types.rkt") (require "structs.rkt")
(require "roles.rkt") (require "roles.rkt")
(require "vm.rkt") (require "vm.rkt")
(require "process.rkt") (require "process.rkt")
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
(provide do-send-message) (provide do-send-message)
(: do-send-message : (All (State) Orientation Message (process State) vm -> ;; do-send-message : (All (State) Orientation Message (process State) vm ->
(Values (Option (process State)) vm))) ;; (Values (Option (process State)) vm))
(define (do-send-message orientation body sender-p state) (define (do-send-message orientation body sender-p state)
(define message-role (role orientation body 'participant)) (define message-role (role orientation body 'participant))
(: send-to-process : (All (State) (process State) -> (process State))) ;; send-to-process : (All (State) (process State) -> (process State))
(define (send-to-process p) (define (send-to-process p)
(define endpoints (process-endpoints p)) (define endpoints (process-endpoints p))
(for/fold: : (process State) ([p p]) (for/fold ([p p]) ([eid (in-hash-keys endpoints)])
([eid (in-hash-keys endpoints)])
(define e (hash-ref endpoints eid)) (define e (hash-ref endpoints eid))
(cond (cond
[(role-intersection message-role (endpoint-role e)) [(role-intersection message-role (endpoint-role e))

46
action-spawn.rkt
View File

@ -1,46 +1,44 @@
#lang typed/racket/base #lang racket/base
(require racket/match) (require racket/match)
(require "types.rkt") (require "structs.rkt")
(require "roles.rkt") (require "roles.rkt")
(require "vm.rkt") (require "vm.rkt")
(require "log-typed.rkt") (require "log.rkt")
(require "process.rkt") (require "process.rkt")
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
(provide do-spawn) (provide do-spawn)
(: do-spawn : (All (OldState) ;; do-spawn : (All (OldState)
process-spec ;; process-spec
(Option (PID -> (InterruptK OldState))) ;; (Option (PID -> (InterruptK OldState)))
(process OldState) ;; (process OldState)
Any ;; Any
vm ;; vm
-> (Values (Option (process OldState)) vm))) ;; -> (Values (Option (process OldState)) vm))
(define (do-spawn spec parent-k p debug-name state) (define (do-spawn spec parent-k p debug-name state)
(define new-pid (vm-next-process-id state)) (define new-pid (vm-next-process-id state))
(marketplace-log 'info "PID ~v (~a) starting" new-pid debug-name) (marketplace-log 'info "PID ~v (~a) starting" new-pid debug-name)
(: new-cotransition : CoTransition) ;; new-cotransition : CoTransition
(define new-cotransition (define new-cotransition
(send-to-user* debug-name new-pid (e) (co-quit e) (send-to-user* debug-name new-pid (e) (co-quit e)
((process-spec-boot spec) new-pid))) ((process-spec-boot spec) new-pid)))
(: co-quit : Reason -> CoTransition) ;; co-quit : Reason -> CoTransition
(define ((co-quit e) k) (define ((co-quit e) k)
((inst k False) (transition #f (quit #f e)))) (k (transition #f (quit #f e))))
(: transition-accepter : (All (NewState) (Transition NewState) -> Process)) ;; transition-accepter : (All (NewState) (Transition NewState) -> Process)
(define (transition-accepter t) (define (transition-accepter t)
(match-define (transition initial-state initial-actions) t) (match-define (transition initial-state initial-actions) t)
(mkProcess ((inst process NewState) (process debug-name
debug-name new-pid
new-pid initial-state
initial-state '()
'() #hash()
#hash() #hash()
#hash() (action-tree->quasiqueue initial-actions)))
(action-tree->quasiqueue initial-actions))))
(let ((new-process (let ((new-process
(send-to-user* debug-name new-pid (e) (transition-accepter (transition #f (quit #f e))) (send-to-user* debug-name new-pid (e) (transition-accepter (transition #f (quit #f e)))
((inst new-cotransition Process) transition-accepter)))) (new-cotransition transition-accepter))))
(values (if parent-k (values (if parent-k
(run-ready p (send-to-user p (e) (quit-interruptk e) (run-ready p (send-to-user p (e) (quit-interruptk e)
(parent-k new-pid))) (parent-k new-pid)))

83
actions.rkt
View File

@ -1,10 +1,10 @@
#lang typed/racket/base #lang racket/base
(require racket/match) (require racket/match)
(require "types.rkt") (require "structs.rkt")
(require "roles.rkt") (require "roles.rkt")
(require "vm.rkt") (require "vm.rkt")
(require "log-typed.rkt") (require "log.rkt")
(require "process.rkt") (require "process.rkt")
(require "action-add-endpoint.rkt") (require "action-add-endpoint.rkt")
(require "action-delete-endpoint.rkt") (require "action-delete-endpoint.rkt")
@ -12,18 +12,17 @@
(require "action-spawn.rkt") (require "action-spawn.rkt")
(require "action-quit.rkt") (require "action-quit.rkt")
(require "list-utils.rkt") (require "list-utils.rkt")
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround (require "quasiqueue.rkt")
(provide run-vm) (provide run-vm)
(: dump-state : vm -> Any) ;; dump-state : vm -> Any
(define (dump-state state) (define (dump-state state)
`(vm (next-pid ,(vm-next-process-id state)) `(vm (next-pid ,(vm-next-process-id state))
(processes ,@(for/fold: : Any (processes ,@(for/fold ([acc '()])
([acc '()])
([pid (in-hash-keys (vm-processes state))]) ([pid (in-hash-keys (vm-processes state))])
(cons (list pid (let ((wp (hash-ref (vm-processes state) pid))) (cons (list pid (let ((wp (hash-ref (vm-processes state) pid)))
(unwrap-process State Any (p wp) (let ((p wp))
(list (match (process-state p) (list (match (process-state p)
[(? vm? v) (dump-state v)] [(? vm? v) (dump-state v)]
[v v]) [v v])
@ -32,16 +31,16 @@
(process-meta-endpoints p) (process-meta-endpoints p)
(process-pending-actions p))))) acc))))) (process-pending-actions p))))) acc)))))
(: run-vm : vm -> (Transition vm)) ;; run-vm : vm -> (Transition vm)
(define (run-vm state) (define (run-vm state)
;; for each pid, ;; for each pid,
;; extract the corresponding process. ;; extract the corresponding process.
;; run through its work items, collecting external actions. ;; run through its work items, collecting external actions.
;; put the process back. ;; put the process back.
;; return the new state and the external actions ;; return the new state and the external actions
(let next-process ((remaining-pids ((inst hash-keys PID Process) (vm-processes state))) (let next-process ((remaining-pids (hash-keys (vm-processes state)))
(state state) (state state)
(external-actions ((inst empty-quasiqueue (Action vm))))) (external-actions (empty-quasiqueue)))
(match remaining-pids (match remaining-pids
['() ['()
(let ((state (collect-dead-processes state)) (let ((state (collect-dead-processes state))
@ -54,7 +53,7 @@
(let-values (((state wp) (extract-process state pid))) (let-values (((state wp) (extract-process state pid)))
(if (not wp) (if (not wp)
(next-process remaining-pids state external-actions) (next-process remaining-pids state external-actions)
(unwrap-process State (transition vm) (p wp) (let ((p wp))
(let next-action (let next-action
([remaining-actions (quasiqueue->list (process-pending-actions p))] ([remaining-actions (quasiqueue->list (process-pending-actions p))]
[p (reset-pending-actions p)] [p (reset-pending-actions p)]
@ -63,7 +62,7 @@
(match remaining-actions (match remaining-actions
['() ['()
(next-process remaining-pids (next-process remaining-pids
(inject-process state (mkProcess p)) (inject-process state p)
external-actions)] external-actions)]
[(cons action remaining-actions) [(cons action remaining-actions)
(marketplace-log 'debug (marketplace-log 'debug
@ -84,20 +83,19 @@
(quasiqueue-append external-actions (quasiqueue-append external-actions
new-external-actions))))])))))]))) new-external-actions))))])))))])))
(: collect-dead-processes : vm -> vm) ;; collect-dead-processes : vm -> vm
(define (collect-dead-processes state) (define (collect-dead-processes state)
(: process-alive? : (All (State) (process State) -> Boolean)) ;; process-alive? : (All (State) (process State) -> Boolean)
(define (process-alive? p) (define (process-alive? p)
(or (not (null? (process-spawn-ks p))) (or (not (null? (process-spawn-ks p)))
(positive? (hash-count (process-endpoints p))) (positive? (hash-count (process-endpoints p)))
(positive? (hash-count (process-meta-endpoints p))) (positive? (hash-count (process-meta-endpoints p)))
(not (quasiqueue-empty? (process-pending-actions p))))) (not (quasiqueue-empty? (process-pending-actions p)))))
(struct-copy vm state (struct-copy vm state
[processes (for/fold: : (HashTable PID Process) [processes (for/fold ([processes #hash()])
([processes (ann #hash() (HashTable PID Process))])
([pid (in-hash-keys (vm-processes state))]) ([pid (in-hash-keys (vm-processes state))])
(define wp (hash-ref (vm-processes state) pid)) (define wp (hash-ref (vm-processes state) pid))
(unwrap-process State (HashTable PID Process) (p wp) (let ((p wp))
(if (process-alive? p) (if (process-alive? p)
(hash-set processes pid wp) (hash-set processes pid wp)
(begin (marketplace-log 'info (begin (marketplace-log 'info
@ -106,20 +104,21 @@
(process-debug-name p)) (process-debug-name p))
processes))))])) processes))))]))
(: vm-idle? : vm -> Boolean) ;; vm-idle? : vm -> Boolean
;; TODO: simplify
(define (vm-idle? state) (define (vm-idle? state)
(andmap (lambda (#{pid : PID}) (andmap (lambda (pid)
(define wp (hash-ref (vm-processes state) pid)) (define wp (hash-ref (vm-processes state) pid))
(unwrap-process State Boolean (p wp) (let ((p wp))
(quasiqueue-empty? (process-pending-actions p)))) (quasiqueue-empty? (process-pending-actions p))))
(hash-keys (vm-processes state)))) (hash-keys (vm-processes state))))
(: perform-action : (All (State) (Action State) (process State) vm ;; perform-action : (All (State) (Action State) (process State) vm
-> (Values (Option (process State)) vm (QuasiQueue (Action vm))))) ;; -> (Values (Option (process State)) vm (QuasiQueue (Action vm))))
(define (perform-action action p state) (define (perform-action action p state)
(match action (match action
[(at-meta-level preaction) [(at-meta-level preaction)
((inst transform-meta-action State) preaction p state)] (transform-meta-action preaction p state)]
[(yield k) [(yield k)
(let ((p (run-ready p k))) (let ((p (run-ready p k)))
(values p state (empty-quasiqueue)))] (values p state (empty-quasiqueue)))]
@ -140,39 +139,39 @@
new-state new-state
(empty-quasiqueue))])) (empty-quasiqueue))]))
(: wrap-trapk : eid -> (Handler vm)) ;; wrap-trapk : eid -> (Handler vm)
(define (((wrap-trapk target-eid) event) state) (define (((wrap-trapk target-eid) event) state)
(match-define (eid pid pre-eid) target-eid) (match-define (eid pid pre-eid) target-eid)
(run-vm (run-vm
(let-values (((state wp) (extract-process state pid))) (let-values (((state wp) (extract-process state pid)))
(if (not wp) (if (not wp)
state state
(unwrap-process State vm (p wp) (let ((p wp))
(define ep (hash-ref (process-meta-endpoints p) pre-eid always-false)) (define ep (hash-ref (process-meta-endpoints p) pre-eid always-false))
(if (not ep) (if (not ep)
(inject-process state (mkProcess p)) (inject-process state p)
(let ((p (run-ready p (send-to-user p (e) (quit-interruptk e) (let ((p (run-ready p (send-to-user p (e) (quit-interruptk e)
((endpoint-handler ep) event))))) ((endpoint-handler ep) event)))))
(inject-process state (mkProcess p))))))))) (inject-process state p))))))))
(: dispatch-spawn-k : PID Integer -> (TrapK PID vm)) ;; dispatch-spawn-k : PID Integer -> (TrapK PID vm)
(define (((dispatch-spawn-k pid spawn-k-id) new-pid) state) (define (((dispatch-spawn-k pid spawn-k-id) new-pid) state)
(run-vm (run-vm
(let-values (((state wp) (extract-process state pid))) (let-values (((state wp) (extract-process state pid)))
(if (not wp) (if (not wp)
state state
(unwrap-process State vm (p wp) (let ((p wp))
(match (assoc spawn-k-id (process-spawn-ks p)) (match (assoc spawn-k-id (process-spawn-ks p))
[#f [#f
(inject-process state (mkProcess p))] (inject-process state p)]
[(and entry (cons _ k)) [(and entry (cons _ k))
(define interruptk (send-to-user p (e) (quit-interruptk e) (define interruptk (send-to-user p (e) (quit-interruptk e)
(k new-pid))) (k new-pid)))
(define p1 (struct-copy process p [spawn-ks (remq entry (process-spawn-ks p))])) (define p1 (struct-copy process p [spawn-ks (remq entry (process-spawn-ks p))]))
(inject-process state (mkProcess (run-ready p1 interruptk)))])))))) (inject-process state (run-ready p1 interruptk))]))))))
(: transform-meta-action : (All (State) (PreAction State) (process State) vm -> ;; transform-meta-action : (All (State) (PreAction State) (process State) vm ->
(Values (Option (process State)) vm (QuasiQueue (Action vm))))) ;; (Values (Option (process State)) vm (QuasiQueue (Action vm))))
(define (transform-meta-action pa p state) (define (transform-meta-action pa p state)
(match pa (match pa
[(add-endpoint pre-eid role unwrapped-handler) [(add-endpoint pre-eid role unwrapped-handler)
@ -180,13 +179,12 @@
(values (struct-copy process p (values (struct-copy process p
[meta-endpoints (hash-set (process-meta-endpoints p) [meta-endpoints (hash-set (process-meta-endpoints p)
pre-eid pre-eid
((inst endpoint State) (endpoint new-eid
new-eid role
role unwrapped-handler))])
unwrapped-handler))])
state state
(quasiqueue (quasiqueue
(add-endpoint (cast new-eid PreEID) (add-endpoint new-eid
role role
(wrap-trapk new-eid))))] (wrap-trapk new-eid))))]
[(delete-endpoint pre-eid reason) [(delete-endpoint pre-eid reason)
@ -194,7 +192,7 @@
(values (struct-copy process p (values (struct-copy process p
[meta-endpoints (hash-remove (process-meta-endpoints p) pre-eid)]) [meta-endpoints (hash-remove (process-meta-endpoints p) pre-eid)])
state state
(quasiqueue (delete-endpoint (cast old-eid PreEID) reason)))] (quasiqueue (delete-endpoint old-eid reason)))]
[(send-message body orientation) [(send-message body orientation)
(values p (values p
state state
@ -202,15 +200,14 @@
[(spawn spec k debug-name) [(spawn spec k debug-name)
(define pid (process-pid p)) (define pid (process-pid p))
(if k (if k
(let ((spawn-k-id (+ 1 (list-max (map (inst car Integer (TrapK PID State)) (let ((spawn-k-id (+ 1 (list-max (map car (process-spawn-ks p))))))
(process-spawn-ks p))))))
(values (struct-copy process p (values (struct-copy process p
[spawn-ks (cons (cons spawn-k-id k) (process-spawn-ks p))]) [spawn-ks (cons (cons spawn-k-id k) (process-spawn-ks p))])
state state
(quasiqueue (spawn spec (dispatch-spawn-k pid spawn-k-id) debug-name)))) (quasiqueue (spawn spec (dispatch-spawn-k pid spawn-k-id) debug-name))))
(values p (values p
state state
(quasiqueue ((inst spawn vm) spec #f debug-name))))] (quasiqueue (spawn spec #f debug-name))))]
[(quit maybe-pid reason) [(quit maybe-pid reason)
(values p (values p
state state

43
drivers/event-relay.rkt
View File

@ -1,30 +1,27 @@
#lang typed/racket/base #lang racket/base
;; Ground-event relay. ;; Ground-event relay.
(provide event-relay) (provide event-relay)
(require "../sugar-typed.rkt") (require "../sugar.rkt")
(require "../support/event.rkt")
(: event-relay : (All (ParentState) Symbol -> (Spawn ParentState))) ;; event-relay : (All (ParentState) Symbol -> (Spawn ParentState))
(define (event-relay self-id) (define (event-relay self-id)
(name-process `(event-relay ,self-id) (name-process `(event-relay ,self-id)
(spawn: #:parent : ParentState (spawn (transition/no-state
#:child : Void (observe-subscribers (cons ? ?)
(transition/no-state (match-conversation (cons (? evt? e) _)
(observe-subscribers: Void (cons ? ?) (on-presence (begin
(match-conversation (cons (? evt? e) _) (printf "SUBSCRIBED ~v~n" e)
(on-presence (begin
(printf "SUBSCRIBED ~v~n" e)
(flush-output)
(at-meta-level: Void
(name-endpoint `(event-relay ,self-id ,e)
(subscriber: Void (cons e ?)
(on-message
[msg (begin (printf "FIRED ~v -> ~v~n" e msg)
(flush-output)
(send-message msg))]))))))
(on-absence (begin
(printf "UNSUBSCRIBED ~v~n" e)
(flush-output) (flush-output)
(at-meta-level: Void (at-meta-level
(delete-endpoint `(event-relay ,self-id ,e))))))))))) (name-endpoint `(event-relay ,self-id ,e)
(subscriber (cons e ?)
(on-message
[msg (begin (printf "FIRED ~v -> ~v~n" e msg)
(flush-output)
(send-message msg))]))))))
(on-absence (begin
(printf "UNSUBSCRIBED ~v~n" e)
(flush-output)
(at-meta-level
(delete-endpoint `(event-relay ,self-id ,e)))))))))))

3
drivers/tcp-bare-with-ground.rkt
View File

@ -5,8 +5,9 @@
(require racket/match) (require racket/match)
(require (prefix-in tcp: racket/tcp)) (require (prefix-in tcp: racket/tcp))
(require racket/port) (require racket/port)
(require "../sugar-untyped.rkt") (require "../sugar.rkt")
(require "../support/dump-bytes.rkt") (require "../support/dump-bytes.rkt")
(require "../unify.rkt")
(provide (struct-out tcp-address) (provide (struct-out tcp-address)
(struct-out tcp-handle) (struct-out tcp-handle)

2
drivers/tcp-bare.rkt
View File

@ -5,7 +5,7 @@
(require racket/match) (require racket/match)
(require (prefix-in tcp: racket/tcp)) (require (prefix-in tcp: racket/tcp))
(require racket/port) (require racket/port)
(require "../sugar-untyped.rkt") (require "../sugar.rkt")
(require "../support/dump-bytes.rkt") (require "../support/dump-bytes.rkt")
(provide (struct-out tcp-address) (provide (struct-out tcp-address)

3
drivers/tcp.rkt
View File

@ -5,8 +5,9 @@
(require racket/match) (require racket/match)
(require (prefix-in tcp: racket/tcp)) (require (prefix-in tcp: racket/tcp))
(require racket/port) (require racket/port)
(require "../sugar-untyped.rkt") (require "../sugar.rkt")
(require "../support/dump-bytes.rkt") (require "../support/dump-bytes.rkt")
(require "../unify.rkt")
(provide (struct-out tcp-address) (provide (struct-out tcp-address)
(struct-out tcp-handle) (struct-out tcp-handle)

13
drivers/timer-untyped.rkt
View File

@ -1,13 +0,0 @@
#lang racket/base
;; Untyped-Racket support for Timer driver.
(require "timer.rkt")
(provide (except-out (all-from-out "timer.rkt")
set-timer
set-timer-pattern
timer-expired
timer-expired-pattern)
(rename-out [set-timer-repr set-timer]
[set-timer-repr set-timer-pattern]
[timer-expired-repr timer-expired]
[timer-expired-repr timer-expired-pattern]))

179
drivers/timer.rkt
View File

@ -1,4 +1,4 @@
#lang typed/racket/base #lang racket/base
;; Timer driver. ;; Timer driver.
;; Uses mutable state internally, but because the scope of the ;; Uses mutable state internally, but because the scope of the
@ -7,103 +7,48 @@
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
(require "../sugar-typed.rkt") (require data/heap)
(require "../support/event.rkt") (require "../sugar.rkt")
(require "../support/pseudo-substruct.rkt")
(require/typed typed/racket/base
[wrap-evt (Evt (Any -> Real) -> Evt)])
;; (pending-timer AbsoluteSeconds Any Boolean) ;; (pending-timer AbsoluteSeconds Any Boolean)
;; An outstanding timer being managed by the timer-driver. ;; An outstanding timer being managed by the timer-driver.
(struct: pending-timer ([deadline : Real] (struct pending-timer (deadline ;; Real
[label : TimerLabel]) label ;; TimerLabel
#:transparent) )
#:transparent)
(require/typed data/heap
[opaque Heap heap?]
[make-heap ((pending-timer pending-timer -> Boolean) -> Heap)]
[heap-count (Heap -> Exact-Nonnegative-Integer)]
[heap-min (Heap -> pending-timer)]
[heap-remove-min! (Heap -> Void)]
[heap-add! (Heap pending-timer * -> Void)])
(require/typed typed/racket/base
[alarm-evt (Real -> Evt)])
(provide TimerLabel
TimerKind
(struct-out set-timer-repr)
SetTimer
SetTimerPattern
set-timer
set-timer?
set-timer-pattern
set-timer-pattern?
(struct-out timer-expired-repr)
TimerExpired
TimerExpiredPattern
timer-expired
timer-expired?
timer-expired-pattern
timer-expired-pattern?
(provide (struct-out set-timer)
(struct-out timer-expired)
timer-driver timer-driver
timer-relay) timer-relay)
(define-type TimerLabel Any) ;; (define-type TimerKind (U 'relative 'absolute))
(define-type TimerKind (U 'relative 'absolute))
;; The timer driver and timer relays listen for messages of this type, ;; The timer driver and timer relays listen for messages of this type,
;; and when they hear one, they set an alarm that will later send a ;; and when they hear one, they set an alarm that will later send a
;; corresponding timer-expired message. ;; corresponding timer-expired message.
(struct: (TLabel TMsecs TKind) (struct set-timer (label msecs kind) #:transparent)
set-timer-repr ([label : TLabel]
[msecs : TMsecs]
[kind : TKind])
#:transparent)
(pseudo-substruct: (set-timer-repr TimerLabel Real TimerKind)
SetTimer set-timer set-timer?)
(pseudo-substruct: (set-timer-repr (U Wild TimerLabel)
(U Wild Real)
(U Wild TimerKind))
SetTimerPattern set-timer-pattern set-timer-pattern?)
;; Message sent by the timer driver or a timer relay upon expiry of a ;; Message sent by the timer driver or a timer relay upon expiry of a
;; timer. Contains the label specified in the corresponding set-timer ;; timer. Contains the label specified in the corresponding set-timer
;; message, and also the current absolute time from the outside world. ;; message, and also the current absolute time from the outside world.
(struct: (TLabel TMsecs) (struct timer-expired (label msecs) #:transparent)
timer-expired-repr ([label : TLabel]
[msecs : TMsecs])
#:transparent)
(pseudo-substruct: (timer-expired-repr TimerLabel Real)
TimerExpired timer-expired timer-expired?)
(pseudo-substruct: (timer-expired-repr (U Wild TimerLabel) (U Wild Real))
TimerExpiredPattern timer-expired-pattern timer-expired-pattern?)
;; State of a timer-driver, including the identifier of the driver, ;; State of a timer-driver, including the identifier of the driver,
;; the currently-active subscription to ground time events (if any), ;; the currently-active subscription to ground time events (if any),
;; and the heap of all remaining timers. ;; and the heap of all remaining timers.
(struct: driver-state ([heap : Heap]) #:transparent) (struct driver-state (heap) #:transparent)
(define-type DriverState driver-state) ;; (define-type RelayKey Exact-Nonnegative-Integer)
(define-type RelayKey Exact-Nonnegative-Integer)
;; State of a timer-relay, including the next timer number and a ;; State of a timer-relay, including the next timer number and a
;; mapping from timer number to timer label. ;; mapping from timer number to timer label.
(struct: relay-state ([next-counter : RelayKey] (struct relay-state (next-counter ;; RelayKey
[active-timers : (HashTable RelayKey TimerLabel)]) active-timers ;; (HashTable RelayKey TimerLabel)
#:transparent) )
#:transparent)
(define-type RelayState relay-state) ;; (define-type RelayState relay-state)
;; Note that (set-timer 'current-time 0 #f) causes an immediate reply ;; Note that (set-timer 'current-time 0 #f) causes an immediate reply
;; of (timer-expired 'current-time (current-inexact-milliseconds)), ;; of (timer-expired 'current-time (current-inexact-milliseconds)),
@ -114,18 +59,18 @@
;; synchronisation value should be the (or some) value of the clock ;; synchronisation value should be the (or some) value of the clock
;; after the asked-for time. That way it serves as timeout and ;; after the asked-for time. That way it serves as timeout and
;; clock-reader in one. ;; clock-reader in one.
(: timer-evt : Real -> Evt) ;; timer-evt : Real -> Evt
(define (timer-evt msecs) (define (timer-evt msecs)
(wrap-evt (alarm-evt msecs) (wrap-evt (alarm-evt msecs)
(lambda (_) (current-inexact-milliseconds)))) (lambda (_) (current-inexact-milliseconds))))
(: make-timer-heap : -> Heap) ;; make-timer-heap : -> Heap
(define (make-timer-heap) (define (make-timer-heap)
(make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1) (pending-timer-deadline t2))))) (make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1) (pending-timer-deadline t2)))))
;; Retrieves the earliest-deadline timer from the heap, if there is ;; Retrieves the earliest-deadline timer from the heap, if there is
;; one. ;; one.
(: next-timer! : Heap -> (Option pending-timer)) ;; next-timer! : Heap -> (Option pending-timer)
(define (next-timer! heap) (define (next-timer! heap)
(if (zero? (heap-count heap)) (if (zero? (heap-count heap))
#f #f
@ -133,7 +78,7 @@
;; Retrieves (and removes) all timers from the heap that have deadline ;; Retrieves (and removes) all timers from the heap that have deadline
;; earlier or equal to the time passed in. ;; earlier or equal to the time passed in.
(: fire-timers! : Heap Real -> (Listof SendMessage)) ;; fire-timers! : Heap Real -> (Listof SendMessage)
(define (fire-timers! heap now) (define (fire-timers! heap now)
(if (zero? (heap-count heap)) (if (zero? (heap-count heap))
'() '()
@ -146,70 +91,64 @@
;; Process for mapping this-level timer requests to ground-level timer ;; Process for mapping this-level timer requests to ground-level timer
;; events and back. ;; events and back.
(: timer-driver : (All (ParentState) -> (Spawn ParentState))) ;; timer-driver : (All (ParentState) -> (Spawn ParentState))
(define (timer-driver) (define (timer-driver)
(name-process 'timer-driver (name-process 'timer-driver
(spawn: #:parent : ParentState (spawn (transition (driver-state (make-timer-heap))
#:child : DriverState (subscriber (set-timer (wild) (wild) (wild))
(transition: (driver-state (make-timer-heap)) : DriverState (match-state state
(subscriber: DriverState (set-timer-pattern (wild) (wild) (wild)) (on-message
(match-state state [(set-timer label msecs 'relative)
(on-message (install-timer! state label (+ (current-inexact-milliseconds) msecs))]
[(set-timer label msecs 'relative) [(set-timer label msecs 'absolute)
(install-timer! state label (+ (current-inexact-milliseconds) msecs))] (install-timer! state label msecs)])))
[(set-timer label msecs 'absolute) (publisher (timer-expired (wild) (wild)))))))
(install-timer! state label msecs)])))
(publisher: DriverState (timer-expired-pattern (wild) (wild)))))))
(: install-timer! : DriverState TimerLabel Real -> (Transition DriverState)) ;; install-timer! : DriverState TimerLabel Real -> (Transition DriverState)
(define (install-timer! state label deadline) (define (install-timer! state label deadline)
(heap-add! (driver-state-heap state) (pending-timer deadline label)) (heap-add! (driver-state-heap state) (pending-timer deadline label))
(update-time-listener! state)) (update-time-listener! state))
(: update-time-listener! : DriverState -> (Transition DriverState)) ;; update-time-listener! : DriverState -> (Transition DriverState)
(define (update-time-listener! state) (define (update-time-listener! state)
(define next (next-timer! (driver-state-heap state))) (define next (next-timer! (driver-state-heap state)))
(transition: state : DriverState (transition state
(delete-endpoint 'time-listener) (delete-endpoint 'time-listener)
(and next (and next
(name-endpoint 'time-listener (name-endpoint 'time-listener
(subscriber: DriverState (cons (timer-evt (pending-timer-deadline next)) (wild)) (subscriber (cons (timer-evt (pending-timer-deadline next)) (wild))
(match-state state (match-state state
(on-message (on-message
[(cons (? evt?) (? real? now)) [(cons (? evt?) (? real? now))
(let ((to-send (fire-timers! (driver-state-heap state) now))) (let ((to-send (fire-timers! (driver-state-heap state) now)))
;; Note: compute to-send before recursing, because of side-effects on heap ;; Note: compute to-send before recursing, because of side-effects on heap
(sequence-actions (transition: state : DriverState) (sequence-actions (transition state)
update-time-listener! update-time-listener!
to-send))]))))))) to-send))])))))))
;; Process for mapping this-level timer requests to meta-level timer ;; Process for mapping this-level timer requests to meta-level timer
;; requests. Useful when running nested VMs: essentially extends timer ;; requests. Useful when running nested VMs: essentially extends timer
;; support up the branches of the VM tree toward the leaves. ;; support up the branches of the VM tree toward the leaves.
(: timer-relay : (All (ParentState) Symbol -> (Spawn ParentState))) ;; timer-relay : (All (ParentState) Symbol -> (Spawn ParentState))
(define (timer-relay self-id) (define (timer-relay self-id)
(name-process `(timer-relay ,self-id) (name-process `(timer-relay ,self-id)
(spawn: #:parent : ParentState (spawn (transition (relay-state 0 (make-immutable-hash '()))
#:child : RelayState (at-meta-level
(transition: (relay-state 0 (make-immutable-hash '())) : RelayState (subscriber (timer-expired (wild) (wild))
(at-meta-level: RelayState
(subscriber: RelayState (timer-expired-pattern (wild) (wild))
(match-state (relay-state next-counter active-timers)
(on-message
[(timer-expired (list (== self-id) (? exact-nonnegative-integer? counter))
now)
(transition: (relay-state next-counter (hash-remove active-timers counter))
: RelayState
(and (hash-has-key? active-timers counter)
(send-message (timer-expired (hash-ref active-timers counter)
now))))]))))
(subscriber: RelayState (set-timer-pattern (wild) (wild) (wild))
(match-state (relay-state next-counter active-timers) (match-state (relay-state next-counter active-timers)
(on-message (on-message
[(set-timer label msecs kind) [(timer-expired (list (== self-id) (? exact-nonnegative-integer? counter))
(transition: (relay-state (+ next-counter 1) now)
(hash-set active-timers next-counter label)) (transition (relay-state next-counter (hash-remove active-timers counter))
: RelayState (and (hash-has-key? active-timers counter)
(at-meta-level: RelayState (send-message (timer-expired (hash-ref active-timers counter)
(send-message (set-timer (list self-id next-counter) msecs kind))))]))) now))))]))))
(publisher: RelayState (timer-expired-pattern (wild) (wild))))))) (subscriber (set-timer (wild) (wild) (wild))
(match-state (relay-state next-counter active-timers)
(on-message
[(set-timer label msecs kind)
(transition (relay-state (+ next-counter 1)
(hash-set active-timers next-counter label))
(at-meta-level
(send-message (set-timer (list self-id next-counter) msecs kind))))])))
(publisher (timer-expired (wild) (wild)))))))

21
drivers/udp-untyped.rkt
View File

@ -1,21 +0,0 @@
#lang racket/base
;; UDP driver. Untyped macro wrappers
(require "udp.rkt")
(provide (except-out (all-from-out "udp.rkt")
udp-remote-address
udp-remote-address-pattern
udp-handle
udp-handle-pattern
udp-listener
udp-listener-pattern
udp-packet
udp-packet-pattern)
(rename-out [udp-remote-address-repr udp-remote-address]
[udp-remote-address-repr udp-remote-address-pattern]
[udp-handle-repr udp-handle]
[udp-handle-repr udp-handle-pattern]
[udp-listener-repr udp-listener]
[udp-listener-repr udp-listener-pattern]
[udp-packet-repr udp-packet]
[udp-packet-repr udp-packet-pattern]))

200
drivers/udp.rkt
View File

@ -1,43 +1,20 @@
#lang typed/racket/base #lang racket/base
;; UDP driver. ;; UDP driver.
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
(require racket/udp)
(require "../support/event.rkt") (require "../sugar.rkt")
(require (except-in racket/udp udp-receive!-evt))
(require/typed racket/udp
[udp-receive!-evt (UDP-Socket Bytes -> Evt)])
(require "../sugar-typed.rkt") (provide (struct-out udp-remote-address)
(require "../support/event.rkt") (struct-out udp-handle)
(require "../support/pseudo-substruct.rkt") (struct-out udp-listener)
(provide (struct-out udp-remote-address-repr)
UdpRemoteAddress udp-remote-address udp-remote-address?
UdpRemoteAddressPattern udp-remote-address-pattern udp-remote-address-pattern?
(struct-out udp-handle-repr)
UdpHandle udp-handle udp-handle?
UdpHandlePattern udp-handle-pattern udp-handle-pattern?
(struct-out udp-listener-repr)
UdpListener udp-listener udp-listener?
UdpListenerPattern udp-listener-pattern udp-listener-pattern?
UdpAddress
UdpAddressPattern
UdpLocalAddress
udp-address? udp-address?
udp-address-pattern?
udp-local-address? udp-local-address?
(struct-out udp-packet-repr) (struct-out udp-packet)
UdpPacket udp-packet udp-packet?
UdpPacketPattern udp-packet-pattern udp-packet-pattern?
udp-driver) udp-driver)
;; A UdpAddress is one of ;; A UdpAddress is one of
@ -48,171 +25,122 @@
;; to the local VM, i.e. shared between processes in that VM, so ;; to the local VM, i.e. shared between processes in that VM, so
;; processes must make sure not to accidentally clash in handle ID ;; processes must make sure not to accidentally clash in handle ID
;; selection. ;; selection.
(struct: (THost TPort) (struct udp-remote-address (host port) #:transparent)
udp-remote-address-repr ([host : THost] (struct udp-handle (id) #:transparent)
[port : TPort]) (struct udp-listener (port) #:transparent)
#:transparent)
(pseudo-substruct: (udp-remote-address-repr String Natural)
UdpRemoteAddress udp-remote-address udp-remote-address?)
(pseudo-substruct: (udp-remote-address-repr (U Wild String) (U Wild Natural))
UdpRemoteAddressPattern udp-remote-address-pattern udp-remote-address-pattern?)
(struct: (TId) (define (udp-address? x)
udp-handle-repr ([id : TId]) (or (udp-remote-address? x)
#:transparent) (udp-handle? x)
(pseudo-substruct: (udp-handle-repr Any) (udp-listener? x)))
UdpHandle udp-handle udp-handle?)
(pseudo-substruct: (udp-handle-repr (U Wild Any))
UdpHandlePattern udp-handle-pattern udp-handle-pattern?)
(struct: (TPort) (define (udp-local-address? x)
udp-listener-repr ([port : TPort]) (or (udp-handle? x)
#:transparent) (udp-listener? x)))
(pseudo-substruct: (udp-listener-repr Natural)
UdpListener udp-listener udp-listener?)
(pseudo-substruct: (udp-listener-repr (U Wild Natural))
UdpListenerPattern udp-listener-pattern udp-listener-pattern?)
(define-type UdpAddress (U UdpRemoteAddress UdpHandle UdpListener))
(define-type UdpAddressPattern (U Wild UdpRemoteAddressPattern UdpHandlePattern UdpListenerPattern))
(define-type UdpLocalAddress (U UdpHandle UdpListener))
(define-predicate udp-address? UdpAddress)
(define-predicate udp-address-pattern? UdpAddressPattern)
(define-predicate udp-local-address? UdpLocalAddress)
;; A UdpPacket is a (udp-packet UdpAddress UdpAddress Bytes), and ;; A UdpPacket is a (udp-packet UdpAddress UdpAddress Bytes), and
;; represents a packet appearing on our local "subnet" of the full UDP ;; represents a packet appearing on our local "subnet" of the full UDP
;; network, complete with source, destination and contents. ;; network, complete with source, destination and contents.
(struct: (TSource TDestination TBody) (struct udp-packet (source destination body) #:transparent)
udp-packet-repr ([source : TSource]
[destination : TDestination]
[body : TBody])
#:transparent)
(pseudo-substruct: (udp-packet-repr UdpAddress UdpAddress Bytes)
UdpPacket udp-packet udp-packet?)
(pseudo-substruct: (udp-packet-repr UdpAddressPattern UdpAddressPattern (U Wild Bytes))
UdpPacketPattern udp-packet-pattern udp-packet-pattern?)
;; A HandleMapping is a record describing a mapping between a local ;; A HandleMapping is a record describing a mapping between a local
;; UdpAddress and its underlying UDP socket. It's private to the ;; UdpAddress and its underlying UDP socket. It's private to the
;; implementation of the driver. ;; implementation of the driver.
(struct: (TAddress TSocket) (struct handle-mapping (address socket) #:transparent)
handle-mapping-repr ([address : TAddress]
[socket : TSocket])
#:transparent)
(pseudo-substruct: (handle-mapping-repr UdpLocalAddress Any)
;; ^ TODO: Want to use UDP-Socket instead of Any here
HandleMapping handle-mapping handle-mapping?)
(pseudo-substruct: (handle-mapping-repr (U Wild UdpLocalAddress) (U Wild Any))
HandleMappingPattern handle-mapping-pattern handle-mapping-pattern?)
;; TODO: BUG?: Routing packets between two local sockets won't work ;; TODO: BUG?: Routing packets between two local sockets won't work
;; because the patterns aren't set up to recognise that situation. ;; because the patterns aren't set up to recognise that situation.
;; represents any remote address ;; represents any remote address
(: any-remote : UdpAddressPattern) ;; any-remote : UdpAddressPattern
(define any-remote (udp-remote-address-pattern (wild) (wild))) (define any-remote (udp-remote-address (wild) (wild)))
(define-type DriverState (Setof UdpLocalAddress)) ;; (define-type DriverState (Setof UdpLocalAddress))
(define-type SocketManagerState Boolean) ;; (define-type SocketManagerState Boolean)
;; Process acting as a UDP socket factory. ;; Process acting as a UDP socket factory.
(: udp-driver : (All (ParentState) -> (Spawn ParentState))) ;; udp-driver : (All (ParentState) -> (Spawn ParentState))
(define (udp-driver) (define (udp-driver)
(: handle-presence : Topic DriverState -> (Transition DriverState)) ;; handle-presence : Topic DriverState -> (Transition DriverState)
(define (handle-presence topic active-handles) (define (handle-presence topic active-handles)
(match-define (udp-packet-pattern _ (? udp-local-address? local-addr) _) topic) (match-define (udp-packet _ (? udp-local-address? local-addr) _) topic)
(cond (cond
[(set-member? active-handles local-addr) [(set-member? active-handles local-addr)
(transition: active-handles : DriverState)] (transition active-handles)]
[else [else
(transition: (set-add active-handles local-addr) : DriverState (transition (set-add active-handles local-addr)
(udp-socket-manager local-addr))])) (udp-socket-manager local-addr))]))
(name-process 'udp-driver (name-process 'udp-driver
(spawn: #:parent : ParentState (spawn (transition (set)
#:child : DriverState
(transition: ((inst set UdpLocalAddress)) : DriverState
(observe-subscribers: DriverState (observe-subscribers (udp-packet any-remote (udp-handle (wild)) (wild))
(udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild)) (match-state active-handles
(match-state active-handles (match-conversation topic
(match-conversation topic (on-presence (handle-presence topic active-handles)))))
(on-presence (handle-presence topic active-handles))))) (observe-subscribers (udp-packet any-remote (udp-listener (wild)) (wild))
(observe-subscribers: DriverState (match-state active-handles
(udp-packet-pattern any-remote (udp-listener-pattern (wild)) (wild)) (match-conversation topic
(match-state active-handles (on-presence (handle-presence topic active-handles)))))
(match-conversation topic (observe-publishers (udp-packet any-remote (udp-handle (wild)) (wild))
(on-presence (handle-presence topic active-handles))))) (match-state active-handles
(observe-publishers: DriverState (match-conversation topic
(udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild)) (on-presence (handle-presence topic active-handles)))))
(match-state active-handles (observe-publishers (udp-packet any-remote (udp-listener (wild)) (wild))
(match-conversation topic (match-state active-handles
(on-presence (handle-presence topic active-handles))))) (match-conversation topic
(observe-publishers: DriverState (on-presence (handle-presence topic active-handles)))))
(udp-packet-pattern any-remote (udp-listener-pattern (wild)) (wild))
(match-state active-handles
(match-conversation topic
(on-presence (handle-presence topic active-handles)))))
(observe-publishers: DriverState (handle-mapping-pattern (wild) (wild)) (observe-publishers (handle-mapping (wild) (wild))
(match-state active-handles (match-state active-handles
(match-conversation (handle-mapping local-addr socket) (match-conversation (handle-mapping local-addr socket)
(on-absence (on-absence
(transition: (set-remove active-handles local-addr) : DriverState))))) (transition (set-remove active-handles local-addr))))))
)))) ))))
(: bind-socket! : UDP-Socket UdpLocalAddress -> Void) ;; bind-socket! : UDP-Socket UdpLocalAddress -> Void
(define (bind-socket! s local-addr) (define (bind-socket! s local-addr)
(match local-addr (match local-addr
[(udp-listener port) (udp-bind! s #f port)] [(udp-listener port) (udp-bind! s #f port)]
[(udp-handle _) (udp-bind! s #f 0)] [(udp-handle _) (udp-bind! s #f 0)]
[else (void)])) [else (void)]))
(: valid-port-number? : Any -> Boolean : Natural) ;; valid-port-number? : Any -> Boolean : Natural
(define (valid-port-number? x) (define (valid-port-number? x)
;; Eventually TR will know about ranges ;; Eventually TR will know about ranges
(exact-nonnegative-integer? x)) (exact-nonnegative-integer? x))
(: udp-socket-manager : UdpLocalAddress -> (Spawn DriverState)) ;; udp-socket-manager : UdpLocalAddress -> (Spawn DriverState)
(define (udp-socket-manager local-addr) (define (udp-socket-manager local-addr)
(define s (udp-open-socket #f #f)) (define s (udp-open-socket #f #f))
(bind-socket! s local-addr) (bind-socket! s local-addr)
(define buffer (make-bytes 65536)) ;; TODO: buffer size control (define buffer (make-bytes 65536)) ;; TODO: buffer size control
(: handle-absence : SocketManagerState -> (Transition SocketManagerState)) ;; handle-absence : SocketManagerState -> (Transition SocketManagerState)
(define (handle-absence socket-is-open?) (define (handle-absence socket-is-open?)
(transition: #f : SocketManagerState (transition #f
(quit) (quit)
(when socket-is-open? (when socket-is-open?
(name-process `(udp-socket-closer ,local-addr) (name-process `(udp-socket-closer ,local-addr)
(spawn: #:parent : SocketManagerState (spawn (begin (udp-close s)
#:child : Void (transition (void) (quit))))))))
(begin (udp-close s)
(transition: (void) : Void (quit))))))))
(name-process `(udp-socket-manager ,local-addr) (name-process `(udp-socket-manager ,local-addr)
(spawn: #:parent : DriverState (spawn (transition #t
#:child : SocketManagerState
(transition: #t : SocketManagerState
;; Offers a handle-mapping on the local network so that ;; Offers a handle-mapping on the local network so that
;; the driver/factory can clean up when this process dies. ;; the driver/factory can clean up when this process dies.
(publisher: SocketManagerState (handle-mapping local-addr s)) (publisher (handle-mapping local-addr s))
;; If our counterparty removes either of their endpoints ;; If our counterparty removes either of their endpoints
;; as the subscriber end of the remote-to-local stream or ;; as the subscriber end of the remote-to-local stream or
;; the publisher end of the local-to-remote stream, shut ;; the publisher end of the local-to-remote stream, shut
;; ourselves down. Also, relay messages published on the ;; ourselves down. Also, relay messages published on the
;; local-to-remote stream out on the actual socket. ;; local-to-remote stream out on the actual socket.
(publisher: SocketManagerState (publisher (udp-packet any-remote local-addr (wild))
(udp-packet-pattern any-remote local-addr (wild))
(match-state socket-is-open? (match-state socket-is-open?
(on-absence (handle-absence socket-is-open?)))) (on-absence (handle-absence socket-is-open?))))
(subscriber: SocketManagerState (subscriber (udp-packet local-addr any-remote (wild))
(udp-packet-pattern local-addr any-remote (wild))
(match-state socket-is-open? (match-state socket-is-open?
(on-absence (handle-absence socket-is-open?)) (on-absence (handle-absence socket-is-open?))
(on-message (on-message
@ -220,10 +148,10 @@
(udp-remote-address remote-host remote-port) (udp-remote-address remote-host remote-port)
body) body)
(begin (udp-send-to s remote-host remote-port body) (begin (udp-send-to s remote-host remote-port body)
(transition: socket-is-open? : SocketManagerState))]))) (transition socket-is-open?))])))
;; Listen for messages arriving on the actual socket using ;; Listen for messages arriving on the actual socket using
;; a ground event, and relay them at this level. ;; a ground event, and relay them at this level.
(subscriber: SocketManagerState (cons (udp-receive!-evt s buffer) (wild)) (subscriber (cons (udp-receive!-evt s buffer) (wild))
(on-message (on-message
[(cons (? evt?) (list (? exact-integer? packet-length) [(cons (? evt?) (list (? exact-integer? packet-length)
(? string? remote-host) (? string? remote-host)

2
examples/echo-plain.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
;; Plain Racket version, using (require) instead of #lang marketplace. ;; Plain Racket version, using (require) instead of #lang marketplace.
(require marketplace/sugar-untyped) (require marketplace/sugar)
(require marketplace/drivers/tcp-bare) (require marketplace/drivers/tcp-bare)
(define (echoer from to) (define (echoer from to)

33
ground.rkt
View File

@ -1,25 +1,18 @@
#lang typed/racket/base #lang racket/base
(require racket/match) (require racket/match)
(require "types.rkt") (require "structs.rkt")
(require "roles.rkt") (require "roles.rkt")
(require "vm.rkt") (require "vm.rkt")
(require "log-typed.rkt") (require "log.rkt")
(require "process.rkt") (require "process.rkt")
(require "actions.rkt") (require "actions.rkt")
(require "action-send-message.rkt") (require "action-send-message.rkt")
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround (require "quasiqueue.rkt")
(require "support/event.rkt")
(require/typed typed/racket/base
[sync (Evt Evt * -> (vm -> vm))]
[never-evt Evt]
[always-evt Evt]
[wrap-evt (Evt (Any -> (vm -> vm)) -> Evt)])
(provide run-ground-vm) (provide run-ground-vm)
(: run-ground-vm : process-spec -> Void) ;; run-ground-vm : process-spec -> Void
(define (run-ground-vm boot) (define (run-ground-vm boot)
(let loop ((state (make-vm boot))) (let loop ((state (make-vm boot)))
(match (run-vm state) (match (run-vm state)
@ -38,7 +31,7 @@
"Cannot process meta-actions ~v because no further metalevel exists" "Cannot process meta-actions ~v because no further metalevel exists"
actions)])) actions)]))
(define active-events (define active-events
((inst endpoint-fold (Listof Evt)) extract-ground-event-subscriptions '() state)) (endpoint-fold extract-ground-event-subscriptions '() state))
(if (and is-blocking? (if (and is-blocking?
(null? active-events)) (null? active-events))
(begin (begin
@ -49,27 +42,27 @@
(let ((interruptk (apply sync (let ((interruptk (apply sync
(if is-blocking? (if is-blocking?
never-evt never-evt
(wrap-evt always-evt (lambda (dummy) (inst values vm)))) (wrap-evt always-evt (lambda (dummy) values)))
active-events))) active-events)))
(loop (interruptk state))))]))) (loop (interruptk state))))])))
(: extract-ground-event-subscriptions : ;; extract-ground-event-subscriptions :
(All (State) (process State) (endpoint State) (Listof Evt) -> (Listof Evt))) ;; (All (State) (process State) (endpoint State) (Listof Evt) -> (Listof Evt))
(define (extract-ground-event-subscriptions old-p ep acc) (define (extract-ground-event-subscriptions old-p ep acc)
(define pid (process-pid old-p)) (define pid (process-pid old-p))
(match (endpoint-role ep) (match (endpoint-role ep)
[(role 'subscriber (cons (? evt? evt) _) 'participant) [(role 'subscriber (cons (? evt? evt) _) 'participant)
(: evt-handler : Any -> (vm -> vm)) ;; evt-handler : Any -> (vm -> vm)
(define ((evt-handler message) state) (define ((evt-handler message) state)
(let-values (((state wp) (extract-process state pid))) (let-values (((state wp) (extract-process state pid)))
(if (not wp) (if (not wp)
state state
(unwrap-process State vm (p wp) (let ((p wp))
(let-values (let-values
(((p state) (((p state)
(do-send-message 'publisher (cast (cons evt message) Message) p state))) (do-send-message 'publisher (cons evt message) p state)))
(if p (if p
(inject-process state (mkProcess p)) (inject-process state p)
state)))))) state))))))
(cons (wrap-evt evt evt-handler) acc)] (cons (wrap-evt evt evt-handler) acc)]
[_ acc])) [_ acc]))

4
lang/base.rkt
View File

@ -3,13 +3,13 @@
(require (for-syntax racket/base)) (require (for-syntax racket/base))
(require (for-syntax racket/pretty)) (require (for-syntax racket/pretty))
(require "../sugar-untyped.rkt") (require "../sugar.rkt")
(require "../drivers/tcp-bare.rkt") (require "../drivers/tcp-bare.rkt")
(require "../support/spy.rkt") (require "../support/spy.rkt")
(provide (rename-out [module-begin #%module-begin]) (provide (rename-out [module-begin #%module-begin])
(except-out (all-from-out racket/base) #%module-begin) (except-out (all-from-out racket/base) #%module-begin)
(all-from-out "../sugar-untyped.rkt") (all-from-out "../sugar.rkt")
(all-from-out "../drivers/tcp-bare.rkt") (all-from-out "../drivers/tcp-bare.rkt")
(all-from-out "../support/spy.rkt") (all-from-out "../support/spy.rkt")
stateless) stateless)

4
list-utils.rkt
View File

@ -1,7 +1,7 @@
#lang typed/racket/base #lang racket/base
(provide list-max) (provide list-max)
(: list-max : (Listof Integer) -> Integer) ;; list-max : (Listof Integer) -> Integer
(define (list-max xs) (define (list-max xs)
(foldr max 0 xs)) (foldr max 0 xs))

17
log-typed.rkt
View File

@ -1,17 +0,0 @@
#lang typed/racket/base
(require/typed "log-untyped.rkt"
[marketplace-root-logger Logger])
;; WARNING: duplicated in log-untyped.rkt
(define-syntax marketplace-log
(syntax-rules ()
[(_ level-exp message)
(let ((level level-exp))
(when (log-level? marketplace-root-logger level)
(log-message marketplace-root-logger level message #f)))]
[(_ level format-string exp ...)
(marketplace-log level (format format-string exp ...))]))
(provide marketplace-root-logger
marketplace-log)

1
log-untyped.rkt → log.rkt
View File

@ -7,7 +7,6 @@
(define marketplace-root-logger (make-logger 'marketplace #f)) (define marketplace-root-logger (make-logger 'marketplace #f))
;; WARNING: duplicated in log-typed.rkt
(define-syntax marketplace-log (define-syntax marketplace-log
(syntax-rules () (syntax-rules ()
[(_ level-exp message) [(_ level-exp message)

18
main.rkt
View File

@ -1,34 +1,26 @@
#lang typed/racket/base #lang racket/base
;; Virtualized operating system, this time with presence and types. ;; Virtualized operating system, this time with presence.
;; TODO: contracts for State checking ;; TODO: contracts for State checking
;; TODO: types for Message and MetaMessage (will require rethinking at-meta-level spawn)
;; TODO: revisit exposure of PIDs to processes. ;; TODO: revisit exposure of PIDs to processes.
;; - make processes parametric in the PID type? ;; - make processes parametric in the PID type?
;; - simply make PIDs unavailable to processes? ;; - simply make PIDs unavailable to processes?
;; - revisit points-of-attachment idea, and expose presence on PIDs properly? ;; - revisit points-of-attachment idea, and expose presence on PIDs properly?
(require racket/match) (require racket/match)
(require "types.rkt") (require "structs.rkt")
(require "roles.rkt") (require "roles.rkt")
(require "vm.rkt") (require "vm.rkt")
(require "actions.rkt") (require "actions.rkt")
(require "nested.rkt") (require "nested.rkt")
(require "ground.rkt") (require "ground.rkt")
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround (require "unify.rkt")
(require/typed "unify.rkt" (provide (all-from-out "structs.rkt")
[opaque Wild wild?]
[wild (case-> (-> Wild) (Symbol -> Wild))]
[non-wild? (Any -> Boolean)]
[ground? (Any -> Boolean)])
(provide (all-from-out "types.rkt")
(all-from-out "roles.rkt") (all-from-out "roles.rkt")
make-nested-vm make-nested-vm
run-ground-vm run-ground-vm
Wild
wild wild
wild? wild?
non-wild? non-wild?

9
nested.rkt
View File

@ -1,18 +1,17 @@
#lang typed/racket/base #lang racket/base
(require racket/match) (require racket/match)
(require "types.rkt") (require "structs.rkt")
(require "roles.rkt") (require "roles.rkt")
(require "vm.rkt") (require "vm.rkt")
(require "actions.rkt") (require "actions.rkt")
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
(provide make-nested-vm) (provide make-nested-vm)
(: make-nested-vm : (All (State) (PID -> process-spec) Any -> (spawn State))) ;; make-nested-vm : (All (State) (PID -> process-spec) Any -> (spawn State))
(define (make-nested-vm make-boot debug-name) (define (make-nested-vm make-boot debug-name)
(spawn (process-spec (lambda (nested-vm-pid) (spawn (process-spec (lambda (nested-vm-pid)
(lambda (k) ((inst k vm) (run-vm (make-vm (make-boot nested-vm-pid))))))) (lambda (k) (k (run-vm (make-vm (make-boot nested-vm-pid)))))))
#f #f
debug-name)) debug-name))

9
opaque-any.rkt
View File

@ -1,9 +0,0 @@
#lang racket/base
(provide topic?
pre-eid?
reason?)
(define (topic? x) #t)
(define (pre-eid? x) #t)
(define (reason? x) #t)

93
process.rkt
View File

@ -1,11 +1,11 @@
#lang typed/racket/base #lang racket/base
(require racket/match) (require racket/match)
(require "types.rkt") (require "structs.rkt")
(require "roles.rkt") (require "roles.rkt")
(require "vm.rkt") (require "vm.rkt")
(require "log-typed.rkt") (require "log.rkt")
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround (require "quasiqueue.rkt")
(provide send-to-user (provide send-to-user
send-to-user* send-to-user*
@ -18,7 +18,7 @@
(send-to-user* (process-debug-name p) (process-pid p) (e) failure-result enclosed-expr)) (send-to-user* (process-debug-name p) (process-pid p) (e) failure-result enclosed-expr))
(define-syntax-rule (send-to-user* debug-name pid (e) failure-result enclosed-expr) (define-syntax-rule (send-to-user* debug-name pid (e) failure-result enclosed-expr)
(with-handlers ([exn:fail? (lambda: ([e : Reason]) (with-handlers ([exn:fail? (lambda (e)
(if (exn? e) (if (exn? e)
(marketplace-log 'error "Process ~v(~v):~n~a~n" (marketplace-log 'error "Process ~v(~v):~n~a~n"
debug-name pid (exn-message e)) debug-name pid (exn-message e))
@ -30,44 +30,37 @@
(marketplace-log 'debug "Leaving process ~v(~v)" debug-name pid) (marketplace-log 'debug "Leaving process ~v(~v)" debug-name pid)
result)) result))
(: action-tree->quasiqueue : (All (State) (ActionTree State) -> (QuasiQueue (Action State)))) ;; action-tree->quasiqueue : (All (State) (ActionTree State) -> (QuasiQueue (Action State)))
;; TODO: simplify
(define (action-tree->quasiqueue t) (define (action-tree->quasiqueue t)
(let loop ((#{revacc : (QuasiQueue (Action State))} '()) (t t)) (let loop ((revacc '()) (t t))
;; 1. Tried match with (define-predicate action? Action).
;; Failed because of parametric function contracts.
;; 2. Tried flipping the order or clauses in the match to
;; avoid the use of (action?), trying to pull out the
;; false/nil/void leaving only, by exclusion, the
;; Action. Failed, complaining that it didn't know the
;; type in the third, default, branch.
;; 3. Just like 2, but with cond. This worked!
(cond (cond
[(pair? t) (loop (loop revacc (car t)) (cdr t))] [(pair? t) (loop (loop revacc (car t)) (cdr t))]
[(or (null? t) (eq? t #f) (void? t)) revacc] [(or (null? t) (eq? t #f) (void? t)) revacc]
[else (cons t revacc)]))) [else (cons t revacc)])))
;; Split out to provide a syntactic location to define State in ;; Split out to provide a syntactic location to define State in
(: quit-interruptk : Reason -> (All (State) State -> (Transition State))) ;; quit-interruptk : Reason -> (All (State) State -> (Transition State))
(define ((quit-interruptk e) old-process-state) (define ((quit-interruptk e) old-process-state)
(transition old-process-state (quit #f e))) (transition old-process-state (quit #f e)))
(: run-ready : (All (State) (process State) (InterruptK State) -> (process State))) ;; run-ready : (All (State) (process State) (InterruptK State) -> (process State))
(define (run-ready p interruptk) (define (run-ready p interruptk)
(define old-state (process-state p)) (define old-state (process-state p))
(match-define (transition new-state actions) (match-define (transition new-state actions)
(send-to-user p (e) (transition old-state (ann (quit #f e) (Action State))) (send-to-user p (e) (transition old-state (quit #f e))
(interruptk old-state))) (interruptk old-state)))
(struct-copy process p (struct-copy process p
[state new-state] [state new-state]
[pending-actions (quasiqueue-append (process-pending-actions p) [pending-actions (quasiqueue-append (process-pending-actions p)
(action-tree->quasiqueue actions))])) (action-tree->quasiqueue actions))]))
(: notify-route-change-self : (All (SNew) ;; notify-route-change-self : (All (SNew)
(process SNew) ;; (process SNew)
(endpoint SNew) ;; (endpoint SNew)
(Role -> EndpointEvent) ;; (Role -> EndpointEvent)
-> ;; ->
(process SNew))) ;; (process SNew))
(define (notify-route-change-self pn en flow->notification) (define (notify-route-change-self pn en flow->notification)
(define endpointso (process-endpoints pn)) (define endpointso (process-endpoints pn))
(for/fold ([pn pn]) ([eido (in-hash-keys endpointso)]) (for/fold ([pn pn]) ([eido (in-hash-keys endpointso)])
@ -86,13 +79,13 @@
flow->notification))] flow->notification))]
[else pn]))) [else pn])))
(: notify-route-change-process : (All (SOld SNew) ;; notify-route-change-process : (All (SOld SNew)
(process SOld) ;; (process SOld)
(process SNew) ;; (process SNew)
(endpoint SNew) ;; (endpoint SNew)
(Role -> EndpointEvent) ;; (Role -> EndpointEvent)
-> (values (process SOld) ;; -> (values (process SOld)
(process SNew)))) ;; (process SNew)))
(define (notify-route-change-process po pn en flow->notification) (define (notify-route-change-process po pn en flow->notification)
(define endpointso (process-endpoints po)) (define endpointso (process-endpoints po))
(for/fold ([po po] (for/fold ([po po]
@ -109,39 +102,37 @@
[else [else
(values po pn)]))) (values po pn)])))
(: invoke-handler-if-visible : (All (State) ;; invoke-handler-if-visible : (All (State)
(process State) ;; (process State)
(endpoint State) ;; (endpoint State)
Role ;; Role
(Role -> EndpointEvent) ;; (Role -> EndpointEvent)
-> ;; ->
(process State))) ;; (process State))
(define (invoke-handler-if-visible p ep flow flow->notification) (define (invoke-handler-if-visible p ep flow flow->notification)
(if (flow-visible? (endpoint-role ep) flow) (if (flow-visible? (endpoint-role ep) flow)
(run-ready p (send-to-user p (e) (quit-interruptk e) (run-ready p (send-to-user p (e) (quit-interruptk e)
((endpoint-handler ep) (flow->notification flow)))) ((endpoint-handler ep) (flow->notification flow))))
p)) p))
(: notify-route-change-vm : (All (SNew) ;; notify-route-change-vm : (All (SNew)
(process SNew) ;; (process SNew)
(endpoint SNew) ;; (endpoint SNew)
(Role -> EndpointEvent) ;; (Role -> EndpointEvent)
vm ;; vm
-> (values (process SNew) ;; -> (values (process SNew)
vm))) ;; vm))
(define (notify-route-change-vm pn en flow->notification state) (define (notify-route-change-vm pn en flow->notification state)
(define old-processes (vm-processes state)) (define old-processes (vm-processes state))
(define-values (final-pn new-processes) (define-values (final-pn new-processes)
(for/fold: : (values (process SNew) (for/fold ([pn (notify-route-change-self pn en flow->notification)]
(HashTable PID Process)) [new-processes #hash()])
([pn (notify-route-change-self pn en flow->notification)]
[new-processes (ann #hash() (HashTable PID Process))])
([pid (in-hash-keys old-processes)]) ([pid (in-hash-keys old-processes)])
(define wp (hash-ref old-processes pid)) (define wp (hash-ref old-processes pid))
(apply values (apply values
(unwrap-process SOld (List (process SNew) (HashTable PID Process)) (po wp) (let ((po wp))
(let-values (((po pn) (notify-route-change-process po pn en flow->notification))) (let-values (((po pn) (notify-route-change-process po pn en flow->notification)))
(list pn (hash-set new-processes pid (mkProcess po)))))))) (list pn (hash-set new-processes pid po)))))))
(values final-pn (values final-pn
(struct-copy vm state [processes new-processes]))) (struct-copy vm state [processes new-processes])))

32
quasiqueue.rkt
View File

@ -1,8 +1,6 @@
#lang typed/racket/base #lang racket/base
(provide QuasiQueue (provide empty-quasiqueue
Constreeof
empty-quasiqueue
quasiqueue-empty? quasiqueue-empty?
quasiqueue-append-list quasiqueue-append-list
quasiqueue-append quasiqueue-append
@ -12,40 +10,36 @@
quasiqueue->cons-tree) quasiqueue->cons-tree)
;; A QuasiQueue<X> is a list of Xs in *reversed* order. ;; A QuasiQueue<X> is a list of Xs in *reversed* order.
(define-type (QuasiQueue X) (Listof X)) ;; (define-type (QuasiQueue X) (Listof X))
(define-type (Constreeof X) (Rec CT (U X (Pairof CT CT) False Void Null))) ;; (define-type (Constreeof X) (Rec CT (U X (Pairof CT CT) False Void Null)))
(: empty-quasiqueue : (All (X) -> (QuasiQueue X))) ;; empty-quasiqueue : (All (X) -> (QuasiQueue X))
(define (empty-quasiqueue) '()) (define (empty-quasiqueue) '())
(: quasiqueue-empty? : (All (X) (QuasiQueue X) -> Boolean)) ;; quasiqueue-empty? : (All (X) (QuasiQueue X) -> Boolean)
(define (quasiqueue-empty? q) (null? q)) (define (quasiqueue-empty? q) (null? q))
(: quasiqueue-append-list : (All (X) (QuasiQueue X) (Listof X) -> (QuasiQueue X))) ;; quasiqueue-append-list : (All (X) (QuasiQueue X) (Listof X) -> (QuasiQueue X))
(define (quasiqueue-append-list q xs) (define (quasiqueue-append-list q xs)
(append (reverse xs) q)) (append (reverse xs) q))
(: quasiqueue-append : (All (X) (QuasiQueue X) (QuasiQueue X) -> (QuasiQueue X))) ;; quasiqueue-append : (All (X) (QuasiQueue X) (QuasiQueue X) -> (QuasiQueue X))
(define (quasiqueue-append q1 q2) (define (quasiqueue-append q1 q2)
(append q2 q1)) (append q2 q1))
(: quasiqueue : (All (X) X * -> (QuasiQueue X))) ;; quasiqueue : (All (X) X * -> (QuasiQueue X))
(define (quasiqueue . xs) (define (quasiqueue . xs)
(reverse xs)) (reverse xs))
(: list->quasiqueue : (All (X) (Listof X) -> (QuasiQueue X))) ;; list->quasiqueue : (All (X) (Listof X) -> (QuasiQueue X))
(define (list->quasiqueue xs) (define (list->quasiqueue xs)
(reverse xs)) (reverse xs))
(: quasiqueue->list : (All (X) (QuasiQueue X) -> (Listof X))) ;; quasiqueue->list : (All (X) (QuasiQueue X) -> (Listof X))
(define (quasiqueue->list q) (define (quasiqueue->list q)
(reverse q)) (reverse q))
(: quasiqueue->cons-tree : (All (X) (QuasiQueue X) -> (Constreeof X))) ;; quasiqueue->cons-tree : (All (X) (QuasiQueue X) -> (Constreeof X))
(define (quasiqueue->cons-tree q) (define (quasiqueue->cons-tree q)
;; (reverse q) -- can't use this, TR won't prove Listof X <: Constreeof X. (reverse q))
(let loop ((#{acc : (Constreeof X)} '()) (q q))
(if (null? q)
acc
(loop (cons (car q) acc) (cdr q)))))

29
roles.rkt
View File

@ -1,14 +1,9 @@
#lang typed/racket/base #lang racket/base
(require racket/match) (require racket/match)
(require "types.rkt") (require "structs.rkt")
(require "log-typed.rkt") (require "log.rkt")
(require/typed "unify.rkt" (require "unify.rkt")
[wild (case-> (-> Topic) (Symbol -> Topic))]
[mgu-canonical (Topic Topic -> Topic)]
[freshen (Topic -> Topic)]
[specialization? (Topic Topic -> Boolean)])
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
(provide co-orientations (provide co-orientations
co-roles co-roles
@ -18,34 +13,34 @@
role-intersection role-intersection
flow-visible?) flow-visible?)
(: co-orientations : Orientation -> (Listof Orientation)) ;; co-orientations : Orientation -> (Listof Orientation)
(define (co-orientations o) (define (co-orientations o)
(match o (match o
['publisher '(subscriber)] ['publisher '(subscriber)]
['subscriber '(publisher)])) ['subscriber '(publisher)]))
(: co-roles : Role -> (Listof Role)) ;; co-roles : Role -> (Listof Role)
(define (co-roles r) (define (co-roles r)
(for/list: ([co-orientation : Orientation (co-orientations (role-orientation r))]) (for/list ([co-orientation (co-orientations (role-orientation r))])
(struct-copy role r [orientation co-orientation]))) (struct-copy role r [orientation co-orientation])))
(: refine-role : Role Topic -> Role) ;; refine-role : Role Topic -> Role
(define (refine-role remote-role new-topic) (define (refine-role remote-role new-topic)
(struct-copy role remote-role [topic new-topic])) (struct-copy role remote-role [topic new-topic]))
(: roles-equal? : Role Role -> Boolean) ;; roles-equal? : Role Role -> Boolean
(define (roles-equal? ta tb) (define (roles-equal? ta tb)
(and (equal? (role-orientation ta) (role-orientation tb)) (and (equal? (role-orientation ta) (role-orientation tb))
(equal? (role-interest-type ta) (role-interest-type tb)) (equal? (role-interest-type ta) (role-interest-type tb))
(specialization? (role-topic ta) (role-topic tb)) (specialization? (role-topic ta) (role-topic tb))
(specialization? (role-topic tb) (role-topic ta)))) (specialization? (role-topic tb) (role-topic ta))))
(: orientations-intersect? : Orientation Orientation -> Boolean) ;; orientations-intersect? : Orientation Orientation -> Boolean
(define (orientations-intersect? l r) (define (orientations-intersect? l r)
(and (memq l (co-orientations r)) #t)) (and (memq l (co-orientations r)) #t))
;; "Both left and right must be canonicalized." - comment from os2.rkt. What does it mean? ;; "Both left and right must be canonicalized." - comment from os2.rkt. What does it mean?
(: role-intersection : Role Role -> (Option Topic)) ;; role-intersection : Role Role -> (Option Topic)
(define (role-intersection left right) (define (role-intersection left right)
(define result (define result
(and (orientations-intersect? (role-orientation left) (role-orientation right)) (and (orientations-intersect? (role-orientation left) (role-orientation right))
@ -72,7 +67,7 @@
;; | 'everything | 'everything | yes | ;; | 'everything | 'everything | yes |
;; |--------------+--------------+------------------------| ;; |--------------+--------------+------------------------|
;; ;;
(: flow-visible? : Role Role -> Boolean) ;; flow-visible? : Role Role -> Boolean
(define (flow-visible? local-role remote-role) (define (flow-visible? local-role remote-role)
(or (eq? (role-interest-type remote-role) 'participant) (or (eq? (role-interest-type remote-role) 'participant)
(eq? (role-interest-type local-role) 'everything))) (eq? (role-interest-type local-role) 'everything)))

15
scribblings/highlevel.scrbl
View File

@ -4,9 +4,7 @@
@title[#:tag "high-level-interface"]{High-level interface} @title[#:tag "high-level-interface"]{High-level interface}
@declare-exporting[#:use-sources (marketplace/sugar-values @declare-exporting[#:use-sources (marketplace/sugar)]
marketplace/sugar-untyped
marketplace/sugar-typed)]
This high-level interface between a VM and a process is analogous to This high-level interface between a VM and a process is analogous to
the @emph{C library interface} of a Unix-like operating system. The the @emph{C library interface} of a Unix-like operating system. The
@ -60,11 +58,8 @@ and @racket[ground-vm:] explicitly.
@section{Using Marketplace as a library} @section{Using Marketplace as a library}
@defmodule*[(marketplace/sugar-untyped @defmodule*[(marketplace/sugar)
marketplace/sugar-typed) #:use-sources (marketplace/sugar)]
#:use-sources (marketplace/sugar-values
marketplace/sugar-untyped
marketplace/sugar-typed)]
Instead of using Racket's @tt{#lang} feature, ordinary Racket programs Instead of using Racket's @tt{#lang} feature, ordinary Racket programs
can use Marketplace features by requiring Marketplace modules can use Marketplace features by requiring Marketplace modules
@ -110,9 +105,7 @@ its state type).
@section[#:tag "constructing-transitions"]{Constructing transitions} @section[#:tag "constructing-transitions"]{Constructing transitions}
@declare-exporting[#:use-sources (marketplace @declare-exporting[#:use-sources (marketplace
marketplace/sugar-values marketplace/sugar)]
marketplace/sugar-untyped
marketplace/sugar-typed)]
@deftogether[( @deftogether[(
@defform[(transition new-state action-tree ...)] @defform[(transition new-state action-tree ...)]

12
scribblings/lowlevel.scrbl
View File

@ -41,8 +41,8 @@ Typed Racket types capturing various notions of handler function.
@section{Messages, Topics and Roles} @section{Messages, Topics and Roles}
@declare-exporting[marketplace marketplace/sugar-untyped marketplace/sugar-typed @declare-exporting[marketplace marketplace/sugar
#:use-sources (marketplace marketplace/sugar-untyped marketplace/sugar-typed)] #:use-sources (marketplace marketplace/sugar)]
@deftogether[( @deftogether[(
@deftype[Message Any] @deftype[Message Any]
@ -255,8 +255,8 @@ Deletes an existing endpoint named @racket[pre-eid]. The given
If no specific reason is needed, it is conventional to supply If no specific reason is needed, it is conventional to supply
@racket[#f] as the @racket[delete-endpoint-reason]. See also the @racket[#f] as the @racket[delete-endpoint-reason]. See also the
convenience @from[marketplace/sugar-values]{@racket[delete-endpoint]} convenience @from[marketplace/sugar]{@racket[delete-endpoint]}
function from @racket[marketplace/sugar-values]. function from @racket[marketplace/sugar].
} }
@ -270,9 +270,9 @@ the containing VM.} The given @racket[Orientation] should describe the
role the sender is playing when sending this message: usually, it will role the sender is playing when sending this message: usually, it will
be @racket['publisher], but when the message is @emph{feedback} for be @racket['publisher], but when the message is @emph{feedback} for
some publisher, it will be @racket['subscriber]. some publisher, it will be @racket['subscriber].
@from[marketplace/sugar-values]{See also the @racket[send-message] and @from[marketplace/sugar]{See also the @racket[send-message] and
@racket[send-feedback] convenience functions from @racket[send-feedback] convenience functions from
@racket[marketplace/sugar-values].} @racket[marketplace/sugar].}
} }

5
scribblings/management-and-monitoring.scrbl
View File

@ -4,10 +4,7 @@
@require[(for-label marketplace/support/spy @require[(for-label marketplace/support/spy
marketplace/support/debug marketplace/support/debug
marketplace/log-untyped marketplace/log)]
(except-in marketplace/log-typed
marketplace-log
marketplace-root-logger))]
@title{Management and Monitoring} @title{Management and Monitoring}

16
scribblings/prelude.inc
View File

@ -12,21 +12,7 @@
(for-label typed/racket/base)) (for-label typed/racket/base))
(require (for-label (only-in marketplace/drivers/tcp-bare tcp) (require (for-label (only-in marketplace/drivers/tcp-bare tcp)
(except-in marketplace/sugar-untyped marketplace/sugar))
name-endpoint
name-process
transition/no-state)
(except-in marketplace/sugar-typed
?
let-fresh
match-state
match-orientation
match-conversation
match-interest-type
match-reason
on-presence
on-absence
on-message)))
;; TODO: make it display "=" instead of ":" connecting the defined ;; TODO: make it display "=" instead of ":" connecting the defined
;; type to the definition. ;; type to the definition.

96
structs.rkt Normal file
View File

@ -0,0 +1,96 @@
#lang racket/base
(provide (all-defined-out))
;; (define-type Orientation (U 'publisher 'subscriber))
(struct role (orientation ;; Orientation
topic ;; Topic
interest-type ;; InterestType
)
#:transparent)
;; (define-type Message Topic) ;; Cheesy.
;; (define-type InterestType (U 'participant 'observer 'everything))
;; (define-type (Handler State) (TrapK EndpointEvent State))
;; (define-type (InterruptK State) (State -> (Transition State)))
;; (define-type (TrapK Event State) (Event -> (InterruptK State)))
;; (define-type EndpointEvent (U PresenceEvent
;; AbsenceEvent
;; MessageEvent))
(struct presence-event (role) #:transparent)
(struct absence-event (role reason) #:transparent)
(struct message-event (role message) #:transparent)
(struct transition (state ;; State
actions ;; (ActionTree State)
)
#:transparent)
;; (define-type (ActionTree State) (Constreeof (Action State)))
;; Existential quantification over State
;; (define-type CoTransition (All (Result) (All (State) (Transition State) -> Result) -> Result))
;; Specification of a new process
(struct process-spec (boot ;; (PID -> CoTransition)
)
#:transparent)
;; (define-type ProcessSpec process-spec)
;; (define-type (PreAction State) (U (add-endpoint State)
;; delete-endpoint
;; send-message
;; (spawn State)
;; quit))
(struct add-endpoint (pre-eid ;; PreEID
role ;; Role
handler ;; (Handler State)
)
#:transparent)
(struct delete-endpoint (pre-eid ;; PreEID
reason ;; Reason
)
#:transparent)
(struct send-message (body ;; Message
orientation ;; Orientation
)
#:transparent)
(struct spawn (spec ;; process-spec
k ;; (Option (PID -> (InterruptK State)))
debug-name ;; Any
)
#:transparent)
(struct quit (pid ;; (Option PID) ;; #f = suicide
reason ;; Reason
)
#:transparent)
;; (define-type (Action State) (U (PreAction State)
;; (yield State)
;; (at-meta-level State)))
(struct yield (k ;; (InterruptK State)
)
#:transparent)
(struct at-meta-level (preaction ;; (PreAction State)
)
#:transparent)
;; (define-type PID Number)
;;; Local Variables:
;;; eval: (put 'transition 'scheme-indent-function 1)
;;; eval: (put 'transition/no-state 'scheme-indent-function 0)
;;; End:

21
sugar-endpoints-support.rkt
View File

@ -1,21 +0,0 @@
#lang racket/base
(require (for-syntax racket/base))
(require "support/dsl-untyped.rkt")
;; We define and provide these here so that they can be used by both
;; typed and untyped contexts. If we define them separately in untyped
;; and typed contexts, then TR's wrapping of provided identifiers
;; interferes with literal comparison in our macros. See also
;; definition and use of the file support/dsl-typed.rkt in git rev
;; b477046.
(define&provide-dsl-helper-syntaxes "endpoint definition context"
[match-state
match-orientation
match-conversation
match-interest-type
match-reason
on-presence
on-absence
on-message])

247
sugar-endpoints-typed.rkt
View File

@ -1,247 +0,0 @@
#lang typed/racket/base
(require (for-syntax syntax/parse))
(require (for-syntax racket/base))
(require racket/match)
(require (prefix-in core: "main.rkt"))
(require "sugar-endpoints-support.rkt")
(provide (all-from-out "sugar-endpoints-support.rkt")
name-endpoint
let-fresh
observe-subscribers:
observe-subscribers/everything:
observe-publishers:
observe-publishers/everything:
publisher:
subscriber:
build-endpoint:)
;; Must handle:
;; - orientation
;; - interest-type
;; - let-name
;; - naming of endpoints
;; - state matching
;; - conversation (and generally role) matching
;; - presence event handling
;; - absence event handling (including reason matching)
;; - message event handling (including message matching)
(: name-endpoint : (All (State) Any (core:AddEndpoint State) -> (core:AddEndpoint State)))
(define (name-endpoint n e)
(match e
[(core:add-endpoint _ role handler)
(core:add-endpoint (cast n core:PreEID) role handler)]))
(define-syntax-rule (let-fresh (id ...) exp ...)
(let ((id (gensym 'id)) ...) exp ...))
(define-syntax-rule (observe-subscribers: State topic clause ...)
(build-endpoint: State
(gensym 'anonymous-endpoint)
(core:role 'publisher (cast topic core:Topic) 'observer)
clause ...))
(define-syntax-rule (observe-subscribers/everything: State topic clause ...)
(build-endpoint: State
(gensym 'anonymous-endpoint)
(core:role 'publisher (cast topic core:Topic) 'everything)
clause ...))
(define-syntax-rule (observe-publishers: State topic clause ...)
(build-endpoint: State
(gensym 'anonymous-endpoint)
(core:role 'subscriber (cast topic core:Topic) 'observer)
clause ...))
(define-syntax-rule (observe-publishers/everything: State topic clause ...)
(build-endpoint: State
(gensym 'anonymous-endpoint)
(core:role 'subscriber (cast topic core:Topic) 'everything)
clause ...))
(define-syntax-rule (publisher: State topic clause ...)
(build-endpoint: State
(gensym 'anonymous-endpoint)
(core:role 'publisher (cast topic core:Topic) 'participant)
clause ...))
(define-syntax-rule (subscriber: State topic clause ...)
(build-endpoint: State
(gensym 'anonymous-endpoint)
(core:role 'subscriber (cast topic core:Topic) 'participant)
clause ...))
(define-syntax build-endpoint:
(lambda (stx)
(define (combine-handler-clauses State
clauses-stx
stateful?
state-stx
orientation-stx
conversation-stx
interest-type-stx
reason-stx)
(define (do-tail new-clauses-stx)
(combine-handler-clauses State
new-clauses-stx
stateful?
state-stx
orientation-stx
conversation-stx
interest-type-stx
reason-stx))
(define (stateful-lift context exprs-stx)
(if stateful?
(syntax-case exprs-stx ()
[(expr)
#`(lambda: ([state : #,State]) (match state [#,state-stx expr]))]
[_
(raise-syntax-error #f
(format "Expected exactly one expression resulting in a transition, in ~a handler"
context)
stx
exprs-stx)])
(syntax-case exprs-stx ()
[(expr ...)
#`(lambda: ([state : #,State]) (core:transition state (list expr ...)))])))
(syntax-case clauses-stx (match-state
match-orientation
match-conversation
match-interest-type
match-reason
on-presence
on-absence
on-message)
[() '()]
[((match-state pat-stx inner-clause ...) outer-clause ...)
(append (combine-handler-clauses State
(syntax (inner-clause ...))
#t
#'pat-stx
orientation-stx
conversation-stx
interest-type-stx
reason-stx)
(do-tail (syntax (outer-clause ...))))]
[((match-orientation pat-stx inner-clause ...) outer-clause ...)
(append (combine-handler-clauses State
(syntax (inner-clause ...))
stateful?
state-stx
#'pat-stx
conversation-stx
interest-type-stx
reason-stx)
(do-tail (syntax (outer-clause ...))))]
[((match-conversation pat-stx inner-clause ...) outer-clause ...)
(append (combine-handler-clauses State
(syntax (inner-clause ...))
stateful?
state-stx
orientation-stx
#'pat-stx
interest-type-stx
reason-stx)
(do-tail (syntax (outer-clause ...))))]
[((match-interest-type pat-stx inner-clause ...) outer-clause ...)
(append (combine-handler-clauses State
(syntax (inner-clause ...))
stateful?
state-stx
orientation-stx
conversation-stx
#'pat-stx
reason-stx)
(do-tail (syntax (outer-clause ...))))]
[((match-reason pat-stx inner-clause ...) outer-clause ...)
(append (combine-handler-clauses State
(syntax (inner-clause ...))
stateful?
state-stx
orientation-stx
conversation-stx
interest-type-stx
#'pat-stx)
(do-tail (syntax (outer-clause ...))))]
[((on-presence expr ...) outer-clause ...)
(cons #`[(core:presence-event (core:role #,orientation-stx
#,conversation-stx
#,interest-type-stx))
#,(stateful-lift 'on-presence (syntax (expr ...)))]
(do-tail (syntax (outer-clause ...))))]
[((on-absence expr ...) outer-clause ...)
(cons #`[(core:absence-event (core:role #,orientation-stx
#,conversation-stx
#,interest-type-stx)
#,reason-stx)
#,(stateful-lift 'on-absence (syntax (expr ...)))]
(do-tail (syntax (outer-clause ...))))]
[((on-message [message-pat expr ...] ...) outer-clause ...)
(cons #`[(core:message-event (core:role #,orientation-stx
#,conversation-stx
#,interest-type-stx)
message)
(match message
#,@(map (lambda (message-clause)
(syntax-case message-clause ()
([message-pat expr ...]
#`[message-pat #,(stateful-lift 'on-message
(syntax (expr ...)))])))
(syntax->list (syntax ([message-pat expr ...] ...))))
[_ (lambda: ([state : #,State]) (core:transition state '()))])]
(do-tail (syntax (outer-clause ...))))]
[(unknown-clause outer-clause ...)
(raise-syntax-error #f
"Illegal clause in endpoint definition"
stx
#'unknown-clause)]))
(syntax-case stx ()
[(dummy State pre-eid-exp role-exp handler-clause ...)
#`(core:add-endpoint (cast pre-eid-exp core:PreEID)
role-exp
(match-lambda
#,@(reverse
(combine-handler-clauses
#'State
(syntax (handler-clause ...))
#f
(syntax old-state)
(syntax _)
(syntax _)
(syntax _)
(syntax _)))
[_ (lambda: ([state : State]) (core:transition state '()))]))])))
;;; Local Variables:
;;; eval: (put 'name-endpoint 'scheme-indent-function 1)
;;; eval: (put 'let-fresh 'scheme-indent-function 1)
;;; eval: (put 'observe-subscribers: 'scheme-indent-function 2)
;;; eval: (put 'observe-subscribers/everything: 'scheme-indent-function 2)
;;; eval: (put 'observe-publishers: 'scheme-indent-function 2)
;;; eval: (put 'observe-publishers/everything: 'scheme-indent-function 2)
;;; eval: (put 'publisher: 'scheme-indent-function 2)
;;; eval: (put 'subscriber: 'scheme-indent-function 2)
;;; eval: (put 'match-state 'scheme-indent-function 1)
;;; eval: (put 'match-orientation 'scheme-indent-function 1)
;;; eval: (put 'match-conversation 'scheme-indent-function 1)
;;; eval: (put 'match-interest-type 'scheme-indent-function 1)
;;; eval: (put 'match-reason 'scheme-indent-function 1)
;;; End:

133
sugar-typed.rkt
View File

@ -1,133 +0,0 @@
#lang typed/racket/base
(require (for-syntax syntax/parse))
(require (for-syntax racket/base))
(require racket/match)
(require (prefix-in core: "main.rkt"))
(require (except-in "main.rkt"
at-meta-level
spawn
yield
transition
delete-endpoint
send-message
quit
wild))
(require "sugar-values.rkt")
(require "sugar-endpoints-typed.rkt")
(provide (all-from-out "sugar-values.rkt")
(all-from-out "sugar-endpoints-typed.rkt")
(all-from-out "main.rkt")
?
transition:
transition/no-state
spawn:
spawn/continue:
name-process
yield:
at-meta-level:
spawn-vm:
ground-vm:)
;; A fresh unification variable, as identifier-syntax.
(define-syntax ? (syntax-id-rules () (_ (wild))))
(define-syntax transition:
(lambda (stx)
(syntax-case stx (:)
[(_ state : State action ...)
#'((inst transition State) state action ...)])))
(define-syntax-rule (transition/no-state action ...)
(transition: (void) : Void action ...))
(define-syntax spawn:
(lambda (stx)
(syntax-parse stx
[(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
#:parent (~literal :) ParentState
#:child (~literal :) State exp)
#`((inst core:spawn ParentState)
(core:process-spec (lambda (pid) (lambda (k) ((inst k State) exp))))
#f
#f)])))
(define-syntax spawn/continue:
(lambda (stx)
(syntax-parse stx
[(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
#:parent parent-state-pattern (~literal :) ParentState parent-k-exp
#:child (~literal :) State exp)
#`((inst core:spawn ParentState)
(core:process-spec (lambda (pid) (lambda (k) ((inst k State) exp))))
(lambda (pid) (lambda: ([parent-state : ParentState])
(match parent-state [parent-state-pattern parent-k-exp])))
#f)])))
(: name-process : (All (State) Any (core:Spawn State) -> (core:Spawn State)))
(define (name-process n p)
(match p
[(core:spawn spec parent-k _)
(core:spawn spec parent-k n)]))
(define-syntax yield:
(lambda (stx)
(syntax-case stx (:)
[(_ state-pattern : State exp)
#'((inst core:yield State) (lambda (state) (match state [state-pattern exp])))])))
(define-syntax at-meta-level:
(lambda (stx)
(syntax-case stx ()
[(_ State)
#''()]
[(_ State preaction)
#'((inst core:at-meta-level State) preaction)]
[(_ State preaction ...)
#'(list ((inst core:at-meta-level State) preaction) ...)])))
(define-syntax spawn-vm:
(lambda (stx)
(syntax-parse stx
[(_ (~literal :) ParentState
(~or (~optional (~seq #:vm-pid vm-pid) #:defaults ([vm-pid #'p0])
#:name "#:vm-pid")
(~optional (~seq #:boot-pid boot-pid) #:defaults ([boot-pid #'p0])
#:name "#:boot-pid")
(~optional (~seq #:initial-state initial-state (~literal :) InitialState)
#:defaults ([initial-state #'(void)] [InitialState #'Void])
#:name "#:initial-state")
(~optional (~seq #:debug-name debug-name)
#:defaults ([debug-name #'#f])
#:name "#:debug-name"))
...
exp ...)
#`((inst core:make-nested-vm ParentState)
(lambda (vm-pid)
(core:process-spec (lambda (boot-pid)
(lambda (k) ((inst k InitialState)
(core:transition initial-state
(list exp ...)))))))
debug-name)])))
(define-syntax ground-vm:
(lambda (stx)
(syntax-parse stx
[(_ (~or (~optional (~seq #:boot-pid boot-pid) #:defaults ([boot-pid #'p0])
#:name "#:boot-pid")
(~optional (~seq #:initial-state initial-state (~literal :) InitialState)
#:defaults ([initial-state #'(void)] [InitialState #'Void])
#:name "#:initial-state"))
...
exp ...)
#`(core:run-ground-vm
(core:process-spec (lambda (boot-pid)
(lambda (k) ((inst k InitialState)
(core:transition initial-state
(list exp ...)))))))])))
;;; Local Variables:
;;; eval: (put 'at-meta-level: 'scheme-indent-function 1)
;;; End:

113
sugar-untyped.rkt
View File

@ -1,113 +0,0 @@
#lang racket/base
(require (for-syntax syntax/parse))
(require (for-syntax racket/base))
(require racket/match)
(require (prefix-in core: "main.rkt"))
(require (except-in "main.rkt"
at-meta-level
spawn
yield
transition
delete-endpoint
send-message
quit))
(require "sugar-values.rkt")
(require "sugar-endpoints-untyped.rkt")
(provide (all-from-out "sugar-values.rkt")
(all-from-out "sugar-endpoints-untyped.rkt")
(all-from-out "main.rkt")
?
transition/no-state
spawn
spawn/continue
name-process
yield
at-meta-level
spawn-vm
ground-vm)
(define-syntax-rule (transition/no-state action ...)
(transition (void) action ...))
;; A fresh unification variable, as identifier-syntax.
(define-syntax ? (syntax-id-rules () (_ (wild))))
(define-syntax spawn
(lambda (stx)
(syntax-parse stx
[(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
exp)
#`(core:spawn (core:process-spec (lambda (pid) (lambda (k) (k exp))))
#f
#f)])))
(define-syntax spawn/continue
(lambda (stx)
(syntax-parse stx
[(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
#:parent parent-state-pattern parent-k-exp
#:child exp)
#`(core:spawn (core:process-spec (lambda (pid) (lambda (k) (k exp))))
(lambda (pid) (match-lambda [parent-state-pattern parent-k-exp]))
#f)])))
(define (name-process n p)
(match p
[(core:spawn spec parent-k _)
(core:spawn spec parent-k n)]))
(define-syntax yield
(lambda (stx)
(syntax-case stx ()
[(_ state-pattern exp)
#'(core:yield (match-lambda [state-pattern exp]))])))
(define (at-meta-level . preactions)
(match preactions
[(cons preaction '()) (core:at-meta-level preaction)]
[_ (map core:at-meta-level preactions)]))
(define-syntax spawn-vm
(lambda (stx)
(syntax-parse stx
[(_ (~or (~optional (~seq #:vm-pid vm-pid) #:defaults ([vm-pid #'p0])
#:name "#:vm-pid")
(~optional (~seq #:boot-pid boot-pid) #:defaults ([boot-pid #'p0])
#:name "#:boot-pid")
(~optional (~seq #:initial-state initial-state)
#:defaults ([initial-state #'(void)])
#:name "#:initial-state")
(~optional (~seq #:debug-name debug-name)
#:defaults ([debug-name #'#f])
#:name "#:debug-name"))
...
exp ...)
#`(core:make-nested-vm
(lambda (vm-pid)
(core:process-spec (lambda (boot-pid)
(lambda (k) (k (core:transition initial-state
(list exp ...)))))))
debug-name)])))
(define-syntax ground-vm
(lambda (stx)
(syntax-parse stx
[(_ (~or (~optional (~seq #:boot-pid boot-pid) #:defaults ([boot-pid #'p0])
#:name "#:boot-pid")
(~optional (~seq #:initial-state initial-state)
#:defaults ([initial-state #'(void)])
#:name "#:initial-state"))
...
exp ...)
#`(core:run-ground-vm
(core:process-spec (lambda (boot-pid)
(lambda (k) (k (core:transition initial-state
(list exp ...)))))))])))
;;; Local Variables:
;;; eval: (put 'name-process 'scheme-indent-function 1)
;;; eval: (put 'yield 'scheme-indent-function 1)
;;; End:

80
sugar-values.rkt
View File

@ -1,80 +0,0 @@
#lang typed/racket/base
(require racket/match)
(require (prefix-in core: "main.rkt"))
(provide transition
delete-endpoint
send-message
send-feedback
quit
sequence-actions
(rename-out [core:wild wild]))
(: transition : (All (State) State (core:ActionTree State) * -> (core:Transition State)))
(define (transition state . actions)
((inst core:transition State) state actions))
(define (delete-endpoint #{id : Any}
[#{reason : Any} #f])
(core:delete-endpoint (cast id core:PreEID) (cast reason core:Reason)))
(: send-message : (case-> [Any -> core:send-message]
[Any core:Orientation -> core:send-message]))
(define (send-message body [#{orientation : core:Orientation} 'publisher])
(core:send-message (cast body core:Message) orientation))
(define (send-feedback #{body : Any})
(core:send-message (cast body core:Message) 'subscriber))
(: quit : (case-> [-> core:quit]
[(Option core:PID) -> core:quit]
[(Option core:PID) Any -> core:quit]))
(define (quit [#{who : (Option core:PID)} (ann #f (Option core:PID))]
[#{reason : Any} #f])
(core:quit who (cast reason core:Reason)))
(: sequence-actions : (All (State)
(core:Transition State)
(U (core:ActionTree State) (State -> (core:Transition State))) *
-> (core:Transition State)))
(define (sequence-actions t . more-actions-and-transformers)
(match-define (core:transition initial-state initial-actions) t)
(let loop ((state initial-state)
(actions initial-actions)
(items more-actions-and-transformers))
(match items
['()
(core:transition state actions)]
[(cons item remaining-items)
(if (or (pair? item)
(eq? item #f)
(void? item)
(null? item)
(core:add-endpoint? item)
(core:delete-endpoint? item)
(core:send-message? item)
(core:spawn? item)
(core:quit? item)
(core:yield? item)
(core:at-meta-level? item))
;; ^ This is ugly, but necessary to let Typed Racket
;; correctly deduce the type of item in the expression
;; (item state) in the false branch of this conditional.
;; Because the type Action is parameterized, there's no
;; sensible way of factoring out the big or here into a
;; reusable predicate.
(loop state
((inst cons (core:ActionTree State) (core:ActionTree State))
actions
item)
remaining-items)
(match (item state)
[(core:transition new-state more-actions)
(loop new-state
(cons actions more-actions)
remaining-items)]))])))
;;; Local Variables:
;;; eval: (put 'sequence-actions 'scheme-indent-function 1)
;;; End:

166
sugar-endpoints-untyped.rkt → sugar.rkt
View File

@ -4,12 +4,25 @@
(require (for-syntax racket/base)) (require (for-syntax racket/base))
(require racket/match) (require racket/match)
(require (prefix-in core: "main.rkt")) (require (prefix-in core: "main.rkt"))
(require (except-in "main.rkt"
at-meta-level
spawn
yield
transition
delete-endpoint
send-message
quit))
(require "support/dsl-untyped.rkt")
(require "sugar-endpoints-support.rkt") (provide transition
delete-endpoint
send-message
send-feedback
quit
sequence-actions
(rename-out [core:wild wild])
(provide (all-from-out "sugar-endpoints-support.rkt")
name-endpoint name-endpoint
let-fresh let-fresh
observe-subscribers observe-subscribers
@ -18,7 +31,71 @@
observe-publishers/everything observe-publishers/everything
publisher publisher
subscriber subscriber
build-endpoint) build-endpoint
?
transition/no-state
spawn
spawn/continue
name-process
yield
at-meta-level
spawn-vm
ground-vm)
;; transition : (All (State) State (core:ActionTree State) * -> (core:Transition State))
(define (transition state . actions)
(core:transition state actions))
(define (delete-endpoint id [reason #f])
(core:delete-endpoint id reason))
;; send-message : (case-> [Any -> core:send-message]
;; [Any core:Orientation -> core:send-message])
(define (send-message body [orientation 'publisher])
(core:send-message body orientation))
(define (send-feedback body)
(core:send-message body 'subscriber))
;; quit : (case-> [-> core:quit]
;; [(Option core:PID) -> core:quit]
;; [(Option core:PID) Any -> core:quit])
(define (quit [who #f] [reason #f])
(core:quit who reason))
;; sequence-actions : (All (State)
;; (core:Transition State)
;; (U (core:ActionTree State) (State -> (core:Transition State))) *
;; -> (core:Transition State))
(define (sequence-actions t . more-actions-and-transformers)
(match-define (core:transition initial-state initial-actions) t)
(let loop ((state initial-state)
(actions initial-actions)
(items more-actions-and-transformers))
(match items
['()
(core:transition state actions)]
[(cons item remaining-items)
(if (procedure? item)
(match (item state)
[(core:transition new-state more-actions)
(loop new-state
(cons actions more-actions)
remaining-items)])
(loop state
(cons actions item)
remaining-items))])))
(define&provide-dsl-helper-syntaxes "endpoint definition context"
[match-state
match-orientation
match-conversation
match-interest-type
match-reason
on-presence
on-absence
on-message])
;; Must handle: ;; Must handle:
;; - orientation ;; - orientation
@ -215,7 +292,88 @@
(syntax _))) (syntax _)))
[_ (lambda (state) (core:transition state '()))]))]))) [_ (lambda (state) (core:transition state '()))]))])))
(define-syntax-rule (transition/no-state action ...)
(transition (void) action ...))
;; A fresh unification variable, as identifier-syntax.
(define-syntax ? (syntax-id-rules () (_ (wild))))
(define-syntax spawn
(lambda (stx)
(syntax-parse stx
[(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
exp)
#`(core:spawn (core:process-spec (lambda (pid) (lambda (k) (k exp))))
#f
#f)])))
(define-syntax spawn/continue
(lambda (stx)
(syntax-parse stx
[(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
#:parent parent-state-pattern parent-k-exp
#:child exp)
#`(core:spawn (core:process-spec (lambda (pid) (lambda (k) (k exp))))
(lambda (pid) (match-lambda [parent-state-pattern parent-k-exp]))
#f)])))
(define (name-process n p)
(match p
[(core:spawn spec parent-k _)
(core:spawn spec parent-k n)]))
(define-syntax yield
(lambda (stx)
(syntax-case stx ()
[(_ state-pattern exp)
#'(core:yield (match-lambda [state-pattern exp]))])))
(define (at-meta-level . preactions)
(match preactions
[(cons preaction '()) (core:at-meta-level preaction)]
[_ (map core:at-meta-level preactions)]))
(define-syntax spawn-vm
(lambda (stx)
(syntax-parse stx
[(_ (~or (~optional (~seq #:vm-pid vm-pid) #:defaults ([vm-pid #'p0])
#:name "#:vm-pid")
(~optional (~seq #:boot-pid boot-pid) #:defaults ([boot-pid #'p0])
#:name "#:boot-pid")
(~optional (~seq #:initial-state initial-state)
#:defaults ([initial-state #'(void)])
#:name "#:initial-state")
(~optional (~seq #:debug-name debug-name)
#:defaults ([debug-name #'#f])
#:name "#:debug-name"))
...
exp ...)
#`(core:make-nested-vm
(lambda (vm-pid)
(core:process-spec (lambda (boot-pid)
(lambda (k) (k (core:transition initial-state
(list exp ...)))))))
debug-name)])))
(define-syntax ground-vm
(lambda (stx)
(syntax-parse stx
[(_ (~or (~optional (~seq #:boot-pid boot-pid) #:defaults ([boot-pid #'p0])
#:name "#:boot-pid")
(~optional (~seq #:initial-state initial-state)
#:defaults ([initial-state #'(void)])
#:name "#:initial-state"))
...
exp ...)
#`(core:run-ground-vm
(core:process-spec (lambda (boot-pid)
(lambda (k) (k (core:transition initial-state
(list exp ...)))))))])))
;;; Local Variables: ;;; Local Variables:
;;; eval: (put 'sequence-actions 'scheme-indent-function 1)
;;; eval: (put 'name-process 'scheme-indent-function 1)
;;; eval: (put 'yield 'scheme-indent-function 1)
;;; eval: (put 'name-endpoint 'scheme-indent-function 1) ;;; eval: (put 'name-endpoint 'scheme-indent-function 1)
;;; eval: (put 'let-fresh 'scheme-indent-function 1) ;;; eval: (put 'let-fresh 'scheme-indent-function 1)
;;; eval: (put 'observe-subscribers 'scheme-indent-function 1) ;;; eval: (put 'observe-subscribers 'scheme-indent-function 1)

96
support/debug.rkt
View File

@ -1,60 +1,56 @@
#lang typed/racket/base #lang racket/base
(require racket/match) (require racket/match)
(require (prefix-in core: "../main.rkt")) (require (prefix-in core: "../main.rkt"))
(require "../sugar-typed.rkt") (require "../sugar.rkt")
(require "../vm.rkt") (require "../vm.rkt")
(require "../process.rkt") (require "../process.rkt")
(require "../quasiqueue.rkt") (require "../quasiqueue.rkt")
(require/typed "gui.rkt" (require "gui.rkt")
[open-debugger (Any -> Debugger)])
(define-type Debugger (All (S) (S -> S))) ;; (define-type Debugger (All (S) (S -> S)))
(provide debug) (provide debug)
(: debug : (All (ParentState) (Spawn ParentState) -> (Spawn ParentState))) ;; debug : (All (ParentState) (Spawn ParentState) -> (Spawn ParentState))
(define (debug spawn-child) (define (debug spawn-child)
(match-define (core:spawn child-spec parent-k debug-name) spawn-child) (match-define (core:spawn child-spec parent-k debug-name) spawn-child)
(core:spawn (core:spawn
(process-spec (core:process-spec
(lambda: ([pid : PID]) ;; TODO: exploit this more in messages etc. (lambda (pid) ;; TODO: exploit this more in messages etc.
(define original-cotransition ((process-spec-boot child-spec) pid)) (define original-cotransition ((core:process-spec-boot child-spec) pid))
(: wrapped-cotransition : (All (R) (All (S) (Transition S) -> R) -> R)) ;; wrapped-cotransition : (All (R) (All (S) (Transition S) -> R) -> R)
(define (wrapped-cotransition k) (define (wrapped-cotransition k)
(: receiver : (All (S) (Transition S) -> R)) ;; receiver : (All (S) (Transition S) -> R)
(define (receiver child-transition) (define (receiver child-transition)
(define d (open-debugger debug-name)) (define d (open-debugger debug-name))
((inst k S) (wrap-transition d child-transition))) (k (wrap-transition d child-transition)))
((inst original-cotransition R) receiver)) (original-cotransition receiver))
wrapped-cotransition)) wrapped-cotransition))
parent-k parent-k
(list 'debug debug-name))) (list 'debug debug-name)))
(: wrap-transition : (All (ChildState) ;; wrap-transition : (All (ChildState)
Debugger ;; Debugger
(Transition ChildState) ;; (Transition ChildState)
-> (Transition ChildState))) ;; -> (Transition ChildState))
(define (wrap-transition d child-transition0) (define (wrap-transition d child-transition0)
(define child-transition ((inst d (Transition ChildState)) child-transition0)) (define child-transition (d child-transition0))
(match-define (core:transition child-state child-actions) child-transition) (match-define (core:transition child-state child-actions) child-transition)
(core:transition child-state ((inst action-tree-map ChildState) (core:transition child-state (action-tree-map (wrap-action d)
(wrap-action d) child-actions)))
child-actions)))
(: action-tree-map : (All (State) ((Action State) -> (Action State)) ;; action-tree-map : (All (State) ((Action State) -> (Action State))
(ActionTree State) ;; (ActionTree State)
-> (ActionTree State))) ;; -> (ActionTree State))
(define (action-tree-map f actions) (define (action-tree-map f actions)
((inst map (Action State) (Action State)) (map f (quasiqueue->list (action-tree->quasiqueue actions))))
f
(quasiqueue->list (action-tree->quasiqueue actions))))
(: wrap-action : (All (ChildState) ;; wrap-action : (All (ChildState)
Debugger ;; Debugger
-> ((Action ChildState) -> (Action ChildState)))) ;; -> ((Action ChildState) -> (Action ChildState)))
(define ((wrap-action d) action) (define ((wrap-action d) action)
(cond (cond
[(core:yield? action) [(core:yield? action)
@ -64,11 +60,11 @@
[else [else
(wrap-preaction #f d action)])) (wrap-preaction #f d action)]))
(: wrap-preaction : (All (ChildState) ;; wrap-preaction : (All (ChildState)
Boolean ;; Boolean
Debugger ;; Debugger
(PreAction ChildState) ;; (PreAction ChildState)
-> (PreAction ChildState))) ;; -> (PreAction ChildState))
(define (wrap-preaction meta? d preaction) (define (wrap-preaction meta? d preaction)
(match preaction (match preaction
[(core:add-endpoint pre-eid role handler) [(core:add-endpoint pre-eid role handler)
@ -82,28 +78,28 @@
[(core:quit pid reason) [(core:quit pid reason)
preaction])) preaction]))
(: wrap-interruptk : (All (ChildState) ;; wrap-interruptk : (All (ChildState)
Debugger ;; Debugger
(InterruptK ChildState) ;; (InterruptK ChildState)
-> (InterruptK ChildState))) ;; -> (InterruptK ChildState))
(define (wrap-interruptk d ik) (define (wrap-interruptk d ik)
(lambda (state) (lambda (state)
(wrap-transition d (ik state)))) (wrap-transition d (ik state))))
(: wrap-spawnk : (All (ChildState) ;; wrap-spawnk : (All (ChildState)
Debugger ;; Debugger
(Option (PID -> (InterruptK ChildState))) ;; (Option (PID -> (InterruptK ChildState)))
-> (Option (PID -> (InterruptK ChildState))))) ;; -> (Option (PID -> (InterruptK ChildState))))
(define (wrap-spawnk d maybe-k) (define (wrap-spawnk d maybe-k)
(and maybe-k (and maybe-k
(lambda: ([child-pid : PID]) (wrap-interruptk d (maybe-k child-pid))))) (lambda (child-pid) (wrap-interruptk d (maybe-k child-pid)))))
(: wrap-handler : (All (ChildState) ;; wrap-handler : (All (ChildState)
Boolean ;; Boolean
Debugger ;; Debugger
(Handler ChildState) ;; (Handler ChildState)
-> (Handler ChildState))) ;; -> (Handler ChildState))
(define (wrap-handler meta?0 d h) (define (wrap-handler meta?0 d h)
(lambda (event0) (lambda (event0)
(match-define (cons meta? event) ((inst d (Pairof Boolean EndpointEvent)) (cons meta?0 event0))) (match-define (cons meta? event) (d (cons meta?0 event0)))
(wrap-interruptk d (h event)))) (wrap-interruptk d (h event))))

7
support/event.rkt
View File

@ -1,7 +0,0 @@
#lang typed/racket/base
(require/typed typed/racket/base
[opaque Evt evt?])
(provide Evt
evt?)

2
support/gui.rkt
View File

@ -19,7 +19,7 @@
(require racket/pretty) (require racket/pretty)
(require (prefix-in core: "../types.rkt") (require (prefix-in core: "../structs.rkt")
(prefix-in core: "../vm.rkt")) (prefix-in core: "../vm.rkt"))
(provide open-debugger) (provide open-debugger)

18
support/pseudo-substruct.rkt
View File

@ -1,18 +0,0 @@
#lang typed/racket/base
;; Limited support for reasoning about subtyped of a polymorphic base struct type in TR.
(require (for-syntax racket/base))
(require racket/match)
(provide pseudo-substruct:)
(define-syntax-rule (pseudo-substruct: (super-type TypeParam ...) SubType sub-type sub-type?)
(begin (define-type SubType (super-type TypeParam ...))
(define-predicate sub-type? SubType)
(define-match-expander sub-type
(lambda (stx)
(syntax-case stx () [(_ f (... ...)) #'(? sub-type? (super-type f (... ...)))]))
(lambda (stx)
(syntax-case stx ()
[x (identifier? #'x) #'(inst super-type TypeParam ...)]
[(_ f (... ...)) #'((inst super-type TypeParam ...) f (... ...))])))))

44
support/spy.rkt
View File

@ -1,32 +1,30 @@
#lang typed/racket/base #lang racket/base
(require "../sugar-typed.rkt") (require "../sugar.rkt")
(provide generic-spy) (provide generic-spy)
(: generic-spy : (All (ParentState) Any -> (Spawn ParentState))) ;; generic-spy : (All (ParentState) Any -> (Spawn ParentState))
(define (generic-spy label) (define (generic-spy label)
(name-process `(generic-spy ,label) (name-process `(generic-spy ,label)
(spawn: #:parent : ParentState (spawn (transition (void)
#:child : Void (observe-publishers (wild)
(transition: (void) : Void (match-orientation orientation
(observe-publishers: Void (wild) (match-conversation topic
(match-orientation orientation (match-interest-type interest
(match-conversation topic (match-reason reason
(match-interest-type interest (on-presence (begin (write `(,label ENTER (,orientation ,topic ,interest)))
(match-reason reason
(on-presence (begin (write `(,label ENTER (,orientation ,topic ,interest)))
(newline)
(flush-output)
'()))
(on-absence (begin (write `(,label EXIT (,orientation ,topic ,interest)))
(newline)
(display reason)
(newline) (newline)
(flush-output) (flush-output)
'())) '()))
(on-message (on-absence (begin (write `(,label EXIT (,orientation ,topic ,interest)))
[p (begin (write `(,label MSG ,p)) (newline)
(newline) (display reason)
(flush-output) (newline)
'())])))))))))) (flush-output)
'()))
(on-message
[p (begin (write `(,label MSG ,p))
(newline)
(flush-output)
'())]))))))))))

12
test-struct-map-typed.rkt
View File

@ -1,12 +0,0 @@
#lang typed/racket/base
(require typed/rackunit)
(require/typed "struct-map.rkt"
[struct-map ((Any -> Any) Any -> Any)])
(require/typed "test-struct-map.rkt"
[#:struct foo ([bar : Integer]
[zot : Integer])])
(check-equal? (struct-map (lambda (x) (if (equal? x 123) 999 888)) (foo 123 234))
(foo 999 234))

166
tr-struct-copy.rkt
View File

@ -1,166 +0,0 @@
#lang racket/base
;; Revolting hacked-on struct-copy using unhygienic-identifier=?
;; instead of free-identifier=? to compare accessor names, to get
;; around the contracting of accessors exported from TR modules.
;;
;; Workaround for PR13149.
(require (for-syntax racket/base racket/private/struct-info))
(provide tr-struct-copy)
(define-for-syntax (unhygienic-identifier=? a b)
(eq? (syntax->datum a)
(syntax->datum b)))
(define-syntax (tr-struct-copy stx)
(if (not (eq? (syntax-local-context) 'expression))
(quasisyntax/loc stx (#%expression #,stx))
(syntax-case stx ()
[(form-name info struct-expr field+val ...)
(let ([ans (syntax->list #'(field+val ...))])
;; Check syntax:
(unless (identifier? #'info)
(raise-syntax-error #f "not an identifier for structure type" stx #'info))
(for-each (lambda (an)
(syntax-case an ()
[(field val)
(unless (identifier? #'field)
(raise-syntax-error #f
"not an identifier for field name"
stx
#'field))]
[(field #:parent p val)
(unless (identifier? #'field)
(raise-syntax-error #f
"not an identifier for field name"
stx
#'field))
(unless (identifier? #'p)
(raise-syntax-error #f
"not an identifier for parent struct name"
stx
#'field))]
[_
(raise-syntax-error #f
(string-append
"bad syntax;\n"
" expected a field update of the form (<field-id> <expr>)\n"
" or (<field-id> #:parent <parent-id> <expr>)")
stx
an)]))
ans)
(let-values ([(construct pred accessors parent)
(let ([v (syntax-local-value #'info (lambda () #f))])
(unless (struct-info? v)
(raise-syntax-error #f "identifier is not bound to a structure type" stx #'info))
(let ([v (extract-struct-info v)])
(values (cadr v)
(caddr v)
(cadddr v)
(list-ref v 5))))])
(let* ([ensure-really-parent
(λ (id)
(let loop ([parent parent])
(cond
[(eq? parent #t)
(raise-syntax-error #f "identifier not bound to a parent struct" stx id)]
[(not parent)
(raise-syntax-error #f "parent struct information not known" stx id)]
[(free-identifier=? id parent) (void)]
[else
(let ([v (syntax-local-value parent (lambda () #f))])
(unless (struct-info? v)
(raise-syntax-error #f "unknown parent struct" stx id)) ;; probably won't happen(?)
(let ([v (extract-struct-info v)])
(loop (list-ref v 5))))])))]
[new-fields
(map (lambda (an)
(syntax-case an ()
[(field expr)
(list (datum->syntax #'field
(string->symbol
(format "~a-~a"
(syntax-e #'info)
(syntax-e #'field)))
#'field)
#'expr
(car (generate-temporaries (list #'field))))]
[(field #:parent id expr)
(begin
(ensure-really-parent #'id)
(list (datum->syntax #'field
(string->symbol
(format "~a-~a"
(syntax-e #'id)
(syntax-e #'field)))
#'field)
#'expr
(car (generate-temporaries (list #'field)))))]))
ans)]
;; new-binding-for : syntax[field-name] -> (union syntax[expression] #f)
[new-binding-for
(lambda (f)
(ormap (lambda (new-field)
(and (unhygienic-identifier=? (car new-field) f)
(caddr new-field)))
new-fields))])
(unless construct
(raise-syntax-error #f
"constructor not statically known for structure type"
stx
#'info))
(unless pred
(raise-syntax-error #f
"predicate not statically known for structure type"
stx
#'info))
(unless (andmap values accessors)
(raise-syntax-error #f
"not all accessors are statically known for structure type"
stx
#'info))
(let ([dests
(map (lambda (new-field)
(or (ormap (lambda (f2)
(and f2
(unhygienic-identifier=? (car new-field) f2)
f2))
accessors)
(raise-syntax-error #f
"accessor name not associated with the given structure type"
stx
(car new-field))))
new-fields)])
;; Check for duplicates using dests, not as, because mod=? as might not be id=?
(let ((dupe (check-duplicate-identifier dests)))
(when dupe
(raise-syntax-error #f
"duplicate field assignment"
stx
;; Map back to an original field:
(ormap (lambda (nf)
(and nf
(unhygienic-identifier=? dupe (car nf))
(car nf)))
(reverse new-fields)))))
;; the actual result
#`(let ((the-struct struct-expr))
(if (#,pred the-struct)
(let #,(map (lambda (new-field)
#`[#,(caddr new-field) #,(cadr new-field)])
new-fields)
(#,construct
#,@(map
(lambda (field) (or (new-binding-for field)
#`(#,field the-struct)))
(reverse accessors))))
(raise-argument-error 'form-name
#,(format "~a?" (syntax-e #'info))
the-struct)))))))])))

119
types.rkt
View File

@ -1,119 +0,0 @@
#lang typed/racket/base
(require "quasiqueue.rkt")
(require/typed "opaque-any.rkt"
;; Various opaque "Any"s
[opaque Topic topic?]
[opaque PreEID pre-eid?]
[opaque Reason reason?])
(provide (all-defined-out)
(all-from-out "quasiqueue.rkt"))
;; This module uses different terminology to os2.rkt. From the paper:
;; "A role generalizes traditional notions of advertisement and
;; subscription by combining a topic of conversation with a direction:
;; either publisher or subscriber. An endpoint combines a role with
;; handlers for events relating to the conversation"
(define-type Orientation (U 'publisher 'subscriber))
(struct: role ([orientation : Orientation]
[topic : Topic]
[interest-type : InterestType])
#:transparent)
(define-type Role role)
(define-type Message Topic) ;; Cheesy.
(define-type InterestType (U 'participant 'observer 'everything))
(define-type (Handler State) (TrapK EndpointEvent State))
(define-type (InterruptK State) (State -> (Transition State)))
(define-type (TrapK Event State) (Event -> (InterruptK State)))
(define-type EndpointEvent (U PresenceEvent
AbsenceEvent
MessageEvent))
(struct: presence-event ([role : Role]) #:transparent)
(struct: absence-event ([role : Role] [reason : Reason]) #:transparent)
(struct: message-event ([role : Role] [message : Message]) #:transparent)
(define-type PresenceEvent presence-event)
(define-type AbsenceEvent absence-event)
(define-type MessageEvent message-event)
(struct: (State)
transition ([state : State]
[actions : (ActionTree State)])
#:transparent)
(define-type (Transition State) (transition State))
(define-type (ActionTree State) (Constreeof (Action State)))
;; Existential quantification over State
(define-type CoTransition (All (Result) (All (State) (Transition State) -> Result) -> Result))
;; Specification of a new process
(struct: process-spec ([boot : (PID -> CoTransition)])
#:transparent)
(define-type ProcessSpec process-spec)
(define-type (PreAction State) (U (add-endpoint State)
delete-endpoint
send-message
(spawn State)
quit))
(struct: (State)
add-endpoint ([pre-eid : PreEID]
[role : Role]
[handler : (Handler State)])
#:transparent)
(define-type (AddEndpoint State) (add-endpoint State))
(struct: delete-endpoint ([pre-eid : PreEID]
[reason : Reason])
#:transparent)
(define-type DeleteEndpoint delete-endpoint)
(struct: send-message ([body : Message]
[orientation : Orientation])
#:transparent)
(define-type SendMessage send-message)
(struct: (State)
spawn ([spec : process-spec]
[k : (Option (PID -> (InterruptK State)))]
[debug-name : Any])
#:transparent)
(define-type (Spawn State) (spawn State))
(struct: quit ([pid : (Option PID)] ;; #f = suicide
[reason : Reason])
#:transparent)
(define-type Quit quit)
(define-type (Action State) (U (PreAction State)
(yield State)
(at-meta-level State)))
(struct: (State)
yield ([k : (InterruptK State)])
#:transparent)
(define-type (Yield State) (yield State))
(struct: (State)
at-meta-level ([preaction : (PreAction State)])
#:transparent)
(define-type (AtMetaLevel State) (at-meta-level State))
(define-type PID Number)
;;; Local Variables:
;;; eval: (put 'transition 'scheme-indent-function 1)
;;; eval: (put 'transition: 'scheme-indent-function 3)
;;; eval: (put 'transition/no-state 'scheme-indent-function 0)
;;; End:

127
vm.rkt
View File

@ -1,22 +1,18 @@
#lang typed/racket/base #lang racket/base
(require racket/match) (require racket/match)
(require "types.rkt") (require "structs.rkt")
(require "roles.rkt") (require "roles.rkt")
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround (require "quasiqueue.rkt")
(provide vm-processes ;; (struct-out vm) doesn't work because of make-vm below (See PR13161) (provide vm-processes ;; (struct-out vm) doesn't work because of make-vm below (See PR13161)
vm-next-process-id vm-next-process-id
vm ;; really just want to export the type here, not the ctor vm
vm? vm?
(struct-out process) (struct-out process)
(struct-out endpoint) (struct-out endpoint)
(struct-out eid) (struct-out eid)
Process
CoProcess
mkProcess
unwrap-process
make-vm make-vm
inject-process inject-process
@ -26,79 +22,53 @@
process-map process-map
endpoint-fold) endpoint-fold)
(struct: vm ([processes : (HashTable PID Process)] (struct vm (processes ;; (HashTable PID Process)
[next-process-id : PID]) next-process-id ;; PID
#:transparent) )
#:transparent)
(struct: (State) (struct process (debug-name ;; Any
process ([debug-name : Any] pid ;; PID
[pid : PID] state ;; State
[state : State] spawn-ks ;; (Listof (Pairof Integer (TrapK PID State))) ;; hmm
[spawn-ks : (Listof (Pairof Integer (TrapK PID State)))] ;; hmm endpoints ;; (HashTable PreEID (endpoint State))
[endpoints : (HashTable PreEID (endpoint State))] meta-endpoints ;; (HashTable PreEID (endpoint State))
[meta-endpoints : (HashTable PreEID (endpoint State))] pending-actions ;; (QuasiQueue (Action State))
[pending-actions : (QuasiQueue (Action State))]) )
#:transparent) #:transparent)
(struct: (State) (struct endpoint (id ;; eid
endpoint ([id : eid] role ;; role
[role : role] handler ;; (Handler State)
[handler : (Handler State)]) )
#:transparent) #:transparent)
(struct: eid ([pid : PID] (struct eid (pid ;; PID
[pre-eid : PreEID]) pre-eid ;; PreEID
#:transparent) )
#:transparent)
(define-type Process (All (R) (CoProcess R) -> R))
(define-type (CoProcess R) (All (State) (process State) -> R))
(: mkProcess : (All (State) ((CoProcess Process) State)))
;; A kind of identity function, taking the components of a process to
;; a process.
(define (mkProcess p)
(lambda (k) ((inst k State) p)))
(: Process-pid : Process -> PID)
(define (Process-pid wp) ((inst wp PID) process-pid))
;; Unwraps a process. Result is the type of the result of the
;; expression; State is a type variable to be bound to the process's
;; private state type. p is to be bound to the unwrapped process; wp
;; is the expression producing the wrapped process. body... are the
;; forms computing a value of type Result.
(define-syntax-rule (unwrap-process State Result (p wp) body ...)
(let ()
(: coproc : (All (State) (process State) -> Result))
(define (coproc p)
body ...)
((inst wp Result) coproc)))
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
(: make-vm : process-spec -> vm) ;; make-vm : process-spec -> vm
(define (make-vm boot) (define (make-vm boot)
(define primordial (mkProcess ((inst process Void) (define primordial (process '#:primordial
'#:primordial -1
-1 (void)
(void) (list)
(list) #hash()
#hash() #hash()
#hash() (quasiqueue (spawn boot #f '#:boot-process))))
(quasiqueue ((inst spawn Void) boot #f '#:boot-process))))) (vm (hash-set #hash() (process-pid primordial) primordial) 0))
(vm (hash-set (ann #hash() (HashTable PID Process))
(Process-pid primordial)
primordial)
0))
(: inject-process : vm Process -> vm) ;; inject-process : vm Process -> vm
(define (inject-process state wp) (define (inject-process state wp)
(struct-copy vm state [processes (hash-set (vm-processes state) (Process-pid wp) wp)])) (struct-copy vm state [processes (hash-set (vm-processes state) (process-pid wp) wp)]))
(: always-false : -> False) ;; always-false : -> False
(define (always-false) #f) (define (always-false) #f)
(: extract-process : vm PID -> (values vm (Option Process))) ;; extract-process : vm PID -> (values vm (Option Process))
(define (extract-process state pid) (define (extract-process state pid)
(define wp (hash-ref (vm-processes state) pid always-false)) (define wp (hash-ref (vm-processes state) pid always-false))
(values (if wp (values (if wp
@ -106,29 +76,28 @@
state) state)
wp)) wp))
(: reset-pending-actions : (All (State) (process State) -> (process State))) ;; reset-pending-actions : (All (State) (process State) -> (process State))
(define (reset-pending-actions p) (define (reset-pending-actions p)
(struct-copy process p [pending-actions ((inst empty-quasiqueue (Action State)))])) (struct-copy process p [pending-actions (empty-quasiqueue)]))
(: process-map : (All (State) (process State) -> (process State)) vm -> vm) ;; process-map : (All (State) (process State) -> (process State)) vm -> vm
;; TODO: simplify
(define (process-map f state) (define (process-map f state)
(for/fold ([state state]) ([pid (in-hash-keys (vm-processes state))]) (for/fold ([state state]) ([pid (in-hash-keys (vm-processes state))])
(let-values (((state wp) (extract-process state pid))) (let-values (((state wp) (extract-process state pid)))
(if (not wp) (if (not wp)
state state
(unwrap-process State vm (p wp) (inject-process state (f wp))))))
(inject-process state (mkProcess (f p))))))))
(: endpoint-fold : (All (A) (All (State) (process State) (endpoint State) A -> A) A vm -> A)) ;; endpoint-fold : (All (A) (All (State) (process State) (endpoint State) A -> A) A vm -> A)
(define (endpoint-fold f seed state) (define (endpoint-fold f seed state)
(for/fold ([seed seed]) ([pid (in-hash-keys (vm-processes state))]) (for/fold ([seed seed]) ([pid (in-hash-keys (vm-processes state))])
(let-values (((state wp) (extract-process state pid))) (let-values (((state wp) (extract-process state pid)))
(if (not wp) (if (not wp)
seed seed
(unwrap-process State A (p wp) (for/fold ([seed seed]) ([pre-eid (in-hash-keys (process-endpoints wp))])
(for/fold ([seed seed]) ([pre-eid (in-hash-keys (process-endpoints p))]) (define ep (hash-ref (process-endpoints wp) pre-eid))
(define ep (hash-ref (process-endpoints p) pre-eid)) (f wp ep seed))))))
((inst f State) p ep seed)))))))
;;; Local Variables: ;;; Local Variables:
;;; eval: (put 'unwrap-process 'scheme-indent-function 3) ;;; eval: (put 'unwrap-process 'scheme-indent-function 3)