Compare commits
2 Commits
typeless
...
custom-edg
Author | SHA1 | Date |
---|---|---|
Tony Garnock-Jones | a48f886509 | |
Tony Garnock-Jones | 6e3b8be397 |
30
README.md
30
README.md
|
@ -30,40 +30,40 @@ This repository contains a [Racket](http://racket-lang.org/) package,
|
||||||
`marketplace`, which includes
|
`marketplace`, which includes
|
||||||
|
|
||||||
- the implementation of the `#lang marketplace` language, in the
|
- the implementation of the `#lang marketplace` language, in the
|
||||||
[top directory](https://github.com/tonyg/marketplace/tree/typeless/).
|
[top directory](https://github.com/tonyg/marketplace/tree/master/).
|
||||||
|
|
||||||
- a TCP echo server example, in
|
- a TCP echo server example, in
|
||||||
[`examples/echo-paper.rkt`](https://github.com/tonyg/marketplace/tree/typeless/examples/echo-paper.rkt).
|
[`examples/echo-paper.rkt`](https://github.com/tonyg/marketplace/tree/master/examples/echo-paper.rkt).
|
||||||
|
|
||||||
- a TCP chat server example, in
|
- a TCP chat server example, in
|
||||||
[`examples/chat-paper.rkt`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat-paper.rkt).
|
[`examples/chat-paper.rkt`](https://github.com/tonyg/marketplace/tree/master/examples/chat-paper.rkt).
|
||||||
|
|
||||||
- Haskell, Erlang and Python implementations of the chat server for comparison, in
|
- Haskell, Erlang and Python implementations of the chat server for comparison, in
|
||||||
[`examples/chat.hs`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat.hs),
|
[`examples/chat.hs`](https://github.com/tonyg/marketplace/tree/master/examples/chat.hs),
|
||||||
[`chat.erl`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat.erl),
|
[`chat.erl`](https://github.com/tonyg/marketplace/tree/master/examples/chat.erl),
|
||||||
and
|
and
|
||||||
[`chat.py`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat.py)
|
[`chat.py`](https://github.com/tonyg/marketplace/tree/master/examples/chat.py)
|
||||||
respectively.
|
respectively.
|
||||||
|
|
||||||
## Compiling and running the code
|
## Compiling and running the code
|
||||||
|
|
||||||
You will need Racket version 6.1.x or later.
|
You will need Racket version 5.90.x or later.
|
||||||
|
|
||||||
Once you have Racket installed, run
|
Once you have Racket installed, run
|
||||||
|
|
||||||
raco pkg install marketplace
|
|
||||||
|
|
||||||
to install the package from the Racket package repository, or
|
|
||||||
|
|
||||||
raco pkg install --link `pwd`
|
raco pkg install --link `pwd`
|
||||||
|
|
||||||
from the root directory of the Git checkout to install the package
|
from the root directory of the Git checkout to install the package in
|
||||||
from a local snapshot. (Alternatively, `make link` does the same thing.)
|
your Racket system. (Alternatively, `make link` does the same thing.)
|
||||||
This will make `#lang marketplace` available to programs.
|
This will make `#lang marketplace` available to programs.
|
||||||
|
|
||||||
|
It will take several minutes to compile the code. On my Macbook Air,
|
||||||
|
it takes around 10 minutes; on my ridiculously fast desktop machine,
|
||||||
|
it still takes around 2 minutes.
|
||||||
|
|
||||||
At this point, you may load and run any of the example `*.rkt` files
|
At this point, you may load and run any of the example `*.rkt` files
|
||||||
in the
|
in the
|
||||||
[`examples/`](https://github.com/tonyg/marketplace/tree/typeless/examples/)
|
[`examples/`](https://github.com/tonyg/marketplace/tree/master/examples/)
|
||||||
directory.
|
directory.
|
||||||
|
|
||||||
Note that both the echo server and chat server examples do not print
|
Note that both the echo server and chat server examples do not print
|
||||||
|
@ -76,4 +76,4 @@ so you cannot run both simultaneously.
|
||||||
|
|
||||||
## Copyright
|
## Copyright
|
||||||
|
|
||||||
Copyright © Tony Garnock-Jones 2010, 2011, 2012, 2013, 2014.
|
Copyright © Tony Garnock-Jones 2010, 2011, 2012, 2013.
|
||||||
|
|
|
@ -1,15 +1,16 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "structs.rkt")
|
(require "types.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)))
|
||||||
|
@ -34,7 +35,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)]))
|
||||||
|
|
|
@ -1,44 +1,46 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "structs.rkt")
|
(require "types.rkt")
|
||||||
(require "roles.rkt")
|
(require "roles.rkt")
|
||||||
(require "vm.rkt")
|
(require "vm.rkt")
|
||||||
(require "process.rkt")
|
(require "process.rkt")
|
||||||
(require "quasiqueue.rkt")
|
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
|
||||||
|
|
||||||
(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) (absence-event t reason))
|
(lambda: ([t : Role]) (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 ([p p] [state state])
|
(for/fold: : (values (process State) vm)
|
||||||
|
([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)
|
(map (lambda (#{pre-eid : PreEID})
|
||||||
(delete-endpoint (eid (process-pid p) pre-eid) reason))
|
(delete-endpoint (cast (eid (process-pid p) pre-eid) PreEID)
|
||||||
|
reason))
|
||||||
(hash-keys (process-meta-endpoints p)))))))
|
(hash-keys (process-meta-endpoints p)))))))
|
||||||
|
|
|
@ -1,30 +1,31 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "structs.rkt")
|
(require "types.rkt")
|
||||||
(require "roles.rkt")
|
(require "roles.rkt")
|
||||||
(require "vm.rkt")
|
(require "vm.rkt")
|
||||||
(require "log.rkt")
|
(require "log-typed.rkt")
|
||||||
(require "process.rkt")
|
(require "process.rkt")
|
||||||
(require "action-delete-endpoint.rkt")
|
(require "action-delete-endpoint.rkt")
|
||||||
(require "quasiqueue.rkt")
|
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
|
||||||
|
|
||||||
|
(require/typed web-server/private/util
|
||||||
|
[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"
|
||||||
killed-pid
|
killed-pid
|
||||||
(process-debug-name p)
|
(process-debug-name p)
|
||||||
(if (exn? reason)
|
(if (exn? reason)
|
||||||
(parameterize ([current-error-port (open-output-string)])
|
(exn->string reason)
|
||||||
((error-display-handler) (exn-message reason) reason)
|
|
||||||
(get-output-string (current-error-port)))
|
|
||||||
(format "~v" reason))))
|
(format "~v" reason))))
|
||||||
|
|
||||||
(if (equal? killed-pid (process-pid p))
|
(if (equal? killed-pid (process-pid p))
|
||||||
|
@ -35,7 +36,9 @@
|
||||||
(if (not maybe-killed-wp)
|
(if (not maybe-killed-wp)
|
||||||
(values p state (empty-quasiqueue))
|
(values p state (empty-quasiqueue))
|
||||||
(apply values
|
(apply values
|
||||||
(let ((killed-p maybe-killed-wp))
|
(unwrap-process KilledState
|
||||||
|
(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)))
|
||||||
|
|
|
@ -1,22 +1,24 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "structs.rkt")
|
(require "types.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 ([p p]) ([eid (in-hash-keys endpoints)])
|
(for/fold: : (process State) ([p p])
|
||||||
|
([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))
|
||||||
|
|
|
@ -1,44 +1,46 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "structs.rkt")
|
(require "types.rkt")
|
||||||
(require "roles.rkt")
|
(require "roles.rkt")
|
||||||
(require "vm.rkt")
|
(require "vm.rkt")
|
||||||
(require "log.rkt")
|
(require "log-typed.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)
|
||||||
(k (transition #f (quit #f e))))
|
((inst k False) (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)
|
||||||
(process debug-name
|
(mkProcess ((inst process NewState)
|
||||||
|
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)))
|
||||||
(new-cotransition transition-accepter))))
|
((inst new-cotransition Process) 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)))
|
||||||
|
|
79
actions.rkt
79
actions.rkt
|
@ -1,10 +1,10 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "structs.rkt")
|
(require "types.rkt")
|
||||||
(require "roles.rkt")
|
(require "roles.rkt")
|
||||||
(require "vm.rkt")
|
(require "vm.rkt")
|
||||||
(require "log.rkt")
|
(require "log-typed.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,17 +12,18 @@
|
||||||
(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 "quasiqueue.rkt")
|
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
|
||||||
|
|
||||||
(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 ([acc '()])
|
(processes ,@(for/fold: : Any
|
||||||
|
([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)))
|
||||||
(let ((p wp))
|
(unwrap-process State Any (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])
|
||||||
|
@ -31,16 +32,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 (hash-keys (vm-processes state)))
|
(let next-process ((remaining-pids ((inst hash-keys PID Process) (vm-processes state)))
|
||||||
(state state)
|
(state state)
|
||||||
(external-actions (empty-quasiqueue)))
|
(external-actions ((inst empty-quasiqueue (Action vm)))))
|
||||||
(match remaining-pids
|
(match remaining-pids
|
||||||
['()
|
['()
|
||||||
(let ((state (collect-dead-processes state))
|
(let ((state (collect-dead-processes state))
|
||||||
|
@ -53,7 +54,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)
|
||||||
(let ((p wp))
|
(unwrap-process State (transition vm) (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)]
|
||||||
|
@ -62,7 +63,7 @@
|
||||||
(match remaining-actions
|
(match remaining-actions
|
||||||
['()
|
['()
|
||||||
(next-process remaining-pids
|
(next-process remaining-pids
|
||||||
(inject-process state p)
|
(inject-process state (mkProcess p))
|
||||||
external-actions)]
|
external-actions)]
|
||||||
[(cons action remaining-actions)
|
[(cons action remaining-actions)
|
||||||
(marketplace-log 'debug
|
(marketplace-log 'debug
|
||||||
|
@ -83,19 +84,20 @@
|
||||||
(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 ([processes #hash()])
|
[processes (for/fold: : (HashTable PID Process)
|
||||||
|
([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))
|
||||||
(let ((p wp))
|
(unwrap-process State (HashTable PID Process) (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
|
||||||
|
@ -104,21 +106,20 @@
|
||||||
(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)
|
(andmap (lambda (#{pid : PID})
|
||||||
(define wp (hash-ref (vm-processes state) pid))
|
(define wp (hash-ref (vm-processes state) pid))
|
||||||
(let ((p wp))
|
(unwrap-process State Boolean (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)
|
||||||
(transform-meta-action preaction p state)]
|
((inst transform-meta-action State) 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)))]
|
||||||
|
@ -139,39 +140,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
|
||||||
(let ((p wp))
|
(unwrap-process State vm (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 p)
|
(inject-process state (mkProcess 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 p))))))))
|
(inject-process state (mkProcess 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
|
||||||
(let ((p wp))
|
(unwrap-process State vm (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 p)]
|
(inject-process state (mkProcess 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 (run-ready p1 interruptk))]))))))
|
(inject-process state (mkProcess (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)
|
||||||
|
@ -179,12 +180,13 @@
|
||||||
(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
|
||||||
(endpoint new-eid
|
((inst endpoint State)
|
||||||
|
new-eid
|
||||||
role
|
role
|
||||||
unwrapped-handler))])
|
unwrapped-handler))])
|
||||||
state
|
state
|
||||||
(quasiqueue
|
(quasiqueue
|
||||||
(add-endpoint new-eid
|
(add-endpoint (cast new-eid PreEID)
|
||||||
role
|
role
|
||||||
(wrap-trapk new-eid))))]
|
(wrap-trapk new-eid))))]
|
||||||
[(delete-endpoint pre-eid reason)
|
[(delete-endpoint pre-eid reason)
|
||||||
|
@ -192,7 +194,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 old-eid reason)))]
|
(quasiqueue (delete-endpoint (cast old-eid PreEID) reason)))]
|
||||||
[(send-message body orientation)
|
[(send-message body orientation)
|
||||||
(values p
|
(values p
|
||||||
state
|
state
|
||||||
|
@ -200,14 +202,15 @@
|
||||||
[(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 car (process-spawn-ks p))))))
|
(let ((spawn-k-id (+ 1 (list-max (map (inst car Integer (TrapK PID State))
|
||||||
|
(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 (spawn spec #f debug-name))))]
|
(quasiqueue ((inst spawn vm) spec #f debug-name))))]
|
||||||
[(quit maybe-pid reason)
|
[(quit maybe-pid reason)
|
||||||
(values p
|
(values p
|
||||||
state
|
state
|
||||||
|
|
|
@ -1,21 +1,24 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
;; Ground-event relay.
|
;; Ground-event relay.
|
||||||
|
|
||||||
(provide event-relay)
|
(provide event-relay)
|
||||||
(require "../sugar.rkt")
|
(require "../sugar-typed.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 (transition/no-state
|
(spawn: #:parent : ParentState
|
||||||
(observe-subscribers (cons ? ?)
|
#:child : Void
|
||||||
|
(transition/no-state
|
||||||
|
(observe-subscribers: Void (cons ? ?)
|
||||||
(match-conversation (cons (? evt? e) _)
|
(match-conversation (cons (? evt? e) _)
|
||||||
(on-presence (begin
|
(on-presence (begin
|
||||||
(printf "SUBSCRIBED ~v~n" e)
|
(printf "SUBSCRIBED ~v~n" e)
|
||||||
(flush-output)
|
(flush-output)
|
||||||
(at-meta-level
|
(at-meta-level: Void
|
||||||
(name-endpoint `(event-relay ,self-id ,e)
|
(name-endpoint `(event-relay ,self-id ,e)
|
||||||
(subscriber (cons e ?)
|
(subscriber: Void (cons e ?)
|
||||||
(on-message
|
(on-message
|
||||||
[msg (begin (printf "FIRED ~v -> ~v~n" e msg)
|
[msg (begin (printf "FIRED ~v -> ~v~n" e msg)
|
||||||
(flush-output)
|
(flush-output)
|
||||||
|
@ -23,5 +26,5 @@
|
||||||
(on-absence (begin
|
(on-absence (begin
|
||||||
(printf "UNSUBSCRIBED ~v~n" e)
|
(printf "UNSUBSCRIBED ~v~n" e)
|
||||||
(flush-output)
|
(flush-output)
|
||||||
(at-meta-level
|
(at-meta-level: Void
|
||||||
(delete-endpoint `(event-relay ,self-id ,e)))))))))))
|
(delete-endpoint `(event-relay ,self-id ,e)))))))))))
|
||||||
|
|
|
@ -5,9 +5,8 @@
|
||||||
(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.rkt")
|
(require "../sugar-untyped.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)
|
||||||
|
|
|
@ -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.rkt")
|
(require "../sugar-untyped.rkt")
|
||||||
(require "../support/dump-bytes.rkt")
|
(require "../support/dump-bytes.rkt")
|
||||||
|
|
||||||
(provide (struct-out tcp-address)
|
(provide (struct-out tcp-address)
|
||||||
|
|
|
@ -5,9 +5,8 @@
|
||||||
(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.rkt")
|
(require "../sugar-untyped.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)
|
||||||
|
|
|
@ -0,0 +1,13 @@
|
||||||
|
#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]))
|
|
@ -1,4 +1,4 @@
|
||||||
#lang racket/base
|
#lang typed/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,48 +7,103 @@
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require data/heap)
|
(require "../sugar-typed.rkt")
|
||||||
(require "../sugar.rkt")
|
(require "../support/event.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)
|
||||||
|
|
||||||
(provide (struct-out set-timer)
|
(require/typed data/heap
|
||||||
(struct-out timer-expired)
|
[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?
|
||||||
|
|
||||||
timer-driver
|
timer-driver
|
||||||
timer-relay)
|
timer-relay)
|
||||||
|
|
||||||
;; (define-type TimerKind (U 'relative 'absolute))
|
(define-type TimerLabel Any)
|
||||||
|
|
||||||
|
(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 set-timer (label msecs kind) #:transparent)
|
(struct: (TLabel TMsecs TKind)
|
||||||
|
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 timer-expired (label msecs) #:transparent)
|
(struct: (TLabel TMsecs)
|
||||||
|
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) #:transparent)
|
(struct: driver-state ([heap : Heap]) #:transparent)
|
||||||
|
|
||||||
;; (define-type RelayKey Exact-Nonnegative-Integer)
|
(define-type DriverState driver-state)
|
||||||
|
|
||||||
|
(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)),
|
||||||
|
@ -59,18 +114,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
|
||||||
|
@ -78,7 +133,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))
|
||||||
'()
|
'()
|
||||||
|
@ -91,64 +146,70 @@
|
||||||
|
|
||||||
;; 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 (transition (driver-state (make-timer-heap))
|
(spawn: #:parent : ParentState
|
||||||
(subscriber (set-timer (wild) (wild) (wild))
|
#:child : DriverState
|
||||||
|
(transition: (driver-state (make-timer-heap)) : DriverState
|
||||||
|
(subscriber: DriverState (set-timer-pattern (wild) (wild) (wild))
|
||||||
(match-state state
|
(match-state state
|
||||||
(on-message
|
(on-message
|
||||||
[(set-timer label msecs 'relative)
|
[(set-timer label msecs 'relative)
|
||||||
(install-timer! state label (+ (current-inexact-milliseconds) msecs))]
|
(install-timer! state label (+ (current-inexact-milliseconds) msecs))]
|
||||||
[(set-timer label msecs 'absolute)
|
[(set-timer label msecs 'absolute)
|
||||||
(install-timer! state label msecs)])))
|
(install-timer! state label msecs)])))
|
||||||
(publisher (timer-expired (wild) (wild)))))))
|
(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
|
(transition: state : DriverState
|
||||||
(delete-endpoint 'time-listener)
|
(delete-endpoint 'time-listener)
|
||||||
(and next
|
(and next
|
||||||
(name-endpoint 'time-listener
|
(name-endpoint 'time-listener
|
||||||
(subscriber (cons (timer-evt (pending-timer-deadline next)) (wild))
|
(subscriber: DriverState (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)
|
(sequence-actions (transition: state : DriverState)
|
||||||
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 (transition (relay-state 0 (make-immutable-hash '()))
|
(spawn: #:parent : ParentState
|
||||||
(at-meta-level
|
#:child : RelayState
|
||||||
(subscriber (timer-expired (wild) (wild))
|
(transition: (relay-state 0 (make-immutable-hash '())) : RelayState
|
||||||
|
(at-meta-level: RelayState
|
||||||
|
(subscriber: RelayState (timer-expired-pattern (wild) (wild))
|
||||||
(match-state (relay-state next-counter active-timers)
|
(match-state (relay-state next-counter active-timers)
|
||||||
(on-message
|
(on-message
|
||||||
[(timer-expired (list (== self-id) (? exact-nonnegative-integer? counter))
|
[(timer-expired (list (== self-id) (? exact-nonnegative-integer? counter))
|
||||||
now)
|
now)
|
||||||
(transition (relay-state next-counter (hash-remove active-timers counter))
|
(transition: (relay-state next-counter (hash-remove active-timers counter))
|
||||||
|
: RelayState
|
||||||
(and (hash-has-key? active-timers counter)
|
(and (hash-has-key? active-timers counter)
|
||||||
(send-message (timer-expired (hash-ref active-timers counter)
|
(send-message (timer-expired (hash-ref active-timers counter)
|
||||||
now))))]))))
|
now))))]))))
|
||||||
(subscriber (set-timer (wild) (wild) (wild))
|
(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)
|
[(set-timer label msecs kind)
|
||||||
(transition (relay-state (+ next-counter 1)
|
(transition: (relay-state (+ next-counter 1)
|
||||||
(hash-set active-timers next-counter label))
|
(hash-set active-timers next-counter label))
|
||||||
(at-meta-level
|
: RelayState
|
||||||
|
(at-meta-level: RelayState
|
||||||
(send-message (set-timer (list self-id next-counter) msecs kind))))])))
|
(send-message (set-timer (list self-id next-counter) msecs kind))))])))
|
||||||
(publisher (timer-expired (wild) (wild)))))))
|
(publisher: RelayState (timer-expired-pattern (wild) (wild)))))))
|
||||||
|
|
|
@ -0,0 +1,21 @@
|
||||||
|
#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]))
|
168
drivers/udp.rkt
168
drivers/udp.rkt
|
@ -1,20 +1,43 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
;; UDP driver.
|
;; UDP driver.
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require racket/udp)
|
|
||||||
|
|
||||||
(require "../sugar.rkt")
|
(require "../support/event.rkt")
|
||||||
|
(require (except-in racket/udp udp-receive!-evt))
|
||||||
|
(require/typed racket/udp
|
||||||
|
[udp-receive!-evt (UDP-Socket Bytes -> Evt)])
|
||||||
|
|
||||||
(provide (struct-out udp-remote-address)
|
(require "../sugar-typed.rkt")
|
||||||
(struct-out udp-handle)
|
(require "../support/event.rkt")
|
||||||
(struct-out udp-listener)
|
(require "../support/pseudo-substruct.rkt")
|
||||||
|
|
||||||
|
(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)
|
(struct-out udp-packet-repr)
|
||||||
|
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
|
||||||
|
@ -25,122 +48,171 @@
|
||||||
;; 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 udp-remote-address (host port) #:transparent)
|
(struct: (THost TPort)
|
||||||
(struct udp-handle (id) #:transparent)
|
udp-remote-address-repr ([host : THost]
|
||||||
(struct udp-listener (port) #:transparent)
|
[port : TPort])
|
||||||
|
#: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?)
|
||||||
|
|
||||||
(define (udp-address? x)
|
(struct: (TId)
|
||||||
(or (udp-remote-address? x)
|
udp-handle-repr ([id : TId])
|
||||||
(udp-handle? x)
|
#:transparent)
|
||||||
(udp-listener? x)))
|
(pseudo-substruct: (udp-handle-repr Any)
|
||||||
|
UdpHandle udp-handle udp-handle?)
|
||||||
|
(pseudo-substruct: (udp-handle-repr (U Wild Any))
|
||||||
|
UdpHandlePattern udp-handle-pattern udp-handle-pattern?)
|
||||||
|
|
||||||
(define (udp-local-address? x)
|
(struct: (TPort)
|
||||||
(or (udp-handle? x)
|
udp-listener-repr ([port : TPort])
|
||||||
(udp-listener? x)))
|
#:transparent)
|
||||||
|
(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 udp-packet (source destination body) #:transparent)
|
(struct: (TSource TDestination TBody)
|
||||||
|
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 handle-mapping (address socket) #:transparent)
|
(struct: (TAddress TSocket)
|
||||||
|
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 (wild) (wild)))
|
(define any-remote (udp-remote-address-pattern (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 _ (? udp-local-address? local-addr) _) topic)
|
(match-define (udp-packet-pattern _ (? udp-local-address? local-addr) _) topic)
|
||||||
(cond
|
(cond
|
||||||
[(set-member? active-handles local-addr)
|
[(set-member? active-handles local-addr)
|
||||||
(transition active-handles)]
|
(transition: active-handles : DriverState)]
|
||||||
[else
|
[else
|
||||||
(transition (set-add active-handles local-addr)
|
(transition: (set-add active-handles local-addr) : DriverState
|
||||||
(udp-socket-manager local-addr))]))
|
(udp-socket-manager local-addr))]))
|
||||||
|
|
||||||
(name-process 'udp-driver
|
(name-process 'udp-driver
|
||||||
(spawn (transition (set)
|
(spawn: #:parent : ParentState
|
||||||
|
#:child : DriverState
|
||||||
|
(transition: ((inst set UdpLocalAddress)) : DriverState
|
||||||
|
|
||||||
(observe-subscribers (udp-packet any-remote (udp-handle (wild)) (wild))
|
(observe-subscribers: DriverState
|
||||||
|
(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
|
||||||
|
(udp-packet-pattern any-remote (udp-listener-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-publishers (udp-packet any-remote (udp-handle (wild)) (wild))
|
(observe-publishers: DriverState
|
||||||
|
(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-publishers (udp-packet any-remote (udp-listener (wild)) (wild))
|
(observe-publishers: DriverState
|
||||||
|
(udp-packet-pattern any-remote (udp-listener-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-publishers (handle-mapping (wild) (wild))
|
(observe-publishers: DriverState (handle-mapping-pattern (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))))))
|
(transition: (set-remove active-handles local-addr) : DriverState)))))
|
||||||
))))
|
))))
|
||||||
|
|
||||||
;; 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
|
(transition: #f : SocketManagerState
|
||||||
(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 (begin (udp-close s)
|
(spawn: #:parent : SocketManagerState
|
||||||
(transition (void) (quit))))))))
|
#:child : Void
|
||||||
|
(begin (udp-close s)
|
||||||
|
(transition: (void) : Void (quit))))))))
|
||||||
|
|
||||||
(name-process `(udp-socket-manager ,local-addr)
|
(name-process `(udp-socket-manager ,local-addr)
|
||||||
(spawn (transition #t
|
(spawn: #:parent : DriverState
|
||||||
|
#: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 (handle-mapping local-addr s))
|
(publisher: SocketManagerState (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 (udp-packet any-remote local-addr (wild))
|
(publisher: SocketManagerState
|
||||||
|
(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 (udp-packet local-addr any-remote (wild))
|
(subscriber: SocketManagerState
|
||||||
|
(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
|
||||||
|
@ -148,10 +220,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?))])))
|
(transition: socket-is-open? : SocketManagerState))])))
|
||||||
;; 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 (cons (udp-receive!-evt s buffer) (wild))
|
(subscriber: SocketManagerState (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,10 +2,12 @@
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
(spawn-vm
|
(spawn-vm
|
||||||
|
#:debug-name 'listener-vm
|
||||||
(at-meta-level
|
(at-meta-level
|
||||||
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
|
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
|
||||||
(match-conversation (tcp-channel them us _)
|
(match-conversation (tcp-channel them us _)
|
||||||
(on-presence (spawn (chat-session them us)))))))
|
(on-presence (name-process `(,them --> ,us)
|
||||||
|
(spawn (chat-session them us))))))))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
(define (chat-session them us)
|
(define (chat-session them us)
|
||||||
|
|
|
@ -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)
|
(require marketplace/sugar-untyped)
|
||||||
(require marketplace/drivers/tcp-bare)
|
(require marketplace/drivers/tcp-bare)
|
||||||
|
|
||||||
(define (echoer from to)
|
(define (echoer from to)
|
||||||
|
|
52
ground.rkt
52
ground.rkt
|
@ -1,19 +1,45 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "structs.rkt")
|
(require "types.rkt")
|
||||||
(require "roles.rkt")
|
(require "roles.rkt")
|
||||||
(require "vm.rkt")
|
(require "vm.rkt")
|
||||||
(require "log.rkt")
|
(require "log-typed.rkt")
|
||||||
(require "process.rkt")
|
(require "process.rkt")
|
||||||
(require "actions.rkt")
|
(require "actions.rkt")
|
||||||
(require "action-send-message.rkt")
|
(require "action-send-message.rkt")
|
||||||
(require "quasiqueue.rkt")
|
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
|
||||||
|
(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
|
(require/typed profile
|
||||||
|
[profile-thunk ((-> Void) #:custom-key (Option (Pairof
|
||||||
|
(Continuation-Mark-Keyof Any)
|
||||||
|
(-> (Listof Any) (Listof Any))))
|
||||||
|
-> Void)])
|
||||||
|
|
||||||
|
(: run-ground-vm : process-spec -> Void)
|
||||||
(define (run-ground-vm boot)
|
(define (run-ground-vm boot)
|
||||||
|
(profile-thunk
|
||||||
|
(lambda ()
|
||||||
|
(profile-thunk (lambda () (run-ground-vm* boot))
|
||||||
|
#:custom-key (cons marketplace-continuation-mark-key
|
||||||
|
(lambda: ([vs : (Listof Any)])
|
||||||
|
(let: loop : (Listof Any) ((vs : (Listof Any) vs))
|
||||||
|
(if (null? vs)
|
||||||
|
'(ground)
|
||||||
|
(cons vs (loop (cdr vs)))))))))
|
||||||
|
#:custom-key #f))
|
||||||
|
|
||||||
|
(: run-ground-vm* : process-spec -> Void)
|
||||||
|
(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)
|
||||||
[(transition state actions)
|
[(transition state actions)
|
||||||
|
@ -31,7 +57,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
|
||||||
(endpoint-fold extract-ground-event-subscriptions '() state))
|
((inst endpoint-fold (Listof Evt)) extract-ground-event-subscriptions '() state))
|
||||||
(if (and is-blocking?
|
(if (and is-blocking?
|
||||||
(null? active-events))
|
(null? active-events))
|
||||||
(begin
|
(begin
|
||||||
|
@ -42,27 +68,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) values)))
|
(wrap-evt always-evt (lambda (dummy) (inst values vm))))
|
||||||
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
|
||||||
(let ((p wp))
|
(unwrap-process State vm (p wp)
|
||||||
(let-values
|
(let-values
|
||||||
(((p state)
|
(((p state)
|
||||||
(do-send-message 'publisher (cons evt message) p state)))
|
(do-send-message 'publisher (cast (cons evt message) Message) p state)))
|
||||||
(if p
|
(if p
|
||||||
(inject-process state p)
|
(inject-process state (mkProcess p))
|
||||||
state))))))
|
state))))))
|
||||||
(cons (wrap-evt evt evt-handler) acc)]
|
(cons (wrap-evt evt evt-handler) acc)]
|
||||||
[_ acc]))
|
[_ acc]))
|
||||||
|
|
8
info.rkt
8
info.rkt
|
@ -1,10 +1,2 @@
|
||||||
#lang setup/infotab
|
#lang setup/infotab
|
||||||
(define scribblings '(("scribblings/marketplace.scrbl" (multi-page))))
|
(define scribblings '(("scribblings/marketplace.scrbl" (multi-page))))
|
||||||
(define deps '("base"
|
|
||||||
"data-lib"
|
|
||||||
"gui-lib"
|
|
||||||
"images-lib"
|
|
||||||
"rackunit-lib"))
|
|
||||||
(define build-deps '("scribble-lib"
|
|
||||||
"slideshow-lib"
|
|
||||||
"typed-racket-lib"))
|
|
||||||
|
|
|
@ -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.rkt")
|
(require "../sugar-untyped.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.rkt")
|
(all-from-out "../sugar-untyped.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)
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
#lang racket/base
|
#lang typed/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))
|
||||||
|
|
|
@ -0,0 +1,17 @@
|
||||||
|
#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)
|
|
@ -7,6 +7,7 @@
|
||||||
|
|
||||||
(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
18
main.rkt
|
@ -1,26 +1,34 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
;; Virtualized operating system, this time with presence.
|
;; Virtualized operating system, this time with presence and types.
|
||||||
|
|
||||||
;; 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 "structs.rkt")
|
(require "types.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 "unify.rkt")
|
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
|
||||||
|
|
||||||
(provide (all-from-out "structs.rkt")
|
(require/typed "unify.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?
|
||||||
|
|
|
@ -1,17 +1,18 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "structs.rkt")
|
(require "types.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) (k (run-vm (make-vm (make-boot nested-vm-pid)))))))
|
(lambda (k) ((inst k vm) (run-vm (make-vm (make-boot nested-vm-pid)))))))
|
||||||
#f
|
#f
|
||||||
debug-name))
|
debug-name))
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,9 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide topic?
|
||||||
|
pre-eid?
|
||||||
|
reason?)
|
||||||
|
|
||||||
|
(define (topic? x) #t)
|
||||||
|
(define (pre-eid? x) #t)
|
||||||
|
(define (reason? x) #t)
|
102
process.rkt
102
process.rkt
|
@ -1,24 +1,27 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "structs.rkt")
|
(require "types.rkt")
|
||||||
(require "roles.rkt")
|
(require "roles.rkt")
|
||||||
(require "vm.rkt")
|
(require "vm.rkt")
|
||||||
(require "log.rkt")
|
(require "log-typed.rkt")
|
||||||
(require "quasiqueue.rkt")
|
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
|
||||||
|
|
||||||
(provide send-to-user
|
(provide send-to-user
|
||||||
send-to-user*
|
send-to-user*
|
||||||
action-tree->quasiqueue
|
action-tree->quasiqueue
|
||||||
quit-interruptk
|
quit-interruptk
|
||||||
run-ready
|
run-ready
|
||||||
notify-route-change-vm)
|
notify-route-change-vm
|
||||||
|
marketplace-continuation-mark-key)
|
||||||
|
|
||||||
|
(define marketplace-continuation-mark-key (make-continuation-mark-key 'marketplace))
|
||||||
|
|
||||||
(define-syntax-rule (send-to-user p (e) failure-result enclosed-expr)
|
(define-syntax-rule (send-to-user p (e) failure-result enclosed-expr)
|
||||||
(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)
|
(with-handlers ([exn:fail? (lambda: ([e : Reason])
|
||||||
(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))
|
||||||
|
@ -26,41 +29,50 @@
|
||||||
debug-name pid e))
|
debug-name pid e))
|
||||||
failure-result)])
|
failure-result)])
|
||||||
(marketplace-log 'debug "Entering process ~v(~v)" debug-name pid)
|
(marketplace-log 'debug "Entering process ~v(~v)" debug-name pid)
|
||||||
(define result enclosed-expr)
|
(define result (with-continuation-mark marketplace-continuation-mark-key
|
||||||
|
(or debug-name pid)
|
||||||
|
enclosed-expr))
|
||||||
(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 '()) (t t))
|
(let loop ((#{revacc : (QuasiQueue (Action State))} '()) (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 (quit #f e))
|
(send-to-user p (e) (transition old-state (ann (quit #f e) (Action State)))
|
||||||
(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)])
|
||||||
|
@ -79,13 +91,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]
|
||||||
|
@ -102,37 +114,39 @@
|
||||||
[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 ([pn (notify-route-change-self pn en flow->notification)]
|
(for/fold: : (values (process SNew)
|
||||||
[new-processes #hash()])
|
(HashTable PID Process))
|
||||||
|
([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
|
||||||
(let ((po wp))
|
(unwrap-process SOld (List (process SNew) (HashTable PID Process)) (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 po)))))))
|
(list pn (hash-set new-processes pid (mkProcess po))))))))
|
||||||
(values final-pn
|
(values final-pn
|
||||||
(struct-copy vm state [processes new-processes])))
|
(struct-copy vm state [processes new-processes])))
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,8 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
|
|
||||||
(provide empty-quasiqueue
|
(provide QuasiQueue
|
||||||
|
Constreeof
|
||||||
|
empty-quasiqueue
|
||||||
quasiqueue-empty?
|
quasiqueue-empty?
|
||||||
quasiqueue-append-list
|
quasiqueue-append-list
|
||||||
quasiqueue-append
|
quasiqueue-append
|
||||||
|
@ -10,36 +12,40 @@
|
||||||
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))
|
;; (reverse q) -- can't use this, TR won't prove Listof X <: Constreeof X.
|
||||||
|
(let loop ((#{acc : (Constreeof X)} '()) (q q))
|
||||||
|
(if (null? q)
|
||||||
|
acc
|
||||||
|
(loop (cons (car q) acc) (cdr q)))))
|
||||||
|
|
29
roles.rkt
29
roles.rkt
|
@ -1,9 +1,14 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "structs.rkt")
|
(require "types.rkt")
|
||||||
(require "log.rkt")
|
(require "log-typed.rkt")
|
||||||
(require "unify.rkt")
|
(require/typed "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
|
||||||
|
@ -13,34 +18,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 (co-orientations (role-orientation r))])
|
(for/list: ([co-orientation : 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))
|
||||||
|
@ -67,7 +72,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)))
|
||||||
|
|
|
@ -82,9 +82,8 @@ actions the process wishes to perform. See @secref{Actions} for the
|
||||||
possible actions a process can take.
|
possible actions a process can take.
|
||||||
|
|
||||||
Note that the result of an event handler function is actually a
|
Note that the result of an event handler function is actually a
|
||||||
@racket[transition] structure containing a new state and a sequence of
|
@racket[Transition] structure; the actual Typed Racket type of event
|
||||||
actions, rather than the explicit pair shown in the approximate type
|
handlers is @racket[TrapK], defined in @secref{handler-functions}.
|
||||||
above. See @secref{handler-functions} for more on handler functions.
|
|
||||||
|
|
||||||
@section{What is a VM?}
|
@section{What is a VM?}
|
||||||
|
|
||||||
|
|
|
@ -34,9 +34,10 @@ the subscription at the meta-level as well.
|
||||||
|
|
||||||
@defmodule[marketplace/drivers/tcp-bare]{
|
@defmodule[marketplace/drivers/tcp-bare]{
|
||||||
|
|
||||||
This module is included by default in programs using @tt{#lang
|
This module is only available for use by untyped Racket processes. It
|
||||||
marketplace}; see @secref{hashlang-variations} for information on
|
is included by default in programs using @tt{#lang marketplace}; see
|
||||||
other language variants.
|
@secref{hashlang-variations} for information on other language
|
||||||
|
variants.
|
||||||
|
|
||||||
@defproc[(tcp-driver) Spawn]{
|
@defproc[(tcp-driver) Spawn]{
|
||||||
|
|
||||||
|
@ -56,9 +57,9 @@ A pre-made @racket[spawn] action equivalent to @racket[(tcp-driver)].
|
||||||
|
|
||||||
@subsection{TCP channels}
|
@subsection{TCP channels}
|
||||||
|
|
||||||
@defstruct*[tcp-channel ([source (or/c tcp-address? tcp-handle? tcp-listener?)]
|
@defstruct*[tcp-channel ([source TcpAddress]
|
||||||
[destination (or/c tcp-address? tcp-handle? tcp-listener?)]
|
[destination TcpAddress]
|
||||||
[subpacket (or/c eof-object? bytes?)]) #:prefab]{
|
[subpacket TcpSubPacket]) #:prefab]{
|
||||||
|
|
||||||
A TCP channel represents a section of a unidirectional TCP flow
|
A TCP channel represents a section of a unidirectional TCP flow
|
||||||
appearing on our local "subnet" of the full TCP network, complete with
|
appearing on our local "subnet" of the full TCP network, complete with
|
||||||
|
@ -66,6 +67,10 @@ source, destination and subpacket. Each TCP connection has two such
|
||||||
flows: one inbound (remote-to-local) bytestream, and one outbound
|
flows: one inbound (remote-to-local) bytestream, and one outbound
|
||||||
(local-to-remote) bytestream.
|
(local-to-remote) bytestream.
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
@deftype[TcpSubPacket (or/c eof-object? bytes?)]{
|
||||||
|
|
||||||
Packets carried by @racket[tcp-channel] structures are either
|
Packets carried by @racket[tcp-channel] structures are either
|
||||||
end-of-file objects or raw binary data represented as Racket byte
|
end-of-file objects or raw binary data represented as Racket byte
|
||||||
vectors.
|
vectors.
|
||||||
|
@ -74,6 +79,8 @@ vectors.
|
||||||
|
|
||||||
@subsection{TCP addresses}
|
@subsection{TCP addresses}
|
||||||
|
|
||||||
|
@deftype[TcpAddress (or/c tcp-address? tcp-handle? tcp-listener?)]{
|
||||||
|
|
||||||
A TCP address describes one end of a TCP connection. It can be either
|
A TCP address describes one end of a TCP connection. It can be either
|
||||||
|
|
||||||
@itemlist[
|
@itemlist[
|
||||||
|
@ -82,6 +89,8 @@ A TCP address describes one end of a TCP connection. It can be either
|
||||||
@item{a @racket[tcp-listener], representing a local socket on a user-assigned port.}
|
@item{a @racket[tcp-listener], representing a local socket on a user-assigned port.}
|
||||||
]
|
]
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
@defstruct*[tcp-address ([host string?]
|
@defstruct*[tcp-address ([host string?]
|
||||||
[port (integer-in 0 65535)]) #:prefab]{
|
[port (integer-in 0 65535)]) #:prefab]{
|
||||||
|
|
||||||
|
@ -100,7 +109,7 @@ a local name for whichever underlying port number ends up being used.
|
||||||
The @racket[id] must be chosen carefully: it is scoped to the local
|
The @racket[id] must be chosen carefully: it is scoped to the local
|
||||||
VM, i.e. shared between processes in that VM, so processes must make
|
VM, i.e. shared between processes in that VM, so processes must make
|
||||||
sure not to accidentally clash in handle ID selection. They are also
|
sure not to accidentally clash in handle ID selection. They are also
|
||||||
used in @racket[tcp-channel] to mean a specific @emph{instance} of a TCP
|
used in TcpChannel to mean a specific @emph{instance} of a TCP
|
||||||
connection, so if you are likely to want to reconnect individual
|
connection, so if you are likely to want to reconnect individual
|
||||||
flows, use different values for @racket[id].
|
flows, use different values for @racket[id].
|
||||||
|
|
||||||
|
@ -194,14 +203,14 @@ where, as for receiving data, the @racket[subpacket] is either
|
||||||
Not yet documented.
|
Not yet documented.
|
||||||
}
|
}
|
||||||
|
|
||||||
@section{timer}
|
@section{timer (typed and untyped)}
|
||||||
|
|
||||||
For examples of the use of the timer driver, see uses of
|
For examples of the use of the timer driver, see uses of
|
||||||
@racket[set-timer] and @racket[timer-expired] in
|
@racket[set-timer] and @racket[timer-expired] in
|
||||||
@hyperlink["https://github.com/tonyg/marketplace-dns/blob/master/network-query.rkt"]{the
|
@hyperlink["https://github.com/tonyg/marketplace-dns/blob/master/network-query.rkt"]{the
|
||||||
Marketplace-based DNS resolver}.
|
Marketplace-based DNS resolver}.
|
||||||
|
|
||||||
@section{udp}
|
@section{udp (typed and untyped)}
|
||||||
|
|
||||||
For examples of the use of the UDP driver, see uses of
|
For examples of the use of the UDP driver, see uses of
|
||||||
@racket[udp-packet] etc. in
|
@racket[udp-packet] etc. in
|
||||||
|
|
|
@ -4,7 +4,9 @@
|
||||||
|
|
||||||
@title[#:tag "high-level-interface"]{High-level interface}
|
@title[#:tag "high-level-interface"]{High-level interface}
|
||||||
|
|
||||||
@declare-exporting[#:use-sources (marketplace/sugar)]
|
@declare-exporting[#:use-sources (marketplace/sugar-values
|
||||||
|
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
|
||||||
|
@ -15,7 +17,9 @@ interface} of a Unix-like operating system.
|
||||||
|
|
||||||
@;{
|
@;{
|
||||||
@defmodulelang*[(marketplace
|
@defmodulelang*[(marketplace
|
||||||
marketplace/flow-control)]
|
marketplace/flow-control
|
||||||
|
marketplace/typed
|
||||||
|
marketplace/typed/flow-control)]
|
||||||
}
|
}
|
||||||
|
|
||||||
@defmodulelang[marketplace]
|
@defmodulelang[marketplace]
|
||||||
|
@ -29,32 +33,44 @@ actions spawn application processes and nested VMs, which in turn
|
||||||
subscribe to sources of events from the outside world.
|
subscribe to sources of events from the outside world.
|
||||||
|
|
||||||
At present, there's just @tt{#lang marketplace}. In future, there will
|
At present, there's just @tt{#lang marketplace}. In future, there will
|
||||||
be languages providing greater support for flow control,
|
be a variation for Typed Racket, and languages providing greater
|
||||||
responsibility transfer, and other networking concepts.
|
support for flow control, responsibility transfer, and other
|
||||||
|
networking concepts. For now, Typed Racket programs must be written as
|
||||||
|
@tt{#lang typed/racket} programs using @racket[(require marketplace)]
|
||||||
|
and @racket[ground-vm:] explicitly.
|
||||||
|
|
||||||
@;{
|
@;{
|
||||||
@itemlist[
|
@itemlist[
|
||||||
|
|
||||||
@item{@racket[marketplace] is for ordinary Racket programs, and uses
|
@item{@racket[marketplace] is for @emph{untyped} programs, and uses
|
||||||
the @secref{tcp-bare} TCP driver;}
|
the @secref{tcp-bare} TCP driver;}
|
||||||
|
|
||||||
@item{@racket[marketplace/flow-control] is like
|
@item{@racket[marketplace/flow-control] is like
|
||||||
@racket[marketplace], but uses the flow-controlled @secref{tcp}
|
@racket[marketplace], but uses the flow-controlled @secref{tcp}
|
||||||
driver;}
|
driver;}
|
||||||
|
|
||||||
|
@item{@racket[marketplace/typed] is like @racket[marketplace], but
|
||||||
|
for @emph{typed} programs;}
|
||||||
|
|
||||||
|
@item{@racket[marketplace/typed/flow-control] is like
|
||||||
|
@racket[marketplace/flow-control], but for typed programs.}
|
||||||
|
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
|
|
||||||
@section{Using Marketplace as a library}
|
@section{Using Marketplace as a library}
|
||||||
|
|
||||||
@defmodule*[(marketplace/sugar)
|
@defmodule*[(marketplace/sugar-untyped
|
||||||
#:use-sources (marketplace/sugar)]
|
marketplace/sugar-typed)
|
||||||
|
#: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
|
||||||
directly.
|
directly.
|
||||||
|
|
||||||
Such programs need to use @racket[ground-vm] to
|
Such programs need to use @racket[ground-vm]/@racket[ground-vm:] to
|
||||||
start the ground-level VM explicitly. They also need to explicitly
|
start the ground-level VM explicitly. They also need to explicitly
|
||||||
start any drivers they need; for example, the file
|
start any drivers they need; for example, the file
|
||||||
@filepath{examples/echo-plain.rkt} uses @racket[ground-vm] along with
|
@filepath{examples/echo-plain.rkt} uses @racket[ground-vm] along with
|
||||||
|
@ -67,48 +83,65 @@ start any drivers they need; for example, the file
|
||||||
(on-presence (spawn (echoer from to))))))
|
(on-presence (spawn (echoer from to))))))
|
||||||
]
|
]
|
||||||
|
|
||||||
@defform[(ground-vm maybe-boot-pid-binding maybe-initial-state initial-action ...)
|
@deftogether[(
|
||||||
|
@defform[(ground-vm maybe-boot-pid-binding maybe-initial-state initial-action ...)]
|
||||||
|
@defform[(ground-vm: maybe-boot-pid-binding maybe-typed-initial-state initial-action ...)
|
||||||
#:grammar
|
#:grammar
|
||||||
[(maybe-boot-pid-binding (code:line)
|
[(maybe-boot-pid-binding (code:line)
|
||||||
(code:line #:boot-pid id))
|
(code:line #:boot-pid id))
|
||||||
(maybe-initial-state (code:line)
|
(maybe-initial-state (code:line)
|
||||||
(code:line #:initial-state expr))
|
(code:line #:initial-state expr))
|
||||||
(initial-action expr)]]{
|
(maybe-typed-initial-state (code:line)
|
||||||
|
(code:line #:initial-state expr : type))
|
||||||
|
(initial-action expr)]]
|
||||||
|
)]{
|
||||||
|
|
||||||
Starts the ground VM. If @racket[#:boot-pid] is specified, the given
|
Starts the ground VM, in untyped and typed programs, respectively. If
|
||||||
identifier is bound within the form to the PID of the @emph{primordial
|
@racket[#:boot-pid] is specified, the given identifier is bound within
|
||||||
process} that performs the initial actions. If
|
the form to the PID of the @emph{primordial process} that performs the
|
||||||
@racket[#:initial-state] is specified, it is used as the initial state
|
initial actions. If @racket[#:initial-state] is specified (with a
|
||||||
for the primordial process; if it is not supplied, the primordial
|
type, for @racket[ground-vm:]), it is used as the initial state for
|
||||||
process is given @racket[(void)] as its initial state.
|
the primordial process; if it is not supplied, the primordial process
|
||||||
|
is given @racket[(void)] as its initial state (and @racket[Void] as
|
||||||
|
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)]
|
marketplace/sugar-values
|
||||||
|
marketplace/sugar-untyped
|
||||||
|
marketplace/sugar-typed)]
|
||||||
|
|
||||||
@deftogether[(
|
@deftogether[(
|
||||||
@defform[(transition new-state action-tree ...)]
|
@defform[(transition new-state action-tree ...)]
|
||||||
|
@defform[(transition: new-state : State action-tree ...)]
|
||||||
@defform[(transition/no-state action-tree ...)]
|
@defform[(transition/no-state action-tree ...)]
|
||||||
)]{
|
)]{
|
||||||
|
|
||||||
Each of these forms produces a @racket[transition] structure.
|
Each of these forms produces a @racket[Transition] structure. The
|
||||||
|
first is for untyped code, the second for typed code (where the
|
||||||
|
mandatory @racket[State] is the type of the transitioning process's
|
||||||
|
private state), and the third for either.
|
||||||
|
|
||||||
Each @racket[action-tree] must be an @tech{action tree}.
|
Each @racket[action-tree] must be an @racket[(ActionTree State)].
|
||||||
It's fine to include @emph{no} action trees, in which case the
|
|
||||||
|
It's fine to include @emph{no} action-trees, in which case the
|
||||||
transition merely updates the state of the process without taking any
|
transition merely updates the state of the process without taking any
|
||||||
actions.
|
actions.
|
||||||
|
|
||||||
In the case of @racket[transition/no-state], the value @racket[(void)]
|
In the case of @racket[transition/no-state], the type @racket[Void]
|
||||||
is used for the process state. @racket[transition/no-state] is useful
|
and value @racket[(void)] is used for the process state.
|
||||||
for processes that are stateless other than the implicit state of
|
@racket[transition/no-state] is useful for processes that are
|
||||||
their endpoints.
|
stateless other than the implicit state of their endpoints.
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
@defstruct*[transition ([state State] [actions action-tree?]) #:transparent]{
|
@deftogether[(
|
||||||
|
@defstruct*[transition ([state State] [actions (ActionTree State)]) #:transparent]
|
||||||
|
@deftype[(Transition State) (transition State)]
|
||||||
|
)]{
|
||||||
|
|
||||||
A transition structure. The @racket[transition-state] field is the new
|
A transition structure. The @racket[transition-state] field is the new
|
||||||
private state the process will have after the transition is applied,
|
private state the process will have after the transition is applied,
|
||||||
|
@ -117,23 +150,16 @@ performed by the VM in order to apply the transition.
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
@defproc[(action-tree? [value any/c]) boolean?]{
|
@deftogether[(
|
||||||
|
@deftype[(ActionTree State) (Constreeof (Action State))]
|
||||||
|
@deftype[(Constreeof X) (Rec CT (U X (Pairof CT CT) False Void Null))]
|
||||||
|
)]{
|
||||||
|
|
||||||
Predicate that recognises an @deftech{action tree}. An action tree is
|
An action-tree is a @deftech{cons-tree} of @racket[Action]s. When
|
||||||
either
|
performing actions, a VM will traverse an action-tree in left-to-right
|
||||||
|
order.
|
||||||
|
|
||||||
@itemlist[
|
@racket['()], @racket[(void)], and @racket[#f] may also be present in
|
||||||
@item{@racket['()];}
|
|
||||||
@item{@racket[#f];}
|
|
||||||
@item{@racket[(void)];}
|
|
||||||
@item{a pair of action trees; or}
|
|
||||||
@item{an @tech{action}.}
|
|
||||||
]
|
|
||||||
|
|
||||||
When performing actions, a VM will traverse an action-tree in
|
|
||||||
left-to-right order.
|
|
||||||
|
|
||||||
@racket['()], @racket[(void)], and @racket[#f] may be present in
|
|
||||||
action-trees: when the VM reaches such a value, it ignores it and
|
action-trees: when the VM reaches such a value, it ignores it and
|
||||||
continues with the next leaf in the tree.
|
continues with the next leaf in the tree.
|
||||||
|
|
||||||
|
@ -175,9 +201,10 @@ at all" in a transition:
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
@defproc[(sequence-actions [initial-transition transition?]
|
@defproc[(sequence-actions [initial-transition (Transition State)]
|
||||||
[item (or/c action-tree? (any/c -> transition?))]
|
[item (U (ActionTree State)
|
||||||
...) transition?]{
|
(State -> (Transition State)))]
|
||||||
|
...) (Transition State)]{
|
||||||
|
|
||||||
Returns a transition formed from the @racket[initial-transition]
|
Returns a transition formed from the @racket[initial-transition]
|
||||||
extended with new actions, possibly updating its carried state. Each
|
extended with new actions, possibly updating its carried state. Each
|
||||||
|
@ -218,30 +245,44 @@ collection of macros helps streamline endpoint setup.
|
||||||
|
|
||||||
@deftogether[(
|
@deftogether[(
|
||||||
@defform[(publisher topic handler ...)]
|
@defform[(publisher topic handler ...)]
|
||||||
|
@defform[(publisher: State topic handler ...)]
|
||||||
@defform[(subscriber topic handler ...)]
|
@defform[(subscriber topic handler ...)]
|
||||||
|
@defform[(subscriber: State topic handler ...)]
|
||||||
@defform[(observe-subscribers topic handler ...)]
|
@defform[(observe-subscribers topic handler ...)]
|
||||||
|
@defform[(observe-subscribers: State topic handler ...)]
|
||||||
@defform[(observe-publishers topic handler ...)]
|
@defform[(observe-publishers topic handler ...)]
|
||||||
|
@defform[(observe-publishers: State topic handler ...)]
|
||||||
@defform[(observe-subscribers/everything topic handler ...)]
|
@defform[(observe-subscribers/everything topic handler ...)]
|
||||||
|
@defform[(observe-subscribers/everything: State topic handler ...)]
|
||||||
@defform[(observe-publishers/everything topic handler ...)]
|
@defform[(observe-publishers/everything topic handler ...)]
|
||||||
|
@defform[(observe-publishers/everything: State topic handler ...)]
|
||||||
@defform[(build-endpoint pre-eid role handler ...)]
|
@defform[(build-endpoint pre-eid role handler ...)]
|
||||||
|
@defform[(build-endpoint: State pre-eid role handler ...)]
|
||||||
)]{
|
)]{
|
||||||
|
|
||||||
The many variations on the core
|
The many variations on the core
|
||||||
@racket[build-endpoint] form exist to give
|
@racket[build-endpoint]/@racket[build-endpoint:] form exist to give
|
||||||
good control over @racket[InterestType] in the endpoint under
|
good control over @racket[InterestType] in the endpoint under
|
||||||
construction;
|
construction;
|
||||||
see @secref{participating-vs-observing}.
|
see @secref{participating-vs-observing}.
|
||||||
|
|
||||||
Almost everything is optional in an endpoint definition. The only
|
Almost everything is optional in an endpoint definition. The only
|
||||||
mandatory part is the topic.
|
mandatory part is the topic, unless you're using Typed Racket, in
|
||||||
|
which case the process state type must also be specified.
|
||||||
|
|
||||||
For example, a minimal endpoint subscribing to all messages would be:
|
For example, a minimal endpoint subscribing to all messages would be:
|
||||||
|
|
||||||
@racketblock[(subscriber ?)]
|
@racketblock[(subscriber ?)]
|
||||||
|
|
||||||
|
or in Typed Racket, for a process with @racket[Integer] as its process
|
||||||
|
state type,
|
||||||
|
|
||||||
|
@racketblock[(subscriber: Integer ?)]
|
||||||
|
|
||||||
A minimal publishing endpoint would be:
|
A minimal publishing endpoint would be:
|
||||||
|
|
||||||
@racketblock[(publisher ?)]
|
@racketblock[(publisher ?)
|
||||||
|
(publisher: Integer ?)]
|
||||||
|
|
||||||
While topic patterns are ordinary Racket data with embedded @racket[?]
|
While topic patterns are ordinary Racket data with embedded @racket[?]
|
||||||
wildcards (see @secref{messages-and-topics}), all the other patterns
|
wildcards (see @secref{messages-and-topics}), all the other patterns
|
||||||
|
@ -279,7 +320,7 @@ the wrapped handlers are expected to return
|
||||||
@seclink["constructing-transitions"]{transition structures}.
|
@seclink["constructing-transitions"]{transition structures}.
|
||||||
|
|
||||||
If not, however, the handler expressions are expected to return plain
|
If not, however, the handler expressions are expected to return plain
|
||||||
@tech{action tree}s.
|
@racket[ActionTree]s.
|
||||||
|
|
||||||
This way, simple handlers that do not need to examine the process
|
This way, simple handlers that do not need to examine the process
|
||||||
state, and simply act in response to whichever event triggered them,
|
state, and simply act in response to whichever event triggered them,
|
||||||
|
@ -442,8 +483,9 @@ dynamically:
|
||||||
|
|
||||||
@itemlist[
|
@itemlist[
|
||||||
|
|
||||||
@item{@racket[publisher] and @racket[subscriber] are for ordinary
|
@item{@racket[publisher] and @racket[subscriber] (and typed
|
||||||
@emph{participation} in conversations;}
|
variations ending in @tt{:}) are for ordinary @emph{participation} in
|
||||||
|
conversations;}
|
||||||
|
|
||||||
@item{@racket[observe-subscribers] and @racket[observe-publishers]
|
@item{@racket[observe-subscribers] and @racket[observe-publishers]
|
||||||
are for @emph{observing} conversations without participating in them; and}
|
are for @emph{observing} conversations without participating in them; and}
|
||||||
|
@ -468,7 +510,7 @@ but as an observer, the code should declare the roles being observed.
|
||||||
Endpoint names can be used to @seclink["updating-endpoints"]{update}
|
Endpoint names can be used to @seclink["updating-endpoints"]{update}
|
||||||
or @seclink["deleting-endpoints"]{delete} endpoints.
|
or @seclink["deleting-endpoints"]{delete} endpoints.
|
||||||
|
|
||||||
@defproc[(name-endpoint [id any/c] [add-endpoint-action AddEndpoint]) AddEndpoint]{
|
@defproc[(name-endpoint [id Any] [add-endpoint-action AddEndpoint]) AddEndpoint]{
|
||||||
|
|
||||||
Returns a copy of the passed-in @racket[add-endpoint] action
|
Returns a copy of the passed-in @racket[add-endpoint] action
|
||||||
structure, with the @racket[id] field set to the passed-in identifying
|
structure, with the @racket[id] field set to the passed-in identifying
|
||||||
|
@ -530,7 +572,15 @@ Equivalent to @racket[(send-message body 'subscriber)].
|
||||||
@defform[(spawn maybe-pid-binding boot-expr)]
|
@defform[(spawn maybe-pid-binding boot-expr)]
|
||||||
@defform[(spawn/continue maybe-pid-binding
|
@defform[(spawn/continue maybe-pid-binding
|
||||||
#:parent parent-state-pattern k-expr
|
#:parent parent-state-pattern k-expr
|
||||||
#:child boot-expr)
|
#:child boot-expr)]
|
||||||
|
@defform[#:literals (:)
|
||||||
|
(spawn: maybe-pid-binding
|
||||||
|
#:parent : ParentStateType
|
||||||
|
#:child : ChildStateType boot-expr)]
|
||||||
|
@defform[#:literals (:)
|
||||||
|
(spawn/continue: maybe-pid-binding
|
||||||
|
#:parent parent-state-pattern : ParentStateType k-expr
|
||||||
|
#:child : ChildStateType boot-expr)
|
||||||
#:grammar
|
#:grammar
|
||||||
[(maybe-pid-binding (code:line)
|
[(maybe-pid-binding (code:line)
|
||||||
(code:line #:pid identifier))
|
(code:line #:pid identifier))
|
||||||
|
@ -546,11 +596,15 @@ If @racket[#:pid] is supplied, the associated identifier is bound to
|
||||||
the child process's PID in both @racket[boot-expr] and the parent's
|
the child process's PID in both @racket[boot-expr] and the parent's
|
||||||
@racket[k-expr].
|
@racket[k-expr].
|
||||||
|
|
||||||
The @racket[spawn/continue] variation includes a @racket[k-expr],
|
The @racket[spawn/continue] and @racket[spawn/continue:] variations
|
||||||
which will run in the parent process after the child process has been
|
include a @racket[k-expr], which will run in the parent process after
|
||||||
created. Note that @racket[k-expr] must return a @racket[transition],
|
the child process has been created. Note that @racket[k-expr] must
|
||||||
since @racket[parent-state-pattern] is always supplied for these
|
return a @racket[Transition], since @racket[parent-state-pattern] is
|
||||||
variations.
|
always supplied for these variations.
|
||||||
|
|
||||||
|
In Typed Racket, for type system reasons, @racket[spawn:] and
|
||||||
|
@racket[spawn/continue:] require @racket[ParentStateType] to be
|
||||||
|
supplied as well as @racket[ChildStateType].
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -587,7 +641,11 @@ itself.
|
||||||
|
|
||||||
@section{Cooperative scheduling}
|
@section{Cooperative scheduling}
|
||||||
|
|
||||||
@defform[(yield state-pattern k-expr)]{
|
@deftogether[(
|
||||||
|
@defform[(yield state-pattern k-expr)]
|
||||||
|
@defform[#:literals (:)
|
||||||
|
(yield: state-pattern : State k-expr)]
|
||||||
|
)]{
|
||||||
|
|
||||||
Lets other processes in the system run for a step, returning to
|
Lets other processes in the system run for a step, returning to
|
||||||
evaluate @racket[k-expr] only after doing a complete round of the
|
evaluate @racket[k-expr] only after doing a complete round of the
|
||||||
|
@ -595,15 +653,22 @@ scheduler.
|
||||||
|
|
||||||
The state of the yielding process will be matched against
|
The state of the yielding process will be matched against
|
||||||
@racket[state-pattern] when the process is resumed, and
|
@racket[state-pattern] when the process is resumed, and
|
||||||
@racket[k-expr] must evaluate to a @racket[transition].
|
@racket[k-expr] must evaluate to a @racket[Transition].
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
@section{Creating nested VMs}
|
@section{Creating nested VMs}
|
||||||
|
|
||||||
|
@deftogether[(
|
||||||
@defform[(spawn-vm maybe-vm-pid-binding maybe-boot-pid-binding
|
@defform[(spawn-vm maybe-vm-pid-binding maybe-boot-pid-binding
|
||||||
maybe-initial-state
|
maybe-initial-state
|
||||||
maybe-debug-name
|
maybe-debug-name
|
||||||
|
boot-action-expr ...)]
|
||||||
|
@defform[#:literals (:)
|
||||||
|
(spawn-vm: : ParentStateType
|
||||||
|
maybe-vm-pid-binding maybe-boot-pid-binding
|
||||||
|
maybe-typed-initial-state
|
||||||
|
maybe-debug-name
|
||||||
boot-action-expr ...)
|
boot-action-expr ...)
|
||||||
#:grammar
|
#:grammar
|
||||||
[(maybe-vm-pid-binding (code:line)
|
[(maybe-vm-pid-binding (code:line)
|
||||||
|
@ -612,9 +677,12 @@ The state of the yielding process will be matched against
|
||||||
(code:line #:boot-pid identifier))
|
(code:line #:boot-pid identifier))
|
||||||
(maybe-initial-state (code:line)
|
(maybe-initial-state (code:line)
|
||||||
(code:line #:initial-state expr))
|
(code:line #:initial-state expr))
|
||||||
|
(maybe-typed-initial-state (code:line)
|
||||||
|
(code:line #:initial-state expr : StateType))
|
||||||
(maybe-debug-name (code:line)
|
(maybe-debug-name (code:line)
|
||||||
(code:line #:debug-name expr))
|
(code:line #:debug-name expr))
|
||||||
(boot-action-expr expr)]]{
|
(boot-action-expr expr)]]
|
||||||
|
)]{
|
||||||
|
|
||||||
Results in a @racket[spawn] action that starts a nested VM. The
|
Results in a @racket[spawn] action that starts a nested VM. The
|
||||||
primordial process in the new VM executes the boot-actions with the
|
primordial process in the new VM executes the boot-actions with the
|
||||||
|
@ -631,7 +699,10 @@ primordial process in the new VM.
|
||||||
|
|
||||||
@section{Relaying across layers}
|
@section{Relaying across layers}
|
||||||
|
|
||||||
@defproc[(at-meta-level [preaction (PreAction State)] ...) (Action StateType)]{
|
@deftogether[(
|
||||||
|
@defform[(at-meta-level: StateType preaction ...)]
|
||||||
|
@defproc[(at-meta-level [preaction (PreAction State)] ...) (Action StateType)]
|
||||||
|
)]{
|
||||||
|
|
||||||
Each VM gives its processes access to two distinct IPC facilities: the
|
Each VM gives its processes access to two distinct IPC facilities: the
|
||||||
@emph{internal} one, provided for the VM's processes to talk amongst
|
@emph{internal} one, provided for the VM's processes to talk amongst
|
||||||
|
@ -640,9 +711,9 @@ itself is a process within.
|
||||||
|
|
||||||
Marketplace's actions can apply to either of those two networks. By
|
Marketplace's actions can apply to either of those two networks. By
|
||||||
default, actions apply to the VM of the acting process directly, but
|
default, actions apply to the VM of the acting process directly, but
|
||||||
using @racket[at-meta-level] to wrap an action @emph{level-shifts} the
|
using @racket[at-meta-level] (or @racket[at-meta-level:] in typed
|
||||||
action to make it apply at the level of the acting process's VM's
|
code) to wrap an action @emph{level-shifts} the action to make it
|
||||||
container instead.
|
apply at the level of the acting process's VM's container instead.
|
||||||
|
|
||||||
For example, wrapping an @racket[endpoint] in @racket[at-meta-level]
|
For example, wrapping an @racket[endpoint] in @racket[at-meta-level]
|
||||||
adds a subscription to the VM's container's network. Instead of
|
adds a subscription to the VM's container's network. Instead of
|
||||||
|
|
|
@ -20,7 +20,7 @@ interface} of a Unix-like operating system.
|
||||||
|
|
||||||
Each @deftech{handler function} is always associated with a particular
|
Each @deftech{handler function} is always associated with a particular
|
||||||
@tech{endpoint}, registered with the VM via
|
@tech{endpoint}, registered with the VM via
|
||||||
@racket[endpoint]/@racket[add-endpoint]. A handler
|
@racket[endpoint]/@racket[endpoint:]/@racket[add-endpoint]. A handler
|
||||||
function for a given process with state type @racket[State] has type:
|
function for a given process with state type @racket[State] has type:
|
||||||
|
|
||||||
@racketblock[(EndpointEvent -> State -> (Transition State))]
|
@racketblock[(EndpointEvent -> State -> (Transition State))]
|
||||||
|
@ -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
|
@declare-exporting[marketplace marketplace/sugar-untyped marketplace/sugar-typed
|
||||||
#:use-sources (marketplace marketplace/sugar)]
|
#:use-sources (marketplace marketplace/sugar-untyped marketplace/sugar-typed)]
|
||||||
|
|
||||||
@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]{@racket[delete-endpoint]}
|
convenience @from[marketplace/sugar-values]{@racket[delete-endpoint]}
|
||||||
function from @racket[marketplace/sugar].
|
function from @racket[marketplace/sugar-values].
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -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]{See also the @racket[send-message] and
|
@from[marketplace/sugar-values]{See also the @racket[send-message] and
|
||||||
@racket[send-feedback] convenience functions from
|
@racket[send-feedback] convenience functions from
|
||||||
@racket[marketplace/sugar].}
|
@racket[marketplace/sugar-values].}
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -4,7 +4,10 @@
|
||||||
|
|
||||||
@require[(for-label marketplace/support/spy
|
@require[(for-label marketplace/support/spy
|
||||||
marketplace/support/debug
|
marketplace/support/debug
|
||||||
marketplace/log)]
|
marketplace/log-untyped
|
||||||
|
(except-in marketplace/log-typed
|
||||||
|
marketplace-log
|
||||||
|
marketplace-root-logger))]
|
||||||
|
|
||||||
@title{Management and Monitoring}
|
@title{Management and Monitoring}
|
||||||
|
|
||||||
|
@ -28,7 +31,8 @@ each @racket['publisher] message sent to the VM's network.
|
||||||
|
|
||||||
@section[#:tag "logging"]{logging (MARKETPLACE_LOG)}
|
@section[#:tag "logging"]{logging (MARKETPLACE_LOG)}
|
||||||
|
|
||||||
@defmodule*[(marketplace/log)]{
|
@defmodule*[(marketplace/log-untyped
|
||||||
|
marketplace/log-typed)]{
|
||||||
|
|
||||||
@defform[#:kind "environment variable" #:id MARKETPLACE_LOG MARKETPLACE_LOG]{
|
@defform[#:kind "environment variable" #:id MARKETPLACE_LOG MARKETPLACE_LOG]{
|
||||||
|
|
||||||
|
|
|
@ -12,7 +12,21 @@
|
||||||
(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)
|
||||||
marketplace/sugar))
|
(except-in marketplace/sugar-untyped
|
||||||
|
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
96
structs.rkt
|
@ -1,96 +0,0 @@
|
||||||
#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:
|
|
|
@ -0,0 +1,21 @@
|
||||||
|
#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])
|
|
@ -0,0 +1,247 @@
|
||||||
|
#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:
|
|
@ -4,27 +4,12 @@
|
||||||
(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")
|
|
||||||
|
|
||||||
(provide (all-from-out "main.rkt")
|
(require "sugar-endpoints-support.rkt")
|
||||||
|
|
||||||
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
|
||||||
|
@ -33,71 +18,7 @@
|
||||||
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
|
||||||
|
@ -294,88 +215,7 @@
|
||||||
(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)
|
|
@ -0,0 +1,133 @@
|
||||||
|
#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:
|
|
@ -0,0 +1,113 @@
|
||||||
|
#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:
|
|
@ -0,0 +1,80 @@
|
||||||
|
#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:
|
|
@ -1,56 +1,60 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
|
||||||
(require (prefix-in core: "../main.rkt"))
|
(require (prefix-in core: "../main.rkt"))
|
||||||
(require "../sugar.rkt")
|
(require "../sugar-typed.rkt")
|
||||||
(require "../vm.rkt")
|
(require "../vm.rkt")
|
||||||
(require "../process.rkt")
|
(require "../process.rkt")
|
||||||
(require "../quasiqueue.rkt")
|
(require "../quasiqueue.rkt")
|
||||||
|
|
||||||
(require "gui.rkt")
|
(require/typed "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
|
||||||
(core:process-spec
|
(process-spec
|
||||||
(lambda (pid) ;; TODO: exploit this more in messages etc.
|
(lambda: ([pid : PID]) ;; TODO: exploit this more in messages etc.
|
||||||
(define original-cotransition ((core:process-spec-boot child-spec) pid))
|
(define original-cotransition ((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))
|
||||||
(k (wrap-transition d child-transition)))
|
((inst k S) (wrap-transition d child-transition)))
|
||||||
(original-cotransition receiver))
|
((inst original-cotransition R) 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 (d child-transition0))
|
(define child-transition ((inst d (Transition ChildState)) 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 (action-tree-map (wrap-action d)
|
(core:transition child-state ((inst action-tree-map ChildState)
|
||||||
|
(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)
|
||||||
(map f (quasiqueue->list (action-tree->quasiqueue actions))))
|
((inst map (Action State) (Action State))
|
||||||
|
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)
|
||||||
|
@ -60,11 +64,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)
|
||||||
|
@ -78,28 +82,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) (wrap-interruptk d (maybe-k child-pid)))))
|
(lambda: ([child-pid : 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) (d (cons meta?0 event0)))
|
(match-define (cons meta? event) ((inst d (Pairof Boolean EndpointEvent)) (cons meta?0 event0)))
|
||||||
(wrap-interruptk d (h event))))
|
(wrap-interruptk d (h event))))
|
||||||
|
|
|
@ -0,0 +1,7 @@
|
||||||
|
#lang typed/racket/base
|
||||||
|
|
||||||
|
(require/typed typed/racket/base
|
||||||
|
[opaque Evt evt?])
|
||||||
|
|
||||||
|
(provide Evt
|
||||||
|
evt?)
|
|
@ -19,7 +19,7 @@
|
||||||
|
|
||||||
(require racket/pretty)
|
(require racket/pretty)
|
||||||
|
|
||||||
(require (prefix-in core: "../structs.rkt")
|
(require (prefix-in core: "../types.rkt")
|
||||||
(prefix-in core: "../vm.rkt"))
|
(prefix-in core: "../vm.rkt"))
|
||||||
|
|
||||||
(provide open-debugger)
|
(provide open-debugger)
|
||||||
|
@ -55,9 +55,20 @@
|
||||||
[name name]
|
[name name]
|
||||||
[from-vm to-debugger]
|
[from-vm to-debugger]
|
||||||
[to-vm from-debugger]))
|
[to-vm from-debugger]))
|
||||||
|
(wrap/unwrapper
|
||||||
(lambda (v)
|
(lambda (v)
|
||||||
(channel-put to-debugger v)
|
(channel-put to-debugger v)
|
||||||
(channel-get from-debugger)))
|
(channel-get from-debugger))))
|
||||||
|
|
||||||
|
;; This is utterly vile.
|
||||||
|
(define (wrap/unwrapper thunk)
|
||||||
|
(local-require racket/unsafe/ops)
|
||||||
|
(lambda (wrapped-val)
|
||||||
|
;; (pretty-print `(wrapped-val ,wrapped-val))
|
||||||
|
(define inner (unsafe-struct-ref wrapped-val 0))
|
||||||
|
;; (pretty-print `(inner ,inner))
|
||||||
|
(unsafe-struct-set! wrapped-val 0 (thunk inner))
|
||||||
|
wrapped-val))
|
||||||
|
|
||||||
(define sane-tab-panel%
|
(define sane-tab-panel%
|
||||||
(class tab-panel%
|
(class tab-panel%
|
||||||
|
@ -70,13 +81,6 @@
|
||||||
(if h-stretch? width min-w)
|
(if h-stretch? width min-w)
|
||||||
(if v-stretch? height min-h))))))
|
(if v-stretch? height min-h))))))
|
||||||
|
|
||||||
(define (string->label-string s)
|
|
||||||
;; Per documentation for (label-string?), a label string "is a
|
|
||||||
;; string whose length is less than or equal to 200."
|
|
||||||
(if (> (string-length s) 200)
|
|
||||||
(string-append (substring s 0 196) " ...")
|
|
||||||
s))
|
|
||||||
|
|
||||||
(define debugger%
|
(define debugger%
|
||||||
(class object%
|
(class object%
|
||||||
|
|
||||||
|
@ -303,7 +307,7 @@
|
||||||
(send events set-data n current-historical-moment)
|
(send events set-data n current-historical-moment)
|
||||||
(send events set-string n dir 1)
|
(send events set-string n dir 1)
|
||||||
(send events set-string n type 2)
|
(send events set-string n type 2)
|
||||||
(send events set-string n (string->label-string (~a detail)) 3)
|
(send events set-string n (~a detail) 3)
|
||||||
(define current-selection (send events get-selection))
|
(define current-selection (send events get-selection))
|
||||||
(when (or (not current-selection) (= current-selection (- n 1)))
|
(when (or (not current-selection) (= current-selection (- n 1)))
|
||||||
(send events set-first-visible-item n)
|
(send events set-first-visible-item n)
|
||||||
|
|
|
@ -0,0 +1,18 @@
|
||||||
|
#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 (... ...))])))))
|
|
@ -1,14 +1,16 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
|
|
||||||
(require "../sugar.rkt")
|
(require "../sugar-typed.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 (transition (void)
|
(spawn: #:parent : ParentState
|
||||||
(observe-publishers (wild)
|
#:child : Void
|
||||||
|
(transition: (void) : Void
|
||||||
|
(observe-publishers: Void (wild)
|
||||||
(match-orientation orientation
|
(match-orientation orientation
|
||||||
(match-conversation topic
|
(match-conversation topic
|
||||||
(match-interest-type interest
|
(match-interest-type interest
|
||||||
|
|
|
@ -0,0 +1,12 @@
|
||||||
|
#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))
|
|
@ -0,0 +1,166 @@
|
||||||
|
#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)))))))])))
|
|
@ -0,0 +1,119 @@
|
||||||
|
#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:
|
109
vm.rkt
109
vm.rkt
|
@ -1,18 +1,22 @@
|
||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "structs.rkt")
|
(require "types.rkt")
|
||||||
(require "roles.rkt")
|
(require "roles.rkt")
|
||||||
(require "quasiqueue.rkt")
|
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
|
||||||
|
|
||||||
(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
|
vm ;; really just want to export the type here, not the ctor
|
||||||
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
|
||||||
|
@ -22,53 +26,79 @@
|
||||||
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 process (debug-name ;; Any
|
(struct: (State)
|
||||||
pid ;; PID
|
process ([debug-name : Any]
|
||||||
state ;; State
|
[pid : PID]
|
||||||
spawn-ks ;; (Listof (Pairof Integer (TrapK PID State))) ;; hmm
|
[state : State]
|
||||||
endpoints ;; (HashTable PreEID (endpoint State))
|
[spawn-ks : (Listof (Pairof Integer (TrapK PID State)))] ;; hmm
|
||||||
meta-endpoints ;; (HashTable PreEID (endpoint State))
|
[endpoints : (HashTable PreEID (endpoint State))]
|
||||||
pending-actions ;; (QuasiQueue (Action State))
|
[meta-endpoints : (HashTable PreEID (endpoint State))]
|
||||||
)
|
[pending-actions : (QuasiQueue (Action State))])
|
||||||
#:transparent)
|
#:transparent)
|
||||||
|
|
||||||
(struct endpoint (id ;; eid
|
(struct: (State)
|
||||||
role ;; role
|
endpoint ([id : eid]
|
||||||
handler ;; (Handler State)
|
[role : role]
|
||||||
)
|
[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 (process '#:primordial
|
(define primordial (mkProcess ((inst process Void)
|
||||||
|
'#: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
|
||||||
|
@ -76,28 +106,29 @@
|
||||||
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 (empty-quasiqueue)]))
|
(struct-copy process p [pending-actions ((inst empty-quasiqueue (Action State)))]))
|
||||||
|
|
||||||
;; 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
|
||||||
(inject-process state (f wp))))))
|
(unwrap-process State vm (p 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
|
||||||
(for/fold ([seed seed]) ([pre-eid (in-hash-keys (process-endpoints wp))])
|
(unwrap-process State A (p wp)
|
||||||
(define ep (hash-ref (process-endpoints wp) pre-eid))
|
(for/fold ([seed seed]) ([pre-eid (in-hash-keys (process-endpoints p))])
|
||||||
(f wp ep seed))))))
|
(define ep (hash-ref (process-endpoints p) pre-eid))
|
||||||
|
((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)
|
||||||
|
|
Loading…
Reference in New Issue