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

Compare commits

merge into: syndicate-lang:typeless
Branches Tags
syndicate-lang:typeless
syndicate-lang:pr/10
syndicate-lang:typed
syndicate-lang:pr/8
syndicate-lang:pr/7
syndicate-lang:custom-edge-profile
syndicate-lang:gh-pages
syndicate-lang:pr/4
syndicate-lang:pr/1
syndicate-lang:pre_extrasugar
syndicate-lang:pre_newdev_201304
syndicate-lang:icfp2013_submission
...
pull from: syndicate-lang:gh-pages
Branches Tags
syndicate-lang:pr/10
syndicate-lang:typeless
syndicate-lang:typed
syndicate-lang:pr/8
syndicate-lang:pr/7
syndicate-lang:custom-edge-profile
syndicate-lang:gh-pages
syndicate-lang:pr/4
syndicate-lang:pr/1
syndicate-lang:pre_extrasugar
syndicate-lang:pre_newdev_201304
syndicate-lang:icfp2013_submission

No commits in common. "typeless" and "gh-pages" have entirely different histories.
typeless ... gh-pages

77 changed files with 2797 additions and 6049 deletions
Show Stats Expand all files Collapse all files

3
.gitignore vendored
View File

@ -1,3 +0,0 @@
compiled/
doc/
scratch/

103
Concepts.html Normal file
View File

File diff suppressed because one or more lines are too long

49
Drivers.html Normal file
View File

File diff suppressed because one or more lines are too long

17
Examples.html Normal file
View File

File diff suppressed because one or more lines are too long

13
Makefile
View File

@ -1,13 +0,0 @@
all: setup
clean:
find . -name compiled -type d | xargs rm -rf
setup:
raco setup $$(basename $$(pwd))
link:
raco pkg install --link $$(pwd)
unlink:
raco pkg remove $$(basename $$(pwd))

21
Management_and_Monitoring.html Normal file
View File

File diff suppressed because one or more lines are too long

79
README.md
View File

@ -1,79 +0,0 @@
# Marketplace: Bringing the Network into the Programming Language
Marketplace is a concurrent language able to express communication,
enforce isolation, and manage resources. Network-inspired extensions
to a functional core represent imperative actions as values, giving
side-effects locality and enabling composition of communicating
processes.
Collaborating programs are grouped within task-specific *virtual
machines* (VMs) to scope their interactions. Conversations between
programs are multi-party (using a publish/subscribe medium), and
programs can easily participate in many such conversations at once.
Marketplace makes *presence* notifications an integral part of
pub/sub. Programs react to presence and absence notifications that
report the comings and goings of their peers. Presence serves to
communicate changes in demand for and supply of services, both within
a VM and across *nested VM layers*. Programs can give up
responsibility for maintaining presence information and for scoping
group communications to their containing VM.
## Documentation
A (draft) manual for Marketplace is available
[here](http://tonyg.github.io/marketplace/).
## The code
This repository contains a [Racket](http://racket-lang.org/) package,
`marketplace`, which includes
- the implementation of the `#lang marketplace` language, in the
[top directory](https://github.com/tonyg/marketplace/tree/typeless/).
- a TCP echo server example, in
[`examples/echo-paper.rkt`](https://github.com/tonyg/marketplace/tree/typeless/examples/echo-paper.rkt).
- a TCP chat server example, in
[`examples/chat-paper.rkt`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat-paper.rkt).
- 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),
[`chat.erl`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat.erl),
and
[`chat.py`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat.py)
respectively.
## Compiling and running the code
You will need Racket version 6.1.x or later.
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`
from the root directory of the Git checkout to install the package
from a local snapshot. (Alternatively, `make link` does the same thing.)
This will make `#lang marketplace` available to programs.
At this point, you may load and run any of the example `*.rkt` files
in the
[`examples/`](https://github.com/tonyg/marketplace/tree/typeless/examples/)
directory.
Note that both the echo server and chat server examples do not print
any output on standard output: instead, they simply start running and
silently await TCP connections. Once one of the servers is running, in
a separate window, try `telnet localhost 5999`.
Note also that both the echo server and the chat server use port 5999,
so you cannot run both simultaneously.
## Copyright
Copyright © Tony Garnock-Jones 2010, 2011, 2012, 2013, 2014.

40
action-add-endpoint.rkt
View File

@ -1,40 +0,0 @@
#lang racket/base
(require racket/match)
(require "structs.rkt")
(require "roles.rkt")
(require "vm.rkt")
(require "process.rkt")
(provide do-add-endpoint)
;; do-add-endpoint : (All (State) PreEID Role (Handler State) (process State) vm
;; -> (values (Option (process State)) vm))
(define (do-add-endpoint pre-eid role h p state)
(define new-eid (eid (process-pid p) pre-eid))
(define old-endpoint (hash-ref (process-endpoints p) pre-eid (lambda () #f)))
(define new-endpoint (endpoint new-eid role h))
(if old-endpoint
;; We are *updating* an existing endpoint's behaviour.
(if (roles-equal? (endpoint-role old-endpoint)
(endpoint-role new-endpoint))
(values (install-endpoint p new-endpoint)
state)
;; TODO: Make this error fatal for the process, not the VM!
(error 'do-add-endpoint
"Roles must be equal when updating an endpoint: ~v vs ~v"
old-endpoint
new-endpoint))
;; We are installing a *new* endpoint.
;; TODO: Decide whether to signal a process' endpoints about
;; *its own* matching endpoints.
(let-values (((p state) (notify-route-change-vm (install-endpoint p new-endpoint)
new-endpoint
presence-event
state)))
(values p state))))
;; install-endpoint : (All (State) (process State) (endpoint State) -> (process State))
(define (install-endpoint p ep)
(define pre-eid (eid-pre-eid (endpoint-id ep)))
(struct-copy process p [endpoints (hash-set (process-endpoints p) pre-eid ep)]))

44
action-delete-endpoint.rkt
View File

@ -1,44 +0,0 @@
#lang racket/base
(require racket/match)
(require "structs.rkt")
(require "roles.rkt")
(require "vm.rkt")
(require "process.rkt")
(require "quasiqueue.rkt")
(provide do-delete-endpoint
delete-all-endpoints)
;; do-delete-endpoint : (All (State) PreEID Reason (process State) vm
;; -> (values (process State) vm))
(define (do-delete-endpoint pre-eid reason p state)
(cond
[(hash-has-key? (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)
old-endpoint
(lambda (t) (absence-event t reason))
state)))
(values p state))]
[else
(values p state)]))
;; remove-endpoint : (All (State) (process State) (endpoint State) -> (process State))
(define (remove-endpoint p ep)
(define pre-eid (eid-pre-eid (endpoint-id ep)))
(struct-copy process p [endpoints (hash-remove (process-endpoints p) pre-eid)]))
;; delete-all-endpoints : (All (State) Reason (process State) vm
;; -> (values (process State) vm (QuasiQueue (Action vm))))
(define (delete-all-endpoints reason p state)
(let-values (((p state)
(for/fold ([p p] [state state])
([pre-eid (in-hash-keys (process-endpoints p))])
(do-delete-endpoint pre-eid reason p state))))
(values p
state
(list->quasiqueue
(map (lambda (pre-eid)
(delete-endpoint (eid (process-pid p) pre-eid) reason))
(hash-keys (process-meta-endpoints p)))))))

42
action-quit.rkt
View File

@ -1,42 +0,0 @@
#lang racket/base
(require racket/match)
(require "structs.rkt")
(require "roles.rkt")
(require "vm.rkt")
(require "log.rkt")
(require "process.rkt")
(require "action-delete-endpoint.rkt")
(require "quasiqueue.rkt")
(provide do-quit)
;; do-quit : (All (State) PID Reason (process State) vm
;; -> (values (Option (process State)) vm (QuasiQueue (Action vm))))
(define (do-quit killed-pid reason p state)
;; log-quit : (All (KilledState) (process KilledState) -> Void)
(define (log-quit p)
(marketplace-log (if reason 'warning 'info)
"PID ~v (~a) quits with reason: ~a"
killed-pid
(process-debug-name p)
(if (exn? reason)
(parameterize ([current-error-port (open-output-string)])
((error-display-handler) (exn-message reason) reason)
(get-output-string (current-error-port)))
(format "~v" reason))))
(if (equal? killed-pid (process-pid p))
(let-values (((p state meta-actions) (delete-all-endpoints reason p state)))
(log-quit p)
(values #f state meta-actions))
(let-values (((state maybe-killed-wp) (extract-process state killed-pid)))
(if (not maybe-killed-wp)
(values p state (empty-quasiqueue))
(apply values
(let ((killed-p maybe-killed-wp))
(log-quit killed-p)
(let-values (((killed-p state meta-actions)
(delete-all-endpoints reason killed-p state)))
(list p state meta-actions))))))))

30
action-send-message.rkt
View File

@ -1,30 +0,0 @@
#lang racket/base
(require racket/match)
(require "structs.rkt")
(require "roles.rkt")
(require "vm.rkt")
(require "process.rkt")
(provide do-send-message)
;; do-send-message : (All (State) Orientation Message (process State) vm ->
;; (Values (Option (process State)) vm))
(define (do-send-message orientation body sender-p state)
(define message-role (role orientation body 'participant))
;; send-to-process : (All (State) (process State) -> (process State))
(define (send-to-process p)
(define endpoints (process-endpoints p))
(for/fold ([p p]) ([eid (in-hash-keys endpoints)])
(define e (hash-ref endpoints eid))
(cond
[(role-intersection message-role (endpoint-role e))
(run-ready p (send-to-user p (e) (quit-interruptk e)
((endpoint-handler e) (message-event message-role body))))]
[else
p])))
;; for each process in state (and also for p),
(values (send-to-process sender-p)
(process-map send-to-process state)))

47
action-spawn.rkt
View File

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

214
actions.rkt
View File

@ -1,214 +0,0 @@
#lang racket/base
(require racket/match)
(require "structs.rkt")
(require "roles.rkt")
(require "vm.rkt")
(require "log.rkt")
(require "process.rkt")
(require "action-add-endpoint.rkt")
(require "action-delete-endpoint.rkt")
(require "action-send-message.rkt")
(require "action-spawn.rkt")
(require "action-quit.rkt")
(require "list-utils.rkt")
(require "quasiqueue.rkt")
(provide run-vm)
;; dump-state : vm -> Any
(define (dump-state state)
`(vm (next-pid ,(vm-next-process-id state))
(processes ,@(for/fold ([acc '()])
([pid (in-hash-keys (vm-processes state))])
(cons (list pid (let ((wp (hash-ref (vm-processes state) pid)))
(let ((p wp))
(list (match (process-state p)
[(? vm? v) (dump-state v)]
[v v])
(process-spawn-ks p)
(process-endpoints p)
(process-meta-endpoints p)
(process-pending-actions p))))) acc)))))
;; run-vm : vm -> (Transition vm)
(define (run-vm state)
;; for each pid,
;; extract the corresponding process.
;; run through its work items, collecting external actions.
;; put the process back.
;; return the new state and the external actions
(let next-process ((remaining-pids (hash-keys (vm-processes state)))
(state state)
(external-actions (empty-quasiqueue)))
(match remaining-pids
['()
(let ((state (collect-dead-processes state))
(action-tree (quasiqueue->cons-tree external-actions)))
(transition state
(if (vm-idle? state)
action-tree
(cons (yield run-vm) action-tree))))]
[(cons pid remaining-pids)
(let-values (((state wp) (extract-process state pid)))
(if (not wp)
(next-process remaining-pids state external-actions)
(let ((p wp))
(let next-action
([remaining-actions (quasiqueue->list (process-pending-actions p))]
[p (reset-pending-actions p)]
[state state]
[external-actions external-actions])
(match remaining-actions
['()
(next-process remaining-pids
(inject-process state p)
external-actions)]
[(cons action remaining-actions)
(marketplace-log 'debug
"PID ~v (~a) Action: ~v"
pid
(process-debug-name p)
action)
(let-values (((p state new-external-actions)
(perform-action action p state)))
(if p
(next-action remaining-actions
p
state
(quasiqueue-append external-actions
new-external-actions))
(next-process remaining-pids
state
(quasiqueue-append external-actions
new-external-actions))))])))))])))
;; collect-dead-processes : vm -> vm
(define (collect-dead-processes state)
;; process-alive? : (All (State) (process State) -> Boolean)
(define (process-alive? p)
(or (not (null? (process-spawn-ks p)))
(positive? (hash-count (process-endpoints p)))
(positive? (hash-count (process-meta-endpoints p)))
(not (quasiqueue-empty? (process-pending-actions p)))))
(struct-copy vm state
[processes (for/fold ([processes #hash()])
([pid (in-hash-keys (vm-processes state))])
(define wp (hash-ref (vm-processes state) pid))
(let ((p wp))
(if (process-alive? p)
(hash-set processes pid wp)
(begin (marketplace-log 'info
"PID ~v (~a) garbage-collected"
pid
(process-debug-name p))
processes))))]))
;; vm-idle? : vm -> Boolean
;; TODO: simplify
(define (vm-idle? state)
(andmap (lambda (pid)
(define wp (hash-ref (vm-processes state) pid))
(let ((p wp))
(quasiqueue-empty? (process-pending-actions p))))
(hash-keys (vm-processes state))))
;; perform-action : (All (State) (Action State) (process State) vm
;; -> (Values (Option (process State)) vm (QuasiQueue (Action vm))))
(define (perform-action action p state)
(match action
[(at-meta-level preaction)
(transform-meta-action preaction p state)]
[(yield k)
(let ((p (run-ready p k)))
(values p state (empty-quasiqueue)))]
[(quit maybe-pid reason)
(do-quit (or maybe-pid (process-pid p)) reason p state)]
[_
(define-values (new-p new-state)
(match action
[(add-endpoint pre-eid role handler)
(do-add-endpoint pre-eid role handler p state)]
[(delete-endpoint pre-eid reason)
(do-delete-endpoint pre-eid reason p state)]
[(send-message body orientation)
(do-send-message orientation body p state)]
[(spawn spec k debug-name)
(do-spawn spec k p debug-name state)]))
(values new-p
new-state
(empty-quasiqueue))]))
;; wrap-trapk : eid -> (Handler vm)
(define (((wrap-trapk target-eid) event) state)
(match-define (eid pid pre-eid) target-eid)
(run-vm
(let-values (((state wp) (extract-process state pid)))
(if (not wp)
state
(let ((p wp))
(define ep (hash-ref (process-meta-endpoints p) pre-eid always-false))
(if (not ep)
(inject-process state p)
(let ((p (run-ready p (send-to-user p (e) (quit-interruptk e)
((endpoint-handler ep) event)))))
(inject-process state p))))))))
;; dispatch-spawn-k : PID Integer -> (TrapK PID vm)
(define (((dispatch-spawn-k pid spawn-k-id) new-pid) state)
(run-vm
(let-values (((state wp) (extract-process state pid)))
(if (not wp)
state
(let ((p wp))
(match (assoc spawn-k-id (process-spawn-ks p))
[#f
(inject-process state p)]
[(and entry (cons _ k))
(define interruptk (send-to-user p (e) (quit-interruptk e)
(k new-pid)))
(define p1 (struct-copy process p [spawn-ks (remq entry (process-spawn-ks p))]))
(inject-process state (run-ready p1 interruptk))]))))))
;; transform-meta-action : (All (State) (PreAction State) (process State) vm ->
;; (Values (Option (process State)) vm (QuasiQueue (Action vm))))
(define (transform-meta-action pa p state)
(match pa
[(add-endpoint pre-eid role unwrapped-handler)
(define new-eid (eid (process-pid p) pre-eid))
(values (struct-copy process p
[meta-endpoints (hash-set (process-meta-endpoints p)
pre-eid
(endpoint new-eid
role
unwrapped-handler))])
state
(quasiqueue
(add-endpoint new-eid
role
(wrap-trapk new-eid))))]
[(delete-endpoint pre-eid reason)
(define old-eid (eid (process-pid p) pre-eid))
(values (struct-copy process p
[meta-endpoints (hash-remove (process-meta-endpoints p) pre-eid)])
state
(quasiqueue (delete-endpoint old-eid reason)))]
[(send-message body orientation)
(values p
state
(quasiqueue (send-message body orientation)))]
[(spawn spec k debug-name)
(define pid (process-pid p))
(if k
(let ((spawn-k-id (+ 1 (list-max (map car (process-spawn-ks p))))))
(values (struct-copy process p
[spawn-ks (cons (cons spawn-k-id k) (process-spawn-ks p))])
state
(quasiqueue (spawn spec (dispatch-spawn-k pid spawn-k-id) debug-name))))
(values p
state
(quasiqueue (spawn spec #f debug-name))))]
[(quit maybe-pid reason)
(values p
state
(quasiqueue (quit maybe-pid reason)))]))

27
drivers/event-relay.rkt
View File

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

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

@ -1,179 +0,0 @@
#lang racket/base
;; TCP drivers, ported from os2.rkt directly, with flow-control and line discipline removed
(require racket/set)
(require racket/match)
(require (prefix-in tcp: racket/tcp))
(require racket/port)
(require "../sugar.rkt")
(require "../support/dump-bytes.rkt")
(require "../unify.rkt")
(provide (struct-out tcp-address)
(struct-out tcp-handle)
(struct-out tcp-listener)
(struct-out tcp-channel)
tcp
tcp-driver)
(struct tcp-address (host port) #:prefab)
(struct tcp-handle (id) #:prefab)
(struct tcp-listener (port) #:prefab)
(struct tcp-channel (source destination subpacket) #:prefab)
(define any-remote (tcp-address (wild) (wild)))
(define any-handle (tcp-handle (wild)))
(define any-listener (tcp-listener (wild)))
(define (tcp-driver)
(name-process 'tcp-driver
(spawn
(transition (set)
(observe-publishers/everything (tcp-channel any-listener any-remote (wild))
(match-state active-handles
(match-conversation c
(on-presence (maybe-spawn-socket 'publisher c active-handles #f tcp-listener-manager))
(on-absence (maybe-forget-socket 'publisher c active-handles)))))
(observe-subscribers/everything (tcp-channel any-remote any-listener (wild))
(match-state active-handles
(match-conversation c
(on-presence (maybe-spawn-socket 'subscriber c active-handles #f tcp-listener-manager))
(on-absence (maybe-forget-socket 'subscriber c active-handles)))))
(observe-publishers (tcp-channel any-handle any-remote (wild))
(match-state active-handles
(match-conversation c
(on-presence
(maybe-spawn-socket 'publisher c active-handles #t tcp-connection-manager))
(on-absence (maybe-forget-socket 'publisher c active-handles)))))
(observe-subscribers (tcp-channel any-remote any-handle (wild))
(match-state active-handles
(match-conversation c
(on-presence
(maybe-spawn-socket 'subscriber c active-handles #t tcp-connection-manager))
(on-absence (maybe-forget-socket 'subscriber c active-handles)))))))))
(define tcp (tcp-driver)) ;; pre-instantiated!
(define (maybe-spawn-socket orientation c active-handles remote-should-be-ground driver-fun)
(match (list orientation c)
[(or (list 'publisher (tcp-channel local-addr remote-addr _))
(list 'subscriber (tcp-channel remote-addr local-addr _)))
(cond
[(not (eqv? remote-should-be-ground (ground? remote-addr))) (transition active-handles)]
[(not (ground? local-addr)) (transition active-handles)]
[(set-member? active-handles (cons local-addr remote-addr)) (transition active-handles)]
[else
(transition (set-add active-handles (cons local-addr remote-addr))
(name-process (cons local-addr remote-addr)
(spawn (driver-fun local-addr remote-addr))))])]))
;; Orientation Topic Set<HandleMapping> -> Transition
(define (maybe-forget-socket orientation c active-handles)
(match (list orientation c)
[(or (list 'publisher (tcp-channel local-addr remote-addr _))
(list 'subscriber (tcp-channel remote-addr local-addr _)))
(cond
[(ground? remote-addr) (transition active-handles)]
[(not (ground? local-addr)) (transition active-handles)]
[else (transition (set-remove active-handles (cons local-addr remote-addr)))])]))
;; TcpAddress TcpAddress -> Transition
(define (tcp-listener-manager local-addr dummy-remote-addr)
(match-define (tcp-listener port) local-addr)
(define listener (tcp:tcp-listen port 4 #t))
(define (handle-absence orientation c state)
;; Hey, what if the presence we need went away between our manager
;; spawning us, and us getting to this point? Presence being
;; "edge-" rather than "level-triggered" means we'll hang around
;; sadly forever, accepting connections to nowhere. TODO
(match (list orientation c)
[(or (list 'publisher (tcp-channel (== local-addr) remote-addr _))
(list 'subscriber (tcp-channel remote-addr (== local-addr) _)))
(if (ground? remote-addr)
(transition state)
(transition 'listener-is-closed
(quit)
(when (eq? state 'listener-is-running)
(name-process (list 'tcp-listener-closer local-addr)
(spawn (begin (tcp:tcp-close listener)
(transition 'dummy (quit))))))))]))
(transition 'listener-is-running
(observe-publishers/everything (tcp-channel local-addr any-remote (wild))
(match-state state
(match-conversation c
(on-absence (handle-absence 'publisher c state)))))
(observe-subscribers/everything (tcp-channel any-remote local-addr (wild))
(match-state state
(match-conversation c
(on-absence (handle-absence 'subscriber c state)))))
(subscriber (cons (tcp:tcp-accept-evt listener) (wild))
(on-message
[(cons _ (list cin cout))
(let-values (((local-hostname local-port remote-hostname remote-port)
(tcp:tcp-addresses cin #t)))
(define remote-addr (tcp-address remote-hostname remote-port))
(name-process (cons local-addr remote-addr)
(spawn (tcp-connection-manager* local-addr remote-addr cin cout))))]))))
;; TcpAddress TcpAddress -> Transition
(define (tcp-connection-manager local-addr remote-addr)
(match-define (tcp-address remote-hostname remote-port) remote-addr)
(define-values (cin cout) (tcp:tcp-connect remote-hostname remote-port))
(tcp-connection-manager* local-addr remote-addr cin cout))
(define (read-bytes-avail-evt len input-port)
(guard-evt
(lambda ()
(let ([bstr (make-bytes len)])
(wrap-evt
(read-bytes-avail!-evt bstr input-port)
(lambda (v)
(if (number? v)
(if (= v len) bstr (subbytes bstr 0 v))
v)))))))
;; TcpAddress TcpAddress InputPort OutputPort -> Transition
;;
;; Our process state here is a Maybe<TcpConnectionState>, representing
;; a shutting-down state if #f.
(define (tcp-connection-manager* local-addr remote-addr cin cout)
(define (close-transition is-open send-eof?)
(transition #f
(when is-open
(list (when send-eof?
(send-message (tcp-channel remote-addr local-addr eof)))
(name-process (list 'tcp-connection-closer local-addr remote-addr)
(spawn (begin (tcp:tcp-abandon-port cin)
(tcp:tcp-abandon-port cout)
(transition/no-state (quit)))))))
(quit)))
(transition #t ;; open
(subscriber (cons (read-bytes-avail-evt 4096 cin) (wild))
(match-state is-open
(on-message
[(cons _ (? eof-object?)) (close-transition is-open #t)]
[(cons _ (? bytes? bs)) (transition is-open
(send-message (tcp-channel remote-addr local-addr bs)))])))
(subscriber (cons (eof-evt cin) (wild))
(match-state is-open
(on-message [(cons (? evt?) _) (close-transition is-open #t)])))
(subscriber (tcp-channel local-addr remote-addr (wild))
(match-state is-open
(on-absence (close-transition is-open #f))
(on-message
[(tcp-channel (== local-addr) (== remote-addr) subpacket)
(match subpacket
[(? eof-object?) (close-transition is-open #f)]
[(? string? s) (begin (write-string s cout)
(flush-output cout)
(transition is-open))]
[(? bytes? bs) (begin (write-bytes bs cout)
(flush-output cout)
(transition is-open))])])))
(publisher (tcp-channel remote-addr local-addr (wild))
(match-state is-open
(on-absence (close-transition is-open #f))))))

157
drivers/tcp-bare.rkt
View File

@ -1,157 +0,0 @@
#lang racket/base
;; TCP driver, with flow-control and line discipline removed, sans reliance on (ground?)
(require racket/set)
(require racket/match)
(require (prefix-in tcp: racket/tcp))
(require racket/port)
(require "../sugar.rkt")
(require "../support/dump-bytes.rkt")
(provide (struct-out tcp-address)
(struct-out tcp-handle)
(struct-out tcp-listener)
(struct-out tcp-channel)
tcp
tcp-driver)
(struct tcp-address (host port) #:prefab)
(struct tcp-handle (id) #:prefab)
(struct tcp-listener (port) #:prefab)
(struct tcp-channel (source destination subpacket) #:prefab)
(define any-remote (tcp-address (wild) (wild)))
(define any-handle (tcp-handle (wild)))
(define any-listener (tcp-listener (wild)))
(define (tcp-driver)
(name-process 'tcp-driver
(spawn
(transition (set)
(observe-publishers/everything (tcp-channel any-listener any-remote (wild))
(match-interest-type 'observer
(match-state active-handles
(match-conversation (tcp-channel L _ _)
(on-presence (maybe-spawn-socket 'incoming L active-handles tcp-listener-manager))
(on-absence (maybe-forget-socket 'incoming L active-handles))))))
(observe-subscribers/everything (tcp-channel any-remote any-listener (wild))
(match-interest-type 'observer
(match-state active-handles
(match-conversation (tcp-channel _ L _)
(on-presence (maybe-spawn-socket 'incoming L active-handles tcp-listener-manager))
(on-absence (maybe-forget-socket 'incoming L active-handles))))))
(observe-publishers (tcp-channel any-handle any-remote (wild))
(match-state active-handles
(match-conversation (tcp-channel L R _)
(on-presence (maybe-spawn-socket R L active-handles tcp-connection-manager))
(on-absence (maybe-forget-socket R L active-handles)))))
(observe-subscribers (tcp-channel any-remote any-handle (wild))
(match-state active-handles
(match-conversation (tcp-channel R L _)
(on-presence (maybe-spawn-socket R L active-handles tcp-connection-manager))
(on-absence (maybe-forget-socket R L active-handles)))))))))
(define tcp (tcp-driver)) ;; pre-instantiated!
(define (maybe-spawn-socket R L active-handles driver-fun)
(define name (cons L R))
(if (set-member? active-handles name)
(transition active-handles)
(transition (set-add active-handles name)
(name-process name (spawn (driver-fun L R))))))
(define (maybe-forget-socket R L active-handles)
(define name (cons L R))
(transition (set-remove active-handles name)))
;; TcpAddress 'incoming -> Transition
(define (tcp-listener-manager local-addr dummy-incoming-marker)
(match-define (tcp-listener port) local-addr)
(define listener (tcp:tcp-listen port 4 #t))
(define (handle-absence)
;; Hey, what if the presence we need went away between our manager
;; spawning us, and us getting to this point? Presence being
;; "edge-" rather than "level-triggered" means we'll hang around
;; sadly forever, accepting connections to nowhere. TODO
(transition 'listener-is-closed
(name-process (list 'tcp-listener-closer local-addr)
(spawn (begin (tcp:tcp-close listener)
(transition 'dummy (quit)))))
(quit)))
(transition 'listener-is-running
(observe-publishers/everything (tcp-channel local-addr any-remote (wild))
(match-interest-type 'observer
(match-state 'listener-is-running
(on-absence (handle-absence)))))
(observe-subscribers/everything (tcp-channel any-remote local-addr (wild))
(match-interest-type 'observer
(match-state 'listener-is-running
(on-absence (handle-absence)))))
(subscriber (cons (tcp:tcp-accept-evt listener) (wild))
(on-message
[(cons _ (list cin cout))
(let-values (((local-hostname local-port remote-hostname remote-port)
(tcp:tcp-addresses cin #t)))
(define remote-addr (tcp-address remote-hostname remote-port))
(name-process (cons local-addr remote-addr)
(spawn (tcp-connection-manager* local-addr remote-addr cin cout))))]))))
;; TcpAddress TcpAddress -> Transition
(define (tcp-connection-manager local-addr remote-addr)
(match-define (tcp-address remote-hostname remote-port) remote-addr)
(define-values (cin cout) (tcp:tcp-connect remote-hostname remote-port))
(tcp-connection-manager* local-addr remote-addr cin cout))
(define (read-bytes-avail-evt len input-port)
(guard-evt
(lambda ()
(let ([bstr (make-bytes len)])
(wrap-evt
(read-bytes-avail!-evt bstr input-port)
(lambda (v)
(if (number? v)
(if (= v len) bstr (subbytes bstr 0 v))
v)))))))
;; TcpAddress TcpAddress InputPort OutputPort -> Transition
;;
;; Our process state here is either 'open or 'closing.
(define (tcp-connection-manager* local-addr remote-addr cin cout)
(define (close-transition send-eof?)
(transition 'closing
(when send-eof? (send-message (tcp-channel remote-addr local-addr eof)))
(name-process (list 'tcp-connection-closer local-addr remote-addr)
(spawn (begin (tcp:tcp-abandon-port cin)
(tcp:tcp-abandon-port cout)
(transition/no-state (quit)))))
(quit)))
(transition 'open
(subscriber (cons (read-bytes-avail-evt 4096 cin) (wild))
(match-state 'open
(on-message
[(cons _ (? eof-object?)) (close-transition #t)]
[(cons _ (? bytes? bs)) (transition 'open
(send-message (tcp-channel remote-addr local-addr bs)))])))
(subscriber (cons (eof-evt cin) (wild))
(match-state 'open
(on-message [(cons (? evt?) _) (close-transition #t)])))
(subscriber (tcp-channel local-addr remote-addr (wild))
(match-state 'open
(on-absence (close-transition #f))
(on-message
[(tcp-channel (== local-addr) (== remote-addr) subpacket)
(match subpacket
[(? eof-object?) (close-transition #f)]
[(? string? s) (begin (write-string s cout)
(flush-output cout)
(transition 'open))]
[(? bytes? bs) (begin (write-bytes bs cout)
(flush-output cout)
(transition 'open))])])))
(publisher (tcp-channel remote-addr local-addr (wild))
(match-state 'open
(on-absence (close-transition #f))))))

285
drivers/tcp.rkt
View File

@ -1,285 +0,0 @@
#lang racket/base
;; TCP drivers, ported from os2.rkt directly
(require racket/set)
(require racket/match)
(require (prefix-in tcp: racket/tcp))
(require racket/port)
(require "../sugar.rkt")
(require "../support/dump-bytes.rkt")
(require "../unify.rkt")
(provide (struct-out tcp-address)
(struct-out tcp-handle)
(struct-out tcp-listener)
(struct-out tcp-channel)
(struct-out tcp-credit)
(struct-out tcp-mode)
send-tcp-credit
send-tcp-mode
tcp-driver
tcp-spy)
;; A TcpAddress is one of
;; -- a (tcp-address String Uint16), representing a remote socket
;; -- a (tcp-handle Any), representing a local socket on a kernel-assigned port
;; -- a (tcp-listener Uint16), representing a local socket on a user-assigned port
;; Note that tcp-handle-ids must be chosen carefully: they are scoped
;; to the local 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 used in TcpChannel to mean a specific
;; *instance* of a TCP connection, so if you are likely to want to
;; reconnect individual flows, use different tcp-handle-ids.
(struct tcp-address (host port) #:prefab)
(struct tcp-handle (id) #:prefab)
(struct tcp-listener (port) #:prefab)
;; A TcpChannel is a (tcp-channel TcpAddress TcpAddress TcpSubPacket),
;; and represents a section of a unidirectional TCP flow appearing on
;; our local "subnet" of the full TCP network, complete with source,
;; destination and subpacket.
(struct tcp-channel (source destination subpacket) #:prefab)
;; A TcpSubPacket is either
;; -- a Bytes, representing a section of the data carried by a
;; TcpChannel. In principle, this should also have a sequence
;; number field, but for simplicity we rely on os2.rkt's
;; preservation of ordering.
;; -- an EndOfFile, representing the end of a the channel's stream.
;; -- a (tcp-credit NonNegativeInteger), for flow control.
;; -- a (tcp-mode TcpModeName), for mode selection.
(struct tcp-credit (amount) #:prefab)
(struct tcp-mode (name) #:prefab)
;; A TcpModeName is either
;; -- 'lines, for reading line-at-a-time, or
;; -- 'bytes, for reading chunks of bytes.
;; TODO: BUG?: Routing packets between two local sockets won't work
;; because the patterns aren't set up to recognise that situation.
;; A TcpConnectionState is a (tcp-connection-state TcpModeName
;; Integer), representing the current input mode and issued credit.
(struct tcp-connection-state (mode credit) #:prefab)
;; TcpAddress TcpAddress NonNegativeInteger -> Preaction
;; Sends a credit message on a channel using the correct (subscriber) role.
(define (send-tcp-credit source-addr sink-addr amount)
(send-feedback (tcp-channel source-addr sink-addr (tcp-credit amount))))
;; TcpAddress TcpAddress TcpModeName -> Preaction
;; Sends a mode selection message on a channel using the correct (subscriber) role.
(define (send-tcp-mode source-addr sink-addr mode-name)
(send-feedback (tcp-channel source-addr sink-addr (tcp-mode mode-name))))
;; TcpAddresses; represents various wildcard addresses
(define any-remote (tcp-address (wild) (wild)))
(define any-handle (tcp-handle (wild)))
(define any-listener (tcp-listener (wild)))
;; Spawn
;; Process acting as a TCP socket factory.
(define (tcp-driver)
(name-process 'tcp-driver
(spawn
(transition (set)
(observe-publishers/everything (tcp-channel any-listener any-remote (wild))
(match-state active-handles
(match-conversation c
(on-presence (maybe-spawn-socket 'publisher c active-handles #f tcp-listener-manager))
(on-absence (maybe-forget-socket 'publisher c active-handles)))))
(observe-subscribers/everything (tcp-channel any-remote any-listener (wild))
(match-state active-handles
(match-conversation c
(on-presence (maybe-spawn-socket 'subscriber c active-handles #f tcp-listener-manager))
(on-absence (maybe-forget-socket 'subscriber c active-handles)))))
(observe-publishers (tcp-channel any-handle any-remote (wild))
(match-state active-handles
(match-conversation c
(on-presence
(maybe-spawn-socket 'publisher c active-handles #t tcp-connection-manager))
(on-absence (maybe-forget-socket 'publisher c active-handles)))))
(observe-subscribers (tcp-channel any-remote any-handle (wild))
(match-state active-handles
(match-conversation c
(on-presence
(maybe-spawn-socket 'subscriber c active-handles #t tcp-connection-manager))
(on-absence (maybe-forget-socket 'subscriber c active-handles)))))))))
;; Orientation Topic Set<HandleMapping> Boolean (TcpAddress TcpAddress -> BootK) -> Transition
(define (maybe-spawn-socket orientation c active-handles remote-should-be-ground driver-fun)
(match (list orientation c)
[(or (list 'publisher (tcp-channel local-addr remote-addr _))
(list 'subscriber (tcp-channel remote-addr local-addr _)))
(cond
[(not (eqv? remote-should-be-ground (ground? remote-addr))) (transition active-handles)]
[(not (ground? local-addr)) (transition active-handles)]
[(set-member? active-handles (cons local-addr remote-addr)) (transition active-handles)]
[else
(transition (set-add active-handles (cons local-addr remote-addr))
(name-process (cons local-addr remote-addr)
(spawn (driver-fun local-addr remote-addr))))])]))
;; Orientation Topic Set<HandleMapping> -> Transition
(define (maybe-forget-socket orientation c active-handles)
(match (list orientation c)
[(or (list 'publisher (tcp-channel local-addr remote-addr _))
(list 'subscriber (tcp-channel remote-addr local-addr _)))
(cond
[(ground? remote-addr) (transition active-handles)]
[(not (ground? local-addr)) (transition active-handles)]
[else (transition (set-remove active-handles (cons local-addr remote-addr)))])]))
;; TcpAddress TcpAddress -> Transition
(define (tcp-listener-manager local-addr dummy-remote-addr)
(match-define (tcp-listener port) local-addr)
(define listener (tcp:tcp-listen port 4 #t))
(define (handle-absence orientation c state)
;; Hey, what if the presence we need went away between our manager
;; spawning us, and us getting to this point? Presence being
;; "edge-" rather than "level-triggered" means we'll hang around
;; sadly forever, accepting connections to nowhere. TODO
(match (list orientation c)
[(or (list 'publisher (tcp-channel (== local-addr) remote-addr _))
(list 'subscriber (tcp-channel remote-addr (== local-addr) _)))
(if (ground? remote-addr)
(transition state)
(transition 'listener-is-closed
(quit)
(when (eq? state 'listener-is-running)
(name-process (list 'tcp-listener-closer local-addr)
(spawn (begin (tcp:tcp-close listener)
(transition 'dummy (quit))))))))]))
(transition 'listener-is-running
(observe-publishers/everything (tcp-channel local-addr any-remote (wild))
(match-state state
(match-conversation c
(on-absence (handle-absence 'publisher c state)))))
(observe-subscribers/everything (tcp-channel any-remote local-addr (wild))
(match-state state
(match-conversation c
(on-absence (handle-absence 'subscriber c state)))))
(subscriber (cons (tcp:tcp-accept-evt listener) (wild))
(on-message
[(cons _ (list cin cout))
(let-values (((local-hostname local-port remote-hostname remote-port)
(tcp:tcp-addresses cin #t)))
(define remote-addr (tcp-address remote-hostname remote-port))
(name-process (cons local-addr remote-addr)
(spawn (tcp-connection-manager* local-addr remote-addr cin cout))))]))))
;; TcpAddress TcpAddress -> Transition
(define (tcp-connection-manager local-addr remote-addr)
(match-define (tcp-address remote-hostname remote-port) remote-addr)
(define-values (cin cout) (tcp:tcp-connect remote-hostname remote-port))
(tcp-connection-manager* local-addr remote-addr cin cout))
;; TcpAddress TcpAddress InputPort OutputPort -> Transition
;;
;; Our process state here is a Maybe<TcpConnectionState>, representing
;; a shutting-down state if #f.
(define (tcp-connection-manager* local-addr remote-addr cin cout)
(define (close-transition state send-eof?)
(transition #f
(when (not (eq? state #f))
(list (when send-eof?
(send-message (tcp-channel remote-addr local-addr eof)))
(name-process (list 'tcp-connection-closer local-addr remote-addr)
(spawn(begin (tcp:tcp-abandon-port cin)
(tcp:tcp-abandon-port cout)
(transition 'dummy (quit)))))))
(quit)))
(define (adjust-credit state amount)
(let ((new-credit (+ (tcp-connection-state-credit state) amount)))
(transition (struct-copy tcp-connection-state state [credit new-credit])
(delete-endpoint 'inbound-relay)
(when (positive? new-credit)
(case (tcp-connection-state-mode state)
[(lines)
(name-endpoint 'inbound-relay
(subscriber (cons (read-bytes-line-evt cin 'any) (wild))
(match-state state
(on-message
[(cons _ (? eof-object?))
(close-transition state #t)]
[(cons _ (? bytes? bs))
(sequence-actions (adjust-credit state -1)
(send-message (tcp-channel remote-addr local-addr bs)))]))))]
[(bytes)
(name-endpoint 'inbound-relay
(subscriber (cons (read-bytes-evt new-credit cin) (wild))
(match-state state
(on-message
[(cons _ (? eof-object?))
(close-transition state #t)]
[(cons _ (? bytes? bs))
(let ((len (bytes-length bs)))
(sequence-actions (adjust-credit state (- len))
(send-message
(tcp-channel remote-addr local-addr bs))))]))))])))))
(transition (tcp-connection-state 'bytes 0)
(subscriber (cons (eof-evt cin) (wild))
(match-state state
(on-message
[(cons (? evt?) _)
(close-transition state #t)])))
(subscriber (tcp-channel local-addr remote-addr (wild))
(match-state state
(on-absence (close-transition state #f))
(on-message
[(tcp-channel (== local-addr) (== remote-addr) subpacket)
(match subpacket
[(? eof-object?) (close-transition state #f)]
[(? bytes? bs)
(define len (bytes-length bs))
(write-bytes bs cout)
(flush-output cout)
(transition state (send-tcp-credit local-addr remote-addr len))]
[_
(error 'tcp-connection-manager*
"Publisher on a channel isn't supposed to issue channel control messages")])])))
(publisher (tcp-channel remote-addr local-addr (wild))
(match-state state
(on-absence (close-transition state #f))
(on-message
[(tcp-channel (== remote-addr) (== local-addr) subpacket)
(match subpacket
[(tcp-credit amount)
(if state (adjust-credit state amount) (transition state))]
[(tcp-mode new-mode)
;; Also resets credit to zero.
(if state (adjust-credit (tcp-connection-state new-mode 0) 0) (transition state))]
[_
(error 'tcp-connection-manager*
"Subscriber on a channel may only send channel control messages")])])))))
;; Spawn
;; Debugging aid: produces pretty hex dumps of TCP traffic sent on
;; this network. Also prints out other messages without special
;; formatting.
(define (tcp-spy)
(define (display-message m)
(match m
[(tcp-channel source dest (? bytes? body))
(write `(TCPDATA ,source --> ,dest)) (newline)
(dump-bytes! body (bytes-length body))
(void)]
[(tcp-channel source dest (? eof-object?))
(write `(TCPEOF ,source --> ,dest)) (newline)
(void)]
[(tcp-channel source dest (tcp-credit amount))
(write `(TCPCREDIT ,source --> ,dest ,amount)) (newline)
(void)]
[other
(write `(TCPOTHER ,other)) (newline)
(void)]))
(name-process 'tcp-spy
(spawn (transition 'no-state
(observe-publishers (wild) (on-message [m (display-message m)]))
(observe-subscribers (wild) (on-message [m (display-message m)]))))))

154
drivers/timer.rkt
View File

@ -1,154 +0,0 @@
#lang racket/base
;; Timer driver.
;; Uses mutable state internally, but because the scope of the
;; mutation is limited to each timer process alone, it's easy to show
;; correct linear use of the various pointers.
(require racket/set)
(require racket/match)
(require data/heap)
(require "../sugar.rkt")
;; (pending-timer AbsoluteSeconds Any Boolean)
;; An outstanding timer being managed by the timer-driver.
(struct pending-timer (deadline ;; Real
label ;; TimerLabel
)
#:transparent)
(provide (struct-out set-timer)
(struct-out timer-expired)
timer-driver
timer-relay)
;; (define-type TimerKind (U 'relative 'absolute))
;; 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
;; corresponding timer-expired message.
(struct set-timer (label msecs kind) #:transparent)
;; Message sent by the timer driver or a timer relay upon expiry of a
;; timer. Contains the label specified in the corresponding set-timer
;; message, and also the current absolute time from the outside world.
(struct timer-expired (label msecs) #:transparent)
;; State of a timer-driver, including the identifier of the driver,
;; the currently-active subscription to ground time events (if any),
;; and the heap of all remaining timers.
(struct driver-state (heap) #:transparent)
;; (define-type RelayKey Exact-Nonnegative-Integer)
;; State of a timer-relay, including the next timer number and a
;; mapping from timer number to timer label.
(struct relay-state (next-counter ;; RelayKey
active-timers ;; (HashTable RelayKey TimerLabel)
)
#:transparent)
;; (define-type RelayState relay-state)
;; Note that (set-timer 'current-time 0 #f) causes an immediate reply
;; of (timer-expired 'current-time (current-inexact-milliseconds)),
;; which can be used for an event-oriented interface to reading the
;; system clock.
;; Racket's alarm-evt is almost the right design for timeouts: its
;; synchronisation value should be the (or some) value of the clock
;; after the asked-for time. That way it serves as timeout and
;; clock-reader in one.
;; timer-evt : Real -> Evt
(define (timer-evt msecs)
(wrap-evt (alarm-evt msecs)
(lambda (_) (current-inexact-milliseconds))))
;; make-timer-heap : -> Heap
(define (make-timer-heap)
(make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1) (pending-timer-deadline t2)))))
;; Retrieves the earliest-deadline timer from the heap, if there is
;; one.
;; next-timer! : Heap -> (Option pending-timer)
(define (next-timer! heap)
(if (zero? (heap-count heap))
#f
(heap-min heap)))
;; Retrieves (and removes) all timers from the heap that have deadline
;; earlier or equal to the time passed in.
;; fire-timers! : Heap Real -> (Listof SendMessage)
(define (fire-timers! heap now)
(if (zero? (heap-count heap))
'()
(let ((m (heap-min heap)))
(if (<= (pending-timer-deadline m) now)
(begin (heap-remove-min! heap)
(cons (send-message (timer-expired (pending-timer-label m) now))
(fire-timers! heap now)))
'()))))
;; Process for mapping this-level timer requests to ground-level timer
;; events and back.
;; timer-driver : (All (ParentState) -> (Spawn ParentState))
(define (timer-driver)
(name-process 'timer-driver
(spawn (transition (driver-state (make-timer-heap))
(subscriber (set-timer (wild) (wild) (wild))
(match-state state
(on-message
[(set-timer label msecs 'relative)
(install-timer! state label (+ (current-inexact-milliseconds) msecs))]
[(set-timer label msecs 'absolute)
(install-timer! state label msecs)])))
(publisher (timer-expired (wild) (wild)))))))
;; install-timer! : DriverState TimerLabel Real -> (Transition DriverState)
(define (install-timer! state label deadline)
(heap-add! (driver-state-heap state) (pending-timer deadline label))
(update-time-listener! state))
;; update-time-listener! : DriverState -> (Transition DriverState)
(define (update-time-listener! state)
(define next (next-timer! (driver-state-heap state)))
(transition state
(delete-endpoint 'time-listener)
(and next
(name-endpoint 'time-listener
(subscriber (cons (timer-evt (pending-timer-deadline next)) (wild))
(match-state state
(on-message
[(cons (? evt?) (? real? now))
(let ((to-send (fire-timers! (driver-state-heap state) now)))
;; Note: compute to-send before recursing, because of side-effects on heap
(sequence-actions (transition state)
update-time-listener!
to-send))])))))))
;; Process for mapping this-level timer requests to meta-level timer
;; requests. Useful when running nested VMs: essentially extends timer
;; support up the branches of the VM tree toward the leaves.
;; timer-relay : (All (ParentState) Symbol -> (Spawn ParentState))
(define (timer-relay self-id)
(name-process `(timer-relay ,self-id)
(spawn (transition (relay-state 0 (make-immutable-hash '()))
(at-meta-level
(subscriber (timer-expired (wild) (wild))
(match-state (relay-state next-counter active-timers)
(on-message
[(timer-expired (list (== self-id) (? exact-nonnegative-integer? counter))
now)
(transition (relay-state next-counter (hash-remove active-timers counter))
(and (hash-has-key? active-timers counter)
(send-message (timer-expired (hash-ref active-timers counter)
now))))]))))
(subscriber (set-timer (wild) (wild) (wild))
(match-state (relay-state next-counter active-timers)
(on-message
[(set-timer label msecs kind)
(transition (relay-state (+ next-counter 1)
(hash-set active-timers next-counter label))
(at-meta-level
(send-message (set-timer (list self-id next-counter) msecs kind))))])))
(publisher (timer-expired (wild) (wild)))))))

162
drivers/udp.rkt
View File

@ -1,162 +0,0 @@
#lang racket/base
;; UDP driver.
(require racket/set)
(require racket/match)
(require racket/udp)
(require "../sugar.rkt")
(provide (struct-out udp-remote-address)
(struct-out udp-handle)
(struct-out udp-listener)
udp-address?
udp-local-address?
(struct-out udp-packet)
udp-driver)
;; A UdpAddress is one of
;; -- a (udp-address String Uint16), representing a remote socket
;; -- a (udp-handle Any), representing a local socket on a kernel-assigned port
;; -- a (udp-listener Uint16), representing a local socket on a user-assigned port
;; Note that udp-handle-ids must be chosen carefully: they are scoped
;; to the local VM, i.e. shared between processes in that VM, so
;; processes must make sure not to accidentally clash in handle ID
;; selection.
(struct udp-remote-address (host port) #:transparent)
(struct udp-handle (id) #:transparent)
(struct udp-listener (port) #:transparent)
(define (udp-address? x)
(or (udp-remote-address? x)
(udp-handle? x)
(udp-listener? x)))
(define (udp-local-address? x)
(or (udp-handle? x)
(udp-listener? x)))
;; A UdpPacket is a (udp-packet UdpAddress UdpAddress Bytes), and
;; represents a packet appearing on our local "subnet" of the full UDP
;; network, complete with source, destination and contents.
(struct udp-packet (source destination body) #:transparent)
;; A HandleMapping is a record describing a mapping between a local
;; UdpAddress and its underlying UDP socket. It's private to the
;; implementation of the driver.
(struct handle-mapping (address socket) #:transparent)
;; TODO: BUG?: Routing packets between two local sockets won't work
;; because the patterns aren't set up to recognise that situation.
;; represents any remote address
;; any-remote : UdpAddressPattern
(define any-remote (udp-remote-address (wild) (wild)))
;; (define-type DriverState (Setof UdpLocalAddress))
;; (define-type SocketManagerState Boolean)
;; Process acting as a UDP socket factory.
;; udp-driver : (All (ParentState) -> (Spawn ParentState))
(define (udp-driver)
;; handle-presence : Topic DriverState -> (Transition DriverState)
(define (handle-presence topic active-handles)
(match-define (udp-packet _ (? udp-local-address? local-addr) _) topic)
(cond
[(set-member? active-handles local-addr)
(transition active-handles)]
[else
(transition (set-add active-handles local-addr)
(udp-socket-manager local-addr))]))
(name-process 'udp-driver
(spawn (transition (set)
(observe-subscribers (udp-packet any-remote (udp-handle (wild)) (wild))
(match-state active-handles
(match-conversation topic
(on-presence (handle-presence topic active-handles)))))
(observe-subscribers (udp-packet any-remote (udp-listener (wild)) (wild))
(match-state active-handles
(match-conversation topic
(on-presence (handle-presence topic active-handles)))))
(observe-publishers (udp-packet any-remote (udp-handle (wild)) (wild))
(match-state active-handles
(match-conversation topic
(on-presence (handle-presence topic active-handles)))))
(observe-publishers (udp-packet any-remote (udp-listener (wild)) (wild))
(match-state active-handles
(match-conversation topic
(on-presence (handle-presence topic active-handles)))))
(observe-publishers (handle-mapping (wild) (wild))
(match-state active-handles
(match-conversation (handle-mapping local-addr socket)
(on-absence
(transition (set-remove active-handles local-addr))))))
))))
;; bind-socket! : UDP-Socket UdpLocalAddress -> Void
(define (bind-socket! s local-addr)
(match local-addr
[(udp-listener port) (udp-bind! s #f port)]
[(udp-handle _) (udp-bind! s #f 0)]
[else (void)]))
;; valid-port-number? : Any -> Boolean : Natural
(define (valid-port-number? x)
;; Eventually TR will know about ranges
(exact-nonnegative-integer? x))
;; udp-socket-manager : UdpLocalAddress -> (Spawn DriverState)
(define (udp-socket-manager local-addr)
(define s (udp-open-socket #f #f))
(bind-socket! s local-addr)
(define buffer (make-bytes 65536)) ;; TODO: buffer size control
;; handle-absence : SocketManagerState -> (Transition SocketManagerState)
(define (handle-absence socket-is-open?)
(transition #f
(quit)
(when socket-is-open?
(name-process `(udp-socket-closer ,local-addr)
(spawn (begin (udp-close s)
(transition (void) (quit))))))))
(name-process `(udp-socket-manager ,local-addr)
(spawn (transition #t
;; Offers a handle-mapping on the local network so that
;; the driver/factory can clean up when this process dies.
(publisher (handle-mapping local-addr s))
;; If our counterparty removes either of their endpoints
;; as the subscriber end of the remote-to-local stream or
;; the publisher end of the local-to-remote stream, shut
;; ourselves down. Also, relay messages published on the
;; local-to-remote stream out on the actual socket.
(publisher (udp-packet any-remote local-addr (wild))
(match-state socket-is-open?
(on-absence (handle-absence socket-is-open?))))
(subscriber (udp-packet local-addr any-remote (wild))
(match-state socket-is-open?
(on-absence (handle-absence socket-is-open?))
(on-message
[(udp-packet (== local-addr)
(udp-remote-address remote-host remote-port)
body)
(begin (udp-send-to s remote-host remote-port body)
(transition socket-is-open?))])))
;; Listen for messages arriving on the actual socket using
;; a ground event, and relay them at this level.
(subscriber (cons (udp-receive!-evt s buffer) (wild))
(on-message
[(cons (? evt?) (list (? exact-integer? packet-length)
(? string? remote-host)
(? valid-port-number? remote-port)))
(let ((packet (subbytes buffer 0 packet-length)))
(send-message (udp-packet (udp-remote-address remote-host remote-port)
local-addr
packet)))]))))))

46
examples/chat-client.rkt
View File

@ -1,46 +0,0 @@
#lang marketplace
(require racket/port)
;; Usually it's OK to just use display and friends directly.
;; Here we have a console output driver just to show how it's done.
(name-process 'console-output-driver
(spawn (transition/no-state
(subscriber (list 'console-output ?)
(on-message [(list 'console-output item)
(printf "~a" item)
(void)])))))
(name-process 'console-input-driver
(spawn (transition/no-state
(name-endpoint 'input-relay
(publisher (list 'console-input ?)
(on-absence
(send-message (list 'console-output "Connection terminated.\n"))
(quit))))
(subscriber (cons (read-line-evt (current-input-port) 'any) ?)
(on-message
[(cons _ (? eof-object?))
(send-message (list 'console-output "Terminating on local EOF.\n"))
(delete-endpoint 'input-relay)]
[(cons _ (? string? line))
(send-message (list 'console-input line))])))))
(name-process 'outbound-connection
(spawn (let ((local (tcp-handle 'outbound))
(remote (tcp-address "localhost" 5999)))
(transition/no-state
(subscriber (list 'console-input ?)
(on-absence (quit))
(on-message
[(list 'console-input line)
(send-message (list 'console-output (format "> ~a \n" line)))
(send-message (tcp-channel local remote (string-append line "\n")))]))
(publisher (tcp-channel local remote ?))
(subscriber (tcp-channel remote local ?)
(on-absence (quit))
(on-message
[(tcp-channel _ _ (? eof-object?))
(quit)]
[(tcp-channel _ _ data)
(send-message (list 'console-output (format "< ~a" data)))]))))))

88
examples/chat-paper-raw.rkt
View File

@ -1,88 +0,0 @@
#lang marketplace
;; Equivalent to chat-paper.rkt, but using the raw unsugared
;; structures rather than the friendly DSL overlay.
(require racket/match)
(require marketplace)
(make-nested-vm
(lambda (vm-pid)
(process-spec (lambda (boot-pid)
(lambda (k)
(k (transition stateless
(at-meta-level
(add-endpoint 'listener
(role 'subscriber
(tcp-channel ? (tcp-listener 5999) ?)
'observer)
listener-event-handler))))))))
#f)
(define listener-event-handler
(match-lambda
[(presence-event (role _ (tcp-channel them us _) _))
(lambda (state)
(transition state
(spawn (process-spec (lambda (pid) (lambda (k) (k (chat-session them us)))))
#f
#f)))]
[_
(lambda (state) (transition state '()))]))
(define (chat-session them us)
(define user (gensym 'user))
(transition stateless
(list (listen-to-user user them us)
(speak-to-user user them us))))
(define (listen-to-user user them us)
(list
(at-meta-level
(add-endpoint 'tcp-receiver
(role 'subscriber
(tcp-channel them us ?)
'participant)
(match-lambda
[(absence-event _ _)
(lambda (state)
(transition state (quit #f #f)))]
[(message-event _ (tcp-channel _ _ (? bytes? text)))
(lambda (state)
(transition state (send-message `(,user says ,text) 'publisher)))]
[_
(lambda (state) (transition state '()))])))
(add-endpoint 'speech-publisher
(role 'publisher
`(,user says ,?)
'participant)
(lambda (event)
(lambda (state) (transition state '()))))))
(define (speak-to-user user them us)
(define (say fmt . args)
(at-meta-level
(send-message (tcp-channel us them (apply format fmt args))
'publisher)))
(define (announce who did-what)
(unless (equal? who user)
(say "~s ~s.~n" who did-what)))
(list
(say "You are ~s.~n" user)
(at-meta-level
(add-endpoint 'tcp-sender
(role 'publisher
(tcp-channel us them ?)
'participant)
(lambda (event)
(lambda (state) (transition state '())))))
(add-endpoint 'speech-subscriber
(role 'subscriber
`(,? says ,?)
'participant)
(match-lambda
[(presence-event (role _ `(,who says ,_) _))
(lambda (state) (transition state (announce who 'arrived)))]
[(absence-event (role _ `(,who says ,_) _) _)
(lambda (state) (transition state (announce who 'departed)))]
[(message-event _ `(,who says ,what))
(lambda (state) (transition state (say "~a: ~a" who what)))]))))

46
examples/chat-paper.rkt
View File

@ -1,46 +0,0 @@
#lang marketplace
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(spawn-vm
(at-meta-level
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
(match-conversation (tcp-channel them us _)
(on-presence (spawn (chat-session them us)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (chat-session them us)
(define user (gensym 'user))
(transition stateless
(listen-to-user user them us)
(speak-to-user user them us)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (listen-to-user user them us)
(list
(at-meta-level
(subscriber (tcp-channel them us ?)
(on-absence (quit))
(on-message
[(tcp-channel _ _ (? bytes? text))
(send-message `(,user says ,text))])))
(publisher `(,user says ,?))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (speak-to-user user them us)
(define (say fmt . args)
(at-meta-level
(send-message
(tcp-channel us them (apply format fmt args)))))
(define (announce who did-what)
(unless (equal? who user)
(say "~s ~s.~n" who did-what)))
(list
(say "You are ~s.~n" user)
(at-meta-level
(publisher (tcp-channel us them ?)))
(subscriber `(,? says ,?)
(match-conversation `(,who says ,_)
(on-presence (announce who 'arrived))
(on-absence (announce who 'departed))
(on-message [`(,who says ,what)
(say "~a: ~a" who what)])))))

57
examples/chat.erl
View File

@ -1,57 +0,0 @@
-module(chat).
-export([start/0]).
start() ->
IndexPid = spawn(fun () -> index([]) end),
{ok, LSock} = gen_tcp:listen(5999, [{active, true}, {packet, line}, {reuseaddr, true}]),
accept_loop(LSock, IndexPid).
accept_loop(LSock, IndexPid) ->
case gen_tcp:accept(LSock) of
{ok, Sock} ->
gen_tcp:controlling_process(Sock, spawn(fun () -> connection(Sock, IndexPid) end)),
accept_loop(LSock, IndexPid)
end.
index(Connected) ->
receive
{arrive, Pid} ->
[begin
P ! {utterance, {arrive, Pid}},
Pid ! {utterance, {arrive, P}}
end || P <- Connected],
monitor(process, Pid),
index([Pid | Connected]);
{'DOWN', _, process, Pid, _} ->
NewConnected = Connected -- [Pid],
[P ! {utterance, {depart, Pid}} || P <- NewConnected],
index(NewConnected);
M = {_Pid, says, _Thing} ->
[P ! {utterance, M} || P <- Connected],
index(Connected);
Other ->
error_logger:error_report({index, unhandled, Other})
end.
say(Sock, V) ->
gen_tcp:send(Sock, io_lib:format("~p~n", [V])).
connection(Sock, IndexPid) ->
IndexPid ! {arrive, self()},
say(Sock, {you_are, self()}),
connection_mainloop(Sock, IndexPid).
connection_mainloop(Sock, IndexPid) ->
receive
{utterance, V} ->
say(Sock, V),
connection_mainloop(Sock, IndexPid);
{tcp, _, Line} ->
IndexPid ! {self(), says, Line},
connection_mainloop(Sock, IndexPid);
{tcp_closed, _} ->
ok;
Other ->
error_logger:error_report({connection, unhandled, Other})
end.

54
examples/chat.hs
View File

@ -1,54 +0,0 @@
import Network.Socket
import Data.List
import System.IO
import Control.Exception
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
hGetLineStripped hdl = liftM (filter (not . flip elem "\n\r")) (hGetLine hdl)
main = do
index <- newTVarIO []
sock <- socket AF_INET Stream 0
setSocketOption sock ReuseAddr 1
bindSocket sock (SockAddrInet 5999 iNADDR_ANY)
listen sock 2
mainLoop index sock 0
mainLoop index sock n = do
conn <- accept sock
forkIO (runConn index conn ("user" ++ show n))
mainLoop index sock $! n+1
runConn index (sock, _) name = do
hdl <- socketToHandle sock ReadWriteMode
hSetBuffering hdl NoBuffering
handle (\(SomeException _) -> return ()) $ (do arrive index name hdl
connLoop index name hdl)
depart index name hdl
hClose hdl
broadcast str conns = sequence_ $ map sendStr conns
where sendStr (_, hdl) = hPutStrLn hdl str
arrive index name hdl = do
hPutStrLn hdl ("you are " ++ name)
old <- atomically $ do old <- readTVar index
writeTVar index ((name, hdl) : old)
return old
broadcast (name ++ " arrived") old
sequence_ $ map (\ (otherName, _) -> hPutStrLn hdl (otherName ++ " arrived")) old
depart index name hdl = do
new <- atomically $ do old <- readTVar index
let new = old \\ [(name, hdl)]
writeTVar index new
return new
broadcast (name ++ " departed") new
connLoop index name hdl = do
line <- hGetLineStripped hdl
curr <- atomically $ readTVar index
broadcast (name ++ " says " ++ line) curr
connLoop index name hdl

50
examples/chat.py
View File

@ -1,50 +0,0 @@
from __future__ import with_statement
from SocketServer import ThreadingMixIn, TCPServer, StreamRequestHandler
from threading import RLock
active_connections = set()
active_connection_mutex = RLock()
class ChatServer(ThreadingMixIn, TCPServer):
allow_reuse_address = True
counter = 0
class ConnectionHandler(StreamRequestHandler):
def handle(self):
global counter
self.connection_id = 'user' + str(counter)
counter = counter + 1
try:
self.arrive()
while True:
line = self.rfile.readline()
if not line: break
for c in active_connections.copy():
c.announce('%s says %s' % (self.connection_id, line.strip()))
finally:
self.depart()
def arrive(self):
self.announce('you are %s' % (self.connection_id,))
with active_connection_mutex:
for c in active_connections:
self.announce('%s arrived' % (c.connection_id,))
c.announce('%s arrived' % (self.connection_id,))
active_connections.add(self)
def depart(self):
with active_connection_mutex:
active_connections.discard(self)
for c in active_connections:
c.announce('%s departed' % (self.connection_id,))
def announce(self, s):
try:
self.wfile.write(s + '\n')
except IOError:
self.depart()
if __name__ == '__main__':
s = ChatServer(('localhost', 5999), ConnectionHandler)
s.serve_forever()

47
examples/debug-chat.rkt
View File

@ -1,47 +0,0 @@
#lang marketplace
(require "../support/debug.rkt")
(debug
(spawn-vm
(at-meta-level
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
(match-conversation (tcp-channel them us _)
(on-presence
(debug (name-process (list 'session them)
(spawn (chat-session them us))))))))))
(define (chat-session them us)
(define user (gensym 'user))
(transition stateless
(listen-to-user user them us)
(speak-to-user user them us)))
(define (listen-to-user user them us)
(list
(publisher `(,user says ,?))
(at-meta-level
(subscriber (tcp-channel them us ?)
(on-absence (quit))
(on-message
[(tcp-channel _ _ (? bytes? text))
(send-message `(,user says ,text))])))))
(define (speak-to-user user them us)
(define (say fmt . args)
(at-meta-level
(send-message
(tcp-channel us them (apply format fmt args)))))
(define (announce who did-what)
(unless (equal? who user)
(say "~s ~s.~n" who did-what)))
(list
(say "You are ~s.~n" user)
(at-meta-level
(publisher (tcp-channel us them ?)))
(subscriber `(,? says ,?)
(match-conversation `(,who says ,_)
(on-presence (announce who 'arrived))
(on-absence (announce who 'departed))
(on-message [`(,who says ,what)
(say "~a: ~a" who what)])))))

14
examples/echo-paper.rkt
View File

@ -1,14 +0,0 @@
#lang marketplace
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
(match-conversation (tcp-channel from to _)
(on-presence (spawn (echoer from to)))))
(define (echoer from to)
(transition stateless
(publisher (tcp-channel to from ?))
(subscriber (tcp-channel from to ?)
(on-absence (quit))
(on-message
[(tcp-channel _ _ data)
(send-message (tcp-channel to from data))]))))

19
examples/echo-plain.rkt
View File

@ -1,19 +0,0 @@
#lang racket/base
;; Plain Racket version, using (require) instead of #lang marketplace.
(require marketplace/sugar)
(require marketplace/drivers/tcp-bare)
(define (echoer from to)
(transition/no-state
(publisher (tcp-channel to from ?))
(subscriber (tcp-channel from to ?)
(on-absence (quit))
(on-message
[(tcp-channel _ _ data)
(send-message (tcp-channel to from data))]))))
(ground-vm tcp
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
(match-conversation (tcp-channel from to _)
(on-presence (spawn (echoer from to))))))

27
footnote.css Normal file
View File

@ -0,0 +1,27 @@
.NoteBox {
position: relative;
float: right;
left: 2em;
height: 0em;
width: 13em;
margin: 0em -13em 0em 0em;
}
.NoteContent {
margin: 0 0 0 0;
font-size: 85%;
}
.FootnoteContent {
display: none;
}
.FootnoteBlock {
border-top: 1px solid black;
}
.FootnoteBlockContent {
padding-left: 1em;
text-indent: -0.5em;
}

68
ground.rkt
View File

@ -1,68 +0,0 @@
#lang racket/base
(require racket/match)
(require "structs.rkt")
(require "roles.rkt")
(require "vm.rkt")
(require "log.rkt")
(require "process.rkt")
(require "actions.rkt")
(require "action-send-message.rkt")
(require "quasiqueue.rkt")
(provide run-ground-vm)
;; run-ground-vm : process-spec -> Void
(define (run-ground-vm boot)
(let loop ((state (make-vm boot)))
(match (run-vm state)
[(transition state actions)
(define is-blocking?
(match (quasiqueue->list (action-tree->quasiqueue actions))
['()
;; no "yield" action -> certainly blocking
#t]
[(list (yield (== run-vm)))
;; single "yield", with k statically known to be run-vm -> poll
#f]
[_
;; uh-oh
(error 'ground-vm
"Cannot process meta-actions ~v because no further metalevel exists"
actions)]))
(define active-events
(endpoint-fold extract-ground-event-subscriptions '() state))
(if (and is-blocking?
(null? active-events))
(begin
;; Not polling, and no events that could wake us from blocking, so quit
(marketplace-log 'debug "Ground VM returning normally.")
(sleep 0.2) ;; give the log-receivers a chance to drain (!)
(void))
(let ((interruptk (apply sync
(if is-blocking?
never-evt
(wrap-evt always-evt (lambda (dummy) values)))
active-events)))
(loop (interruptk state))))])))
;; extract-ground-event-subscriptions :
;; (All (State) (process State) (endpoint State) (Listof Evt) -> (Listof Evt))
(define (extract-ground-event-subscriptions old-p ep acc)
(define pid (process-pid old-p))
(match (endpoint-role ep)
[(role 'subscriber (cons (? evt? evt) _) 'participant)
;; evt-handler : Any -> (vm -> vm)
(define ((evt-handler message) state)
(let-values (((state wp) (extract-process state pid)))
(if (not wp)
state
(let ((p wp))
(let-values
(((p state)
(do-send-message 'publisher (cons evt message) p state)))
(if p
(inject-process state p)
state))))))
(cons (wrap-evt evt evt-handler) acc)]
[_ acc]))

192
high-level-interface.html Normal file
View File

File diff suppressed because one or more lines are too long

37
index.html Normal file
View File

File diff suppressed because one or more lines are too long

10
info.rkt
View File

@ -1,10 +0,0 @@
#lang setup/infotab
(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"))

68
lang/base.rkt
View File

@ -1,68 +0,0 @@
#lang racket/base
(require (for-syntax racket/base))
(require (for-syntax racket/pretty))
(require "../sugar.rkt")
(require "../drivers/tcp-bare.rkt")
(require "../support/spy.rkt")
(provide (rename-out [module-begin #%module-begin])
(except-out (all-from-out racket/base) #%module-begin)
(all-from-out "../sugar.rkt")
(all-from-out "../drivers/tcp-bare.rkt")
(all-from-out "../support/spy.rkt")
stateless)
(define stateless (void))
(define-syntax (module-begin stx)
(unless (eq? (syntax-local-context) 'module-begin)
(raise-syntax-error #f "allowed only around a module body" stx))
(syntax-case stx ()
[(_ forms ...)
(let ()
(define (accumulate-actions action-ids final-forms forms)
(if (null? forms)
(let ((final-stx
#`(#%module-begin #,@(reverse final-forms)
(ground-vm tcp #,@(reverse action-ids)))))
;;(pretty-print (syntax->datum final-stx))
final-stx)
(syntax-case (local-expand (car forms)
'module
(syntax->list #'(quote
quote-syntax #%top
lambda case-lambda
let-values letrec-values
begin begin0 set!
with-continuation-mark
if #%app #%expression
define-values define-syntaxes
begin-for-syntax
module module*
#%module-begin
#%require #%provide
#%variable-reference))) ()
[(head rest ...)
(if (free-identifier=? #'head #'begin)
(accumulate-actions action-ids
final-forms
(append (syntax->list #'(rest ...)) (cdr forms)))
(if (ormap (lambda (i) (free-identifier=? #'head i))
(syntax->list #'(define-values define-syntaxes begin-for-syntax
module module*
#%module-begin
#%require #%provide)))
(accumulate-actions action-ids
(cons (car forms) final-forms)
(cdr forms))
(accumulate-action (car forms) action-ids final-forms (cdr forms))))]
[non-pair-syntax
(accumulate-action (car forms) action-ids final-forms (cdr forms))])))
(define (accumulate-action action action-ids final-forms remaining-forms)
(define temp (car (generate-temporaries (list action))))
(accumulate-actions (cons temp action-ids)
(cons #`(define #,temp #,action) final-forms)
remaining-forms))
(accumulate-actions '() '() (syntax->list #'(forms ...))))]))

2
lang/reader.rkt
View File

@ -1,2 +0,0 @@
#lang s-exp syntax/module-reader
marketplace/lang/base

7
list-utils.rkt
View File

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

38
log.rkt
View File

@ -1,38 +0,0 @@
#lang racket/base
(require racket/match)
(provide marketplace-root-logger
marketplace-log)
(define marketplace-root-logger (make-logger 'marketplace #f))
(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 ...))]))
(define (level-code level)
(match level
['debug "D"]
['info "I"]
['warning "W"]
['error "E"]
['fatal "F"]
[other (symbol->string other)]))
(match (getenv "MARKETPLACE_LOG")
[#f (void)]
[str (let ((level (string->symbol str)))
(define receiver (make-log-receiver marketplace-root-logger level))
(thread
(lambda ()
(let loop ()
(match (sync receiver)
[(vector level message data event-name)
(fprintf (current-error-port) "~a/~a\n" (level-code level) message)])
(loop)))))])

106
low-level-interface.html Normal file
View File

File diff suppressed because one or more lines are too long

27
main.rkt
View File

@ -1,27 +0,0 @@
#lang racket/base
;; Virtualized operating system, this time with presence.
;; TODO: contracts for State checking
;; TODO: revisit exposure of PIDs to processes.
;; - make processes parametric in the PID type?
;; - simply make PIDs unavailable to processes?
;; - revisit points-of-attachment idea, and expose presence on PIDs properly?
(require racket/match)
(require "structs.rkt")
(require "roles.rkt")
(require "vm.rkt")
(require "actions.rkt")
(require "nested.rkt")
(require "ground.rkt")
(require "unify.rkt")
(provide (all-from-out "structs.rkt")
(all-from-out "roles.rkt")
make-nested-vm
run-ground-vm
wild
wild?
non-wild?
ground?)

332
manual-fonts.css Normal file
View File

File diff suppressed because one or more lines are too long

307
manual-racket.css Normal file
View File

@ -0,0 +1,307 @@
/* See the beginning of "manual.css". */
/* Monospace: */
.RktIn, .RktRdr, .RktPn, .RktMeta,
.RktMod, .RktKw, .RktVar, .RktSym,
.RktRes, .RktOut, .RktCmt, .RktVal,
.RktBlk, .RktErr {
font-family: 'Source Code Pro', monospace;
white-space: inherit;
font-size: 1rem;
}
/* this selctor grabs the first linked Racket symbol
in a definition box (i.e., the symbol being defined) */
a.RktValDef, a.RktStxDef, a.RktSymDef,
span.RktValDef, span.RktStxDef, span.RktSymDef
{
font-size: 1.15rem;
color: black;
font-weight: 600;
}
.inheritedlbl {
font-family: 'Fira', sans;
}
.RBackgroundLabelInner {
font-family: inherit;
}
/* ---------------------------------------- */
/* Inherited methods, left margin */
.inherited {
width: 95%;
margin-top: 0.5em;
text-align: left;
background-color: inherit;
}
.inherited td {
font-size: 82%;
padding-left: 0.5rem;
line-height: 1.3em;
text-indent: 0;
padding-right: 0;
}
.inheritedlbl {
font-style: normal;
}
/* ---------------------------------------- */
/* Racket text styles */
.RktIn {
color: #cc6633;
background-color: #eee;
}
.RktInBG {
background-color: #eee;
}
.refcolumn .RktInBG {
background-color: white;
}
.RktRdr {
}
.RktPn {
color: #843c24;
}
.RktMeta {
color: black;
}
.RktMod {
color: inherit;
}
.RktOpt {
color: black;
}
.RktKw {
color: black;
}
.RktErr {
color: red;
font-style: italic;
font-weight: 400;
}
.RktVar {
position: relative;
left: -1px; font-style: italic;
color: #444;
}
.SVInsetFlow .RktVar {
font-weight: 400;
color: #444;
}
.RktSym {
color: inherit;
}
.RktValLink, .RktStxLink, .RktModLink {
text-decoration: none;
color: #07A;
font-weight: 500;
font-size: 1rem;
}
/* for syntax links within headings */
h2 a.RktStxLink, h3 a.RktStxLink, h4 a.RktStxLink, h5 a.RktStxLink,
h2 a.RktValLink, h3 a.RktValLink, h4 a.RktValLink, h5 a.RktValLink,
h2 .RktSym, h3 .RktSym, h4 .RktSym, h5 .RktSym,
h2 .RktMod, h3 .RktMod, h4 .RktMod, h5 .RktMod,
h2 .RktVal, h3 .RktVal, h4 .RktVal, h5 .RktVal,
h2 .RktPn, h3 .RktPn, h4 .RktPn, h5 .RktPn {
color: #333;
font-size: 1.65rem;
font-weight: 400;
}
.toptoclink .RktStxLink, .toclink .RktStxLink,
.toptoclink .RktValLink, .toclink .RktValLink,
.toptoclink .RktModLink, .toclink .RktModLink {
color: inherit;
}
.tocset .RktValLink, .tocset .RktStxLink, .tocset .RktModLink {
color: black;
font-weight: 400;
font-size: 0.9rem;
}
.tocset td a.tocviewselflink .RktValLink,
.tocset td a.tocviewselflink .RktStxLink,
.tocset td a.tocviewselflink .RktMod,
.tocset td a.tocviewselflink .RktSym {
font-weight: lighter;
color: white;
}
.RktRes {
color: #0000af;
}
.RktOut {
color: #960096;
}
.RktCmt {
color: #c2741f;
}
.RktVal {
color: #228b22;
}
/* ---------------------------------------- */
/* Some inline styles */
.together { /* for definitions grouped together in one box */
width: 100%;
border-top: 2px solid white;
}
tbody > tr:first-child > td > .together {
border-top: 0px; /* erase border on first instance of together */
}
.RktBlk {
white-space: normal;
text-align: left;
}
.highlighted {
font-size: 1rem;
background-color: #fee;
}
.defmodule {
font-family: 'Source Code Pro';
padding: 0.25rem 0.75rem 0.25rem 0.5rem;
margin-bottom: 1rem;
width: 100%;
background-color: hsl(60, 29%, 94%);
}
.defmodule a {
color: #444;
}
.defmodule td span.hspace:first-child {
position: absolute;
width: 0;
}
.defmodule .RpackageSpec .Smaller,
.defmodule .RpackageSpec .stt {
font-size: 1rem;
}
.specgrammar {
float: none;
padding-left: 1em;
}
.RBibliography td {
vertical-align: text-top;
padding-top: 1em;
}
.leftindent {
margin-left: 2rem;
margin-right: 0em;
}
.insetpara {
margin-left: 1em;
margin-right: 1em;
}
.SCodeFlow .Rfilebox {
margin-left: -1em; /* see 17.2 of guide, module languages */
}
.Rfiletitle {
text-align: right;
background-color: #eee;
}
.SCodeFlow .Rfiletitle {
border-top: 1px dotted gray;
border-right: 1px dotted gray;
}
.Rfilename {
border-top: 0;
border-right: 0;
padding-left: 0.5em;
padding-right: 0.5em;
background-color: inherit;
}
.Rfilecontent {
margin: 0.5em;
}
.RpackageSpec {
padding-right: 0;
}
/* ---------------------------------------- */
/* For background labels */
.RBackgroundLabel {
float: right;
width: 0px;
height: 0px;
}
.RBackgroundLabelInner {
position: relative;
width: 25em;
left: -25.5em;
top: 0.20rem; /* sensitive to monospaced font choice */
text-align: right;
z-index: 0;
font-weight: 300;
font-family: 'Source Code Pro';
font-size: 0.9rem;
color: gray;
}
.RpackageSpec .Smaller {
font-weight: 300;
font-family: 'Source Code Pro';
font-size: 0.9rem;
}
.RForeground {
position: relative;
left: 0px;
top: 0px;
z-index: 1;
}

728
manual-style.css Normal file
View File

@ -0,0 +1,728 @@
/* See the beginning of "scribble.css".
This file is used by the `scribble/manual` language, along with
"manual-racket.css". */
@import url("manual-fonts.css");
* {
margin: 0;
padding: 0;
}
@media all {html {font-size: 15px;}}
@media all and (max-width:940px){html {font-size: 14px;}}
@media all and (max-width:850px){html {font-size: 13px;}}
@media all and (max-width:830px){html {font-size: 12px;}}
@media all and (max-width:740px){html {font-size: 11px;}}
/* CSS seems backward: List all the classes for which we want a
particular font, so that the font can be changed in one place. (It
would be nicer to reference a font definition from all the places
that we want it.)
As you read the rest of the file, remember to double-check here to
see if any font is set. */
/* Monospace: */
.maincolumn, .refpara, .refelem, .tocset, .stt, .hspace, .refparaleft, .refelemleft {
font-family: 'Source Code Pro', monospace;
white-space: inherit;
font-size: 1rem;
}
.stt {
font-weight: 500;
}
h2 .stt {
font-size: 2.7rem;
}
.toptoclink .stt {
font-size: inherit;
}
.toclink .stt {
font-size: 90%;
}
.RpackageSpec .stt {
font-weight: 300;
font-family: 'Source Code Pro';
font-size: 0.9rem;
}
h3 .stt, h4 .stt, h5 .stt {
color: #333;
font-size: 1.65rem;
font-weight: 400;
}
/* Serif: */
.main, .refcontent, .tocview, .tocsub, .sroman, i {
font-family: 'Charter', serif;
font-size: 1.18rem;
}
/* Sans-serif: */
.version, .versionNoNav, .ssansserif {
font-family: 'Fira', sans-serif;
}
.ssansserif {
font-family: 'Fira';
font-weight: 500;
font-size: 0.9em;
}
.tocset .ssansserif {
font-size: 100%;
}
/* ---------------------------------------- */
p, .SIntrapara {
display: block;
margin: 0 0 1em 0;
line-height: 140%;
}
li {
list-style-position: outside;
margin-left: 1.2em;
}
h1, h2, h3, h4, h5, h6, h7, h8 {
font-family: 'Fira';
font-weight: 300;
font-size: 1.6rem;
color: #333;
margin-top: inherit;
margin-bottom: 1rem;
line-height: 125%;
-moz-font-feature-settings: 'tnum=1';
-moz-font-feature-settings: 'tnum' 1;
-webkit-font-feature-settings: 'tnum' 1;
-o-font-feature-settings: 'tnum' 1;
-ms-font-feature-settings: 'tnum' 1;
font-feature-settings: 'tnum' 1;
}
h3, h4, h5, h6, h7, h8 {
border-top: 1px solid black;
}
h2 { /* per-page main title */
font-family: 'Miso';
font-weight: bold;
margin-top: 4rem;
font-size: 3rem;
line-height: 110%;
width: 90%;
}
h3, h4, h5, h6, h7, h8 {
margin-top: 2em;
padding-top: 0.1em;
margin-bottom: 0.75em;
}
/* ---------------------------------------- */
/* Main */
body {
color: black;
background-color: white;
}
.maincolumn {
width: auto;
margin-top: 4rem;
margin-left: 17rem;
margin-right: 2rem;
margin-bottom: 10rem; /* to avoid fixed bottom nav bar */
max-width: 700px;
min-width: 370px; /* below this size, code samples don't fit */
}
a {
text-decoration: inherit;
}
a, .toclink, .toptoclink, .tocviewlink, .tocviewselflink, .tocviewtoggle, .plainlink,
.techinside, .techoutside:hover, .techinside:hover {
color: #07A;
}
a:hover {
text-decoration: underline;
}
/* ---------------------------------------- */
/* Navigation */
.navsettop, .navsetbottom {
left: 0;
width: 15rem;
height: 6rem;
font-family: 'Fira';
font-size: 0.9rem;
border-bottom: 0px solid hsl(216, 15%, 70%);
background-color: inherit;
padding: 0;
}
.navsettop {
position: absolute;
top: 0;
left: 0;
margin-bottom: 0;
border-bottom: 0;
}
.navsettop a, .navsetbottom a {
color: black;
}
.navsettop a:hover, .navsetbottom a:hover {
background: hsl(216, 78%, 95%);
text-decoration: none;
}
.navleft, .navright {
position: static;
float: none;
margin: 0;
white-space: normal;
}
.navleft a {
display: inline-block;
}
.navright a {
display: inline-block;
text-align: center;
}
.navleft a, .navright a, .navright span {
display: inline-block;
padding: 0.5rem;
min-width: 1rem;
}
.navright {
height: 2rem;
white-space: nowrap;
}
.navsetbottom {
display: none;
}
.nonavigation {
color: #889;
}
.searchform {
display: block;
margin: 0;
padding: 0;
border-bottom: 1px solid #eee;
height: 4rem;
}
.searchbox {
font-size: 1rem;
width: 12rem;
margin: 1rem;
padding: 0.25rem;
vertical-align: middle;
background-color: white;
}
#search_box {
font-size: 0.8rem;
}
/* ---------------------------------------- */
/* Version */
.versionbox {
position: absolute;
float: none;
top: 0.25rem;
left: 17rem;
z-index: 11000;
height: 2em;
font-size: 70%;
font-weight: lighter;
width: inherit;
margin: 0;
}
.version, .versionNoNav {
font-size: inherit;
}
.version:before, .versionNoNav:before {
content: "v.";
}
/* ---------------------------------------- */
/* Margin notes */
/* cancel scribvle.css styles: */
.refpara, .refelem {
position: static;
float: none;
height: auto;
width: auto;
margin: 0;
}
.refcolumn {
position: static;
display: block;
width: auto;
font-size: inherit;
margin: 2rem;
margin-left: 2rem;
padding: 0.5em;
padding-left: 0.75em;
padding-right: 1em;
background: hsl(60, 29%, 94%);
border: 1px solid #ccb;
border-left: 0.4rem solid #ccb;
}
.refcontent p {
line-height: 1.5rem;
margin: 0;
}
.refcontent p + p {
margin-top: 1em;
}
.refcontent a {
font-weight: 400;
}
.refcontent img {
width: 1.5em;
}
.refpara, .refparaleft {
top: -1em;
}
@media all and (max-width:600px) {
.refcolumn {
margin-left: 0;
margin-right: 0;
}
}
@media all and (min-width:1260px) {
.refcolumn {
position: absolute;
left: 66rem; right: 3em;
margin: 0;
float: right;
max-width: 18rem;
}
}
.refcontent {
font-family: 'Fira';
font-size: 1rem;
line-height: 160%;
margin: 0 0 0 0;
}
.refparaleft, .refelemleft {
position: relative;
float: left;
right: 2em;
height: 0em;
width: 13em;
margin: 0em 0em 0em -13em;
}
.refcolumnleft {
background-color: hsl(60, 29%, 94%);
display: block;
position: relative;
width: 13em;
font-size: 85%;
border: 0.5em solid hsl(60, 29%, 94%);
margin: 0 0 0 0;
}
/* ---------------------------------------- */
/* Table of contents, left margin */
.tocset {
position: absolute;
float: none;
left: 0;
top: 0rem;
width: 14rem;
padding: 7rem 0.5rem 0.5rem 0.5rem;
background-color: hsl(216, 15%, 70%);
margin: 0;
}
.tocset td {
vertical-align: text-top;
padding-bottom: 0.4rem;
padding-left: 0.2rem;
line-height: 110%;
font-family: 'Fira';
-moz-font-feature-settings: 'tnum=1';
-moz-font-feature-settings: 'tnum' 1;
-webkit-font-feature-settings: 'tnum' 1;
-o-font-feature-settings: 'tnum' 1;
-ms-font-feature-settings: 'tnum' 1;
font-feature-settings: 'tnum' 1;
}
.tocset td a {
color: black;
font-weight: 400;
}
.tocview {
text-align: left;
background-color: inherit;
}
.tocview td, .tocsub td {
line-height: 1.3em;
}
.tocview table, .tocsub table {
width: 90%;
}
.tocset td a.tocviewselflink {
font-weight: lighter;
font-size: 110%; /* monospaced styles below don't need to enlarge */
color: white;
}
.tocviewselflink {
text-decoration: none;
}
.tocsub {
text-align: left;
margin-top: 0.5em;
background-color: inherit;
}
.tocviewlist, .tocsublist {
margin-left: 0.2em;
margin-right: 0.2em;
padding-top: 0.2em;
padding-bottom: 0.2em;
}
.tocviewlist table {
font-size: 82%;
}
.tocviewlisttopspace {
margin-bottom: 1em;
}
.tocviewsublist, .tocviewsublistonly, .tocviewsublisttop, .tocviewsublistbottom {
margin-left: 0.4em;
border-left: 1px solid #99a;
padding-left: 0.8em;
}
.tocviewsublist {
margin-bottom: 1em;
}
.tocviewsublist table,
.tocviewsublistonly table,
.tocviewsublisttop table,
.tocviewsublistbottom table,
table.tocsublist {
font-size: 1rem;
}
.tocviewsublist td, .tocviewsublistbottom td, .tocviewsublisttop td, .tocsub td,
.tocviewsublistonly td {
font-size: 90%;
}
.tocviewtoggle {
font-size: 75%; /* looks better, and avoids bounce when toggling sub-sections due to font alignments */
}
.tocsublist td {
padding-left: 0.5rem;
padding-top: 0.25rem;
text-indent: 0;
}
.tocsublinknumber {
font-size: 100%;
}
.tocsublink {
font-size: 82%;
text-decoration: none;
}
.tocsubseclink {
font-size: 100%;
text-decoration: none;
}
.tocsubnonseclink {
font-size: 82%;
text-decoration: none;
margin-left: 1rem;
padding-left: 0;
display: inline-block;
}
/* the label "on this page" */
.tocsubtitle {
display: block;
font-size: 62%;
font-family: 'Fira';
font-weight: bolder;
font-style: normal;
letter-spacing: 2px;
text-transform: uppercase;
margin: 0.5em;
}
.toptoclink {
font-weight: bold;
font-size: 110%
}
/* hack to add space around .toptoclink because markup is all td */
.toptoclink:after {
content: " ";
font-size: 3rem;
}
.toclink {
font-size: inherit;
}
/* ---------------------------------------- */
/* Some inline styles */
.indexlink {
text-decoration: none;
}
pre {
margin-left: 2em;
}
blockquote {
margin-left: 2em;
margin-right: 2em;
margin-bottom: 1em;
}
.SCodeFlow {
border-left: 1px dotted black;
padding-left: 1em;
padding-right: 1em;
margin-top: 1em;
margin-bottom: 1em;
margin-left: 0em;
margin-right: 2em;
white-space: nowrap;
line-height: 1.4em;
}
.SCodeFlow img {
margin-top: 0.5em;
margin-bottom: 0.5em;
}
.SVInsetFlow, .SIntrapara > table.RBoxed {
margin: 0;
margin-top: 2em;
padding: 0.25em;
padding-bottom: 0.5em;
background: #f3f3f3;
box-sizing:border-box;
border-top: 1px solid #99b;
background: hsl(216, 78%, 95%);
background: -moz-linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 78%, 95%) 100%);
background: -webkit-linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 78%, 95%) 100%);
background: -o-linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 78%, 95%) 100%);
background: -ms-linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 78%, 95%) 100%);
background: linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 78%, 95%) 100%);
}
blockquote > blockquote.SVInsetFlow {
/* resolves issue in e.g. /reference/notation.html */
margin-top: 0em;
}
.leftindent .SVInsetFlow { /* see e.g. section 4.5 of Racket Guide */
margin-top: 1em;
margin-bottom: 1em;
}
.SVInsetFlow a, .SCodeFlow a {
color: #07A;
font-weight: 500;
}
.SubFlow {
display: block;
margin: 0em;
}
.boxed {
width: 100%;
background-color: inherit;
}
.techoutside { text-decoration: none; }
.SAuthorListBox {
position: static;
float: none;
font-family: 'Fira';
font-weight: 300;
font-size: 110%;
margin-top: 1rem;
margin-bottom: 3rem;
width: auto;
height: auto;
}
.author > a { /* email links within author block */
font-weight: inherit;
color: inherit;
}
.SAuthorList {
font-size: 82%;
}
.SAuthorList:before {
content: "by ";
}
.author {
display: inline;
white-space: nowrap;
}
/* phone + tablet styles */
@media all and (max-width:720px){
@media all and (max-width:720px){
@media all {html {font-size: 15px;}}
@media all and (max-width:700px){html {font-size: 14px;}}
@media all and (max-width:630px){html {font-size: 13px;}}
@media all and (max-width:610px){html {font-size: 12px;}}
@media all and (max-width:550px){html {font-size: 11px;}}
@media all and (max-width:520px){html {font-size: 10px;}}
.navsettop, .navsetbottom {
display: block;
position: absolute;
width: 100%;
height: 4rem;
border: 0;
background-color: hsl(216, 15%, 70%);
}
.searchform {
display: inline;
border: 0;
}
.navright {
position: absolute;
right: 1.5rem;
margin-top: 1rem;
border: 0px solid red;
}
.navsetbottom {
display: block;
margin-top: 8rem;
}
.tocset {
display: none;
}
.tocset table, .tocset tbody, .tocset tr, .tocset td {
display: inline;
}
.tocview {
display: none;
}
.tocsub .tocsubtitle {
display: none;
}
.versionbox {
top: 4.5rem;
left: 1rem; /* same distance as main-column */
z-index: 11000;
height: 2em;
font-size: 70%;
font-weight: lighter;
}
.maincolumn {
margin-left: 1em;
margin-top: 7rem;
margin-bottom: 0rem;
}
}
}
/* print styles : hide the navigation elements */
@media print {
.tocset,
.navsettop,
.navsetbottom { display: none; }
.maincolumn {
width: auto;
margin-right: 13em;
margin-left: 0;
}
}

18
nested.rkt
View File

@ -1,18 +0,0 @@
#lang racket/base
(require racket/match)
(require "structs.rkt")
(require "roles.rkt")
(require "vm.rkt")
(require "actions.rkt")
(provide make-nested-vm)
;; make-nested-vm : (All (State) (PID -> process-spec) Any -> (spawn State))
(define (make-nested-vm make-boot debug-name)
(spawn (process-spec (lambda (nested-vm-pid)
(lambda (k) (k (run-vm (make-vm (make-boot nested-vm-pid)))))))
#f
debug-name))
;; TODO: (process-spec: NewProcessState (pid-id) transition-expr)

BIN
pict.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 21 KiB

BIN
pict_2.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 14 KiB

BIN
pict_3.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 14 KiB

141
process.rkt
View File

@ -1,141 +0,0 @@
#lang racket/base
(require racket/match)
(require "structs.rkt")
(require "roles.rkt")
(require "vm.rkt")
(require "log.rkt")
(require "quasiqueue.rkt")
(provide send-to-user
send-to-user*
action-tree->quasiqueue
quit-interruptk
run-ready
notify-route-change-vm)
(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))
(define-syntax-rule (send-to-user* debug-name pid (e) failure-result enclosed-expr)
(with-handlers ([exn:fail? (lambda (e)
(if (exn? e)
(marketplace-log 'error "Process ~v(~v):~n~a~n"
debug-name pid (exn-message e))
(marketplace-log 'error "Process ~v(~v):~n~v~n"
debug-name pid e))
failure-result)])
(marketplace-log 'debug "Entering process ~v(~v)" debug-name pid)
(define result enclosed-expr)
(marketplace-log 'debug "Leaving process ~v(~v)" debug-name pid)
result))
;; action-tree->quasiqueue : (All (State) (ActionTree State) -> (QuasiQueue (Action State)))
;; TODO: simplify
(define (action-tree->quasiqueue t)
(let loop ((revacc '()) (t t))
(cond
[(pair? t) (loop (loop revacc (car t)) (cdr t))]
[(or (null? t) (eq? t #f) (void? t)) revacc]
[else (cons t revacc)])))
;; Split out to provide a syntactic location to define State in
;; quit-interruptk : Reason -> (All (State) State -> (Transition State))
(define ((quit-interruptk e) old-process-state)
(transition old-process-state (quit #f e)))
;; run-ready : (All (State) (process State) (InterruptK State) -> (process State))
(define (run-ready p interruptk)
(define old-state (process-state p))
(match-define (transition new-state actions)
(send-to-user p (e) (transition old-state (quit #f e))
(interruptk old-state)))
(struct-copy process p
[state new-state]
[pending-actions (quasiqueue-append (process-pending-actions p)
(action-tree->quasiqueue actions))]))
;; notify-route-change-self : (All (SNew)
;; (process SNew)
;; (endpoint SNew)
;; (Role -> EndpointEvent)
;; ->
;; (process SNew))
(define (notify-route-change-self pn en flow->notification)
(define endpointso (process-endpoints pn))
(for/fold ([pn pn]) ([eido (in-hash-keys endpointso)])
(define eo (hash-ref endpointso eido))
(cond
[(role-intersection (endpoint-role eo) (endpoint-role en))
=> (lambda (intersecting-topic)
(define flow-toward-o (refine-role (endpoint-role en) intersecting-topic))
(define flow-toward-n (refine-role (endpoint-role eo) intersecting-topic))
(invoke-handler-if-visible (invoke-handler-if-visible pn
eo
flow-toward-o
flow->notification)
en
flow-toward-n
flow->notification))]
[else pn])))
;; notify-route-change-process : (All (SOld SNew)
;; (process SOld)
;; (process SNew)
;; (endpoint SNew)
;; (Role -> EndpointEvent)
;; -> (values (process SOld)
;; (process SNew)))
(define (notify-route-change-process po pn en flow->notification)
(define endpointso (process-endpoints po))
(for/fold ([po po]
[pn pn])
([eido (in-hash-keys endpointso)])
(define eo (hash-ref endpointso eido))
(cond
[(role-intersection (endpoint-role eo) (endpoint-role en))
=> (lambda (intersecting-topic)
(define flow-toward-o (refine-role (endpoint-role en) intersecting-topic))
(define flow-toward-n (refine-role (endpoint-role eo) intersecting-topic))
(values (invoke-handler-if-visible po eo flow-toward-o flow->notification)
(invoke-handler-if-visible pn en flow-toward-n flow->notification)))]
[else
(values po pn)])))
;; invoke-handler-if-visible : (All (State)
;; (process State)
;; (endpoint State)
;; Role
;; (Role -> EndpointEvent)
;; ->
;; (process State))
(define (invoke-handler-if-visible p ep flow flow->notification)
(if (flow-visible? (endpoint-role ep) flow)
(run-ready p (send-to-user p (e) (quit-interruptk e)
((endpoint-handler ep) (flow->notification flow))))
p))
;; notify-route-change-vm : (All (SNew)
;; (process SNew)
;; (endpoint SNew)
;; (Role -> EndpointEvent)
;; vm
;; -> (values (process SNew)
;; vm))
(define (notify-route-change-vm pn en flow->notification state)
(define old-processes (vm-processes state))
(define-values (final-pn new-processes)
(for/fold ([pn (notify-route-change-self pn en flow->notification)]
[new-processes #hash()])
([pid (in-hash-keys old-processes)])
(define wp (hash-ref old-processes pid))
(apply values
(let ((po wp))
(let-values (((po pn) (notify-route-change-process po pn en flow->notification)))
(list pn (hash-set new-processes pid po)))))))
(values final-pn
(struct-copy vm state [processes new-processes])))
;;; Local Variables:
;;; eval: (put 'send-to-user 'scheme-indent-function 3)
;;; End:

45
quasiqueue.rkt
View File

@ -1,45 +0,0 @@
#lang racket/base
(provide empty-quasiqueue
quasiqueue-empty?
quasiqueue-append-list
quasiqueue-append
quasiqueue
list->quasiqueue
quasiqueue->list
quasiqueue->cons-tree)
;; A QuasiQueue<X> is a list of Xs in *reversed* order.
;; (define-type (QuasiQueue X) (Listof X))
;; (define-type (Constreeof X) (Rec CT (U X (Pairof CT CT) False Void Null)))
;; empty-quasiqueue : (All (X) -> (QuasiQueue X))
(define (empty-quasiqueue) '())
;; quasiqueue-empty? : (All (X) (QuasiQueue X) -> Boolean)
(define (quasiqueue-empty? q) (null? q))
;; quasiqueue-append-list : (All (X) (QuasiQueue X) (Listof X) -> (QuasiQueue X))
(define (quasiqueue-append-list q xs)
(append (reverse xs) q))
;; quasiqueue-append : (All (X) (QuasiQueue X) (QuasiQueue X) -> (QuasiQueue X))
(define (quasiqueue-append q1 q2)
(append q2 q1))
;; quasiqueue : (All (X) X * -> (QuasiQueue X))
(define (quasiqueue . xs)
(reverse xs))
;; list->quasiqueue : (All (X) (Listof X) -> (QuasiQueue X))
(define (list->quasiqueue xs)
(reverse xs))
;; quasiqueue->list : (All (X) (QuasiQueue X) -> (Listof X))
(define (quasiqueue->list q)
(reverse q))
;; quasiqueue->cons-tree : (All (X) (QuasiQueue X) -> (Constreeof X))
(define (quasiqueue->cons-tree q)
(reverse q))

245
racket.css Normal file
View File

@ -0,0 +1,245 @@
/* See the beginning of "scribble.css". */
/* Monospace: */
.RktIn, .RktRdr, .RktPn, .RktMeta,
.RktMod, .RktKw, .RktVar, .RktSym,
.RktRes, .RktOut, .RktCmt, .RktVal,
.RktBlk {
font-family: monospace;
white-space: inherit;
}
/* Serif: */
.inheritedlbl {
font-family: serif;
}
/* Sans-serif: */
.RBackgroundLabelInner {
font-family: sans-serif;
}
/* ---------------------------------------- */
/* Inherited methods, left margin */
.inherited {
width: 100%;
margin-top: 0.5em;
text-align: left;
background-color: #ECF5F5;
}
.inherited td {
font-size: 82%;
padding-left: 1em;
text-indent: -0.8em;
padding-right: 0.2em;
}
.inheritedlbl {
font-style: italic;
}
/* ---------------------------------------- */
/* Racket text styles */
.RktIn {
color: #cc6633;
background-color: #eeeeee;
}
.RktInBG {
background-color: #eeeeee;
}
.RktRdr {
}
.RktPn {
color: #843c24;
}
.RktMeta {
color: black;
}
.RktMod {
color: black;
}
.RktOpt {
color: black;
}
.RktKw {
color: black;
}
.RktErr {
color: red;
font-style: italic;
}
.RktVar {
color: #262680;
font-style: italic;
}
.RktSym {
color: #262680;
}
.RktSymDef { /* used with RktSym at def site */
}
.RktValLink {
text-decoration: none;
color: blue;
}
.RktValDef { /* used with RktValLink at def site */
}
.RktModLink {
text-decoration: none;
color: blue;
}
.RktStxLink {
text-decoration: none;
color: black;
}
.RktStxDef { /* used with RktStxLink at def site */
}
.RktRes {
color: #0000af;
}
.RktOut {
color: #960096;
}
.RktCmt {
color: #c2741f;
}
.RktVal {
color: #228b22;
}
/* ---------------------------------------- */
/* Some inline styles */
.together {
width: 100%;
}
.prototype, .argcontract, .RBoxed {
white-space: nowrap;
}
.prototype td {
vertical-align: text-top;
}
.longprototype td {
vertical-align: bottom;
}
.RktBlk {
white-space: inherit;
text-align: left;
}
.RktBlk tr {
white-space: inherit;
}
.RktBlk td {
vertical-align: baseline;
white-space: inherit;
}
.argcontract td {
vertical-align: text-top;
}
.highlighted {
background-color: #ddddff;
}
.defmodule {
width: 100%;
background-color: #F5F5DC;
}
.specgrammar {
float: right;
}
.RBibliography td {
vertical-align: text-top;
}
.leftindent {
margin-left: 1em;
margin-right: 0em;
}
.insetpara {
margin-left: 1em;
margin-right: 1em;
}
.Rfilebox {
}
.Rfiletitle {
text-align: right;
margin: 0em 0em 0em 0em;
}
.Rfilename {
border-top: 1px solid #6C8585;
border-right: 1px solid #6C8585;
padding-left: 0.5em;
padding-right: 0.5em;
background-color: #ECF5F5;
}
.Rfilecontent {
margin: 0em 0em 0em 0em;
}
.RpackageSpec {
padding-right: 0.5em;
}
/* ---------------------------------------- */
/* For background labels */
.RBackgroundLabel {
float: right;
width: 0px;
height: 0px;
}
.RBackgroundLabelInner {
position: relative;
width: 25em;
left: -25.5em;
top: 0px;
text-align: right;
color: white;
z-index: 0;
font-weight: bold;
}
.RForeground {
position: relative;
left: 0px;
top: 0px;
z-index: 1;
}

73
roles.rkt
View File

@ -1,73 +0,0 @@
#lang racket/base
(require racket/match)
(require "structs.rkt")
(require "log.rkt")
(require "unify.rkt")
(provide co-orientations
co-roles
refine-role
roles-equal?
orientations-intersect?
role-intersection
flow-visible?)
;; co-orientations : Orientation -> (Listof Orientation)
(define (co-orientations o)
(match o
['publisher '(subscriber)]
['subscriber '(publisher)]))
;; co-roles : Role -> (Listof Role)
(define (co-roles r)
(for/list ([co-orientation (co-orientations (role-orientation r))])
(struct-copy role r [orientation co-orientation])))
;; refine-role : Role Topic -> Role
(define (refine-role remote-role new-topic)
(struct-copy role remote-role [topic new-topic]))
;; roles-equal? : Role Role -> Boolean
(define (roles-equal? ta tb)
(and (equal? (role-orientation ta) (role-orientation tb))
(equal? (role-interest-type ta) (role-interest-type tb))
(specialization? (role-topic ta) (role-topic tb))
(specialization? (role-topic tb) (role-topic ta))))
;; orientations-intersect? : Orientation Orientation -> Boolean
(define (orientations-intersect? l r)
(and (memq l (co-orientations r)) #t))
;; "Both left and right must be canonicalized." - comment from os2.rkt. What does it mean?
;; role-intersection : Role Role -> (Option Topic)
(define (role-intersection left right)
(define result
(and (orientations-intersect? (role-orientation left) (role-orientation right))
(mgu-canonical (freshen (role-topic left)) (freshen (role-topic right)))))
(marketplace-log 'debug "role-intersection ~v // ~v --> ~v" left right result)
result)
;; True iff the flow between remote-role and local-role should be
;; visible to the local peer. This is the case when either local-role
;; is monitoring 'everything or otherwise if remote-role is a
;; 'participant only.
;;
;; |--------------+--------------+------------------------|
;; | local-role | remote-role | visible to local peer? |
;; |--------------+--------------+------------------------|
;; | 'participant | 'participant | yes |
;; | 'participant | 'observer | no |
;; | 'participant | 'everything | no |
;; | 'observer | 'participant | yes |
;; | 'observer | 'observer | no |
;; | 'observer | 'everything | no |
;; | 'everything | 'participant | yes |
;; | 'everything | 'observer | yes |
;; | 'everything | 'everything | yes |
;; |--------------+--------------+------------------------|
;;
;; flow-visible? : Role Role -> Boolean
(define (flow-visible? local-role remote-role)
(or (eq? (role-interest-type remote-role) 'participant)
(eq? (role-interest-type local-role) 'everything)))

153
scribble-common.js Normal file
View File

@ -0,0 +1,153 @@
// Common functionality for PLT documentation pages
// Page Parameters ------------------------------------------------------------
var page_query_string =
(location.href.search(/\?([^#]+)(?:#|$)/) >= 0) && RegExp.$1;
var page_args =
((function(){
if (!page_query_string) return [];
var args = page_query_string.split(/[&;]/);
for (var i=0; i<args.length; i++) {
var a = args[i];
var p = a.indexOf('=');
if (p >= 0) args[i] = [a.substring(0,p), a.substring(p+1)];
else args[i] = [a, false];
}
return args;
})());
function GetPageArg(key, def) {
for (var i=0; i<page_args.length; i++)
if (page_args[i][0] == key) return unescape(page_args[i][1]);
return def;
}
function MergePageArgsIntoLink(a) {
if (page_args.length == 0 ||
(!a.attributes["data-pltdoc"]) || (a.attributes["data-pltdoc"].value == ""))
return;
a.href.search(/^([^?#]*)(?:\?([^#]*))?(#.*)?$/);
if (RegExp.$2.length == 0) {
a.href = RegExp.$1 + "?" + page_query_string + RegExp.$3;
} else {
// need to merge here, precedence to arguments that exist in `a'
var i, j;
var prefix = RegExp.$1, str = RegExp.$2, suffix = RegExp.$3;
var args = str.split(/[&;]/);
for (i=0; i<args.length; i++) {
j = args[i].indexOf('=');
if (j) args[i] = args[i].substring(0,j);
}
var additions = "";
for (i=0; i<page_args.length; i++) {
var exists = false;
for (j=0; j<args.length; j++)
if (args[j] == page_args[i][0]) { exists = true; break; }
if (!exists) str += "&" + page_args[i][0] + "=" + page_args[i][1];
}
a.href = prefix + "?" + str + suffix;
}
}
// Cookies --------------------------------------------------------------------
function GetCookie(key, def) {
var i, cookiestrs;
try {
if (document.cookie.length <= 0) return def;
cookiestrs = document.cookie.split(/; */);
} catch (e) { return def; }
for (i = 0; i < cookiestrs.length; i++) {
var cur = cookiestrs[i];
var eql = cur.indexOf('=');
if (eql >= 0 && cur.substring(0,eql) == key)
return unescape(cur.substring(eql+1));
}
return def;
}
function SetCookie(key, val) {
var d = new Date();
d.setTime(d.getTime()+(365*24*60*60*1000));
try {
document.cookie =
key + "=" + escape(val) + "; expires="+ d.toGMTString() + "; path=/";
} catch (e) {}
}
// note that this always stores a directory name, ending with a "/"
function SetPLTRoot(ver, relative) {
var root = location.protocol + "//" + location.host
+ NormalizePath(location.pathname.replace(/[^\/]*$/, relative));
SetCookie("PLT_Root."+ver, root);
}
// adding index.html works because of the above
function GotoPLTRoot(ver, relative) {
var u = GetCookie("PLT_Root."+ver, null);
if (u == null) return true; // no cookie: use plain up link
// the relative path is optional, default goes to the toplevel start page
if (!relative) relative = "index.html";
location = u + relative;
return false;
}
// Utilities ------------------------------------------------------------------
var normalize_rxs = [/\/\/+/g, /\/\.(\/|$)/, /\/[^\/]*\/\.\.(\/|$)/];
function NormalizePath(path) {
var tmp, i;
for (i = 0; i < normalize_rxs.length; i++)
while ((tmp = path.replace(normalize_rxs[i], "/")) != path) path = tmp;
return path;
}
// `noscript' is problematic in some browsers (always renders as a
// block), use this hack instead (does not always work!)
// document.write("<style>mynoscript { display:none; }</style>");
// Interactions ---------------------------------------------------------------
function DoSearchKey(event, field, ver, top_path) {
var val = field.value;
if (event && event.keyCode == 13) {
var u = GetCookie("PLT_Root."+ver, null);
if (u == null) u = top_path; // default: go to the top path
u += "search/index.html?q=" + escape(val);
if (page_query_string) u += "&" + page_query_string;
location = u;
return false;
}
return true;
}
function TocviewToggle(glyph, id) {
var s = document.getElementById(id).style;
var expand = s.display == "none";
s.display = expand ? "block" : "none";
glyph.innerHTML = expand ? "&#9660;" : "&#9658;";
}
// Page Init ------------------------------------------------------------------
// Note: could make a function that inspects and uses window.onload to chain to
// a previous one, but this file needs to be required first anyway, since it
// contains utilities for all other files.
var on_load_funcs = [];
function AddOnLoad(fun) { on_load_funcs.push(fun); }
window.onload = function() {
for (var i=0; i<on_load_funcs.length; i++) on_load_funcs[i]();
};
AddOnLoad(function(){
var links = document.getElementsByTagName("a");
for (var i=0; i<links.length; i++) MergePageArgsIntoLink(links[i]);
var label = GetPageArg("ctxtname",false);
if (!label) return;
var indicator = document.getElementById("contextindicator");
if (!indicator) return;
indicator.innerHTML = label;
indicator.style.display = "block";
});

480
scribble.css Normal file
View File

@ -0,0 +1,480 @@
/* This file is used by default by all Scribble documents.
See also "manual.css", which is added by default by the
`scribble/manual` language. */
/* CSS seems backward: List all the classes for which we want a
particular font, so that the font can be changed in one place. (It
would be nicer to reference a font definition from all the places
that we want it.)
As you read the rest of the file, remember to double-check here to
see if any font is set. */
/* Monospace: */
.maincolumn, .refpara, .refelem, .tocset, .stt, .hspace, .refparaleft, .refelemleft {
font-family: monospace;
}
/* Serif: */
.main, .refcontent, .tocview, .tocsub, .sroman, i {
font-family: serif;
}
/* Sans-serif: */
.version, .versionNoNav, .ssansserif {
font-family: sans-serif;
}
.ssansserif {
font-size: 80%;
font-weight: bold;
}
/* ---------------------------------------- */
p, .SIntrapara {
display: block;
margin: 1em 0;
}
h2 { /* per-page main title */
margin-top: 0;
}
h3, h4, h5, h6, h7, h8 {
margin-top: 1.75em;
margin-bottom: 0.5em;
}
.SSubSubSubSection {
font-weight: bold;
font-size: 0.83em; /* should match h5; from HTML 4 reference */
}
/* Needed for browsers like Opera, and eventually for HTML 4 conformance.
This means that multiple paragraphs in a table element do not have a space
between them. */
table p {
margin-top: 0;
margin-bottom: 0;
}
/* ---------------------------------------- */
/* Main */
body {
color: black;
background-color: #ffffff;
}
table td {
padding-left: 0;
padding-right: 0;
}
.maincolumn {
width: 43em;
margin-right: -40em;
margin-left: 15em;
}
.main {
text-align: left;
}
/* ---------------------------------------- */
/* Navigation */
.navsettop, .navsetbottom {
background-color: #f0f0e0;
padding: 0.25em 0 0.25em 0;
}
.navsettop {
margin-bottom: 1.5em;
border-bottom: 2px solid #e0e0c0;
}
.navsetbottom {
margin-top: 2em;
border-top: 2px solid #e0e0c0;
}
.navleft {
margin-left: 1ex;
position: relative;
float: left;
white-space: nowrap;
}
.navright {
margin-right: 1ex;
position: relative;
float: right;
white-space: nowrap;
}
.nonavigation {
color: #e0e0e0;
}
.searchform {
display: inline;
margin: 0;
padding: 0;
}
.searchbox {
width: 16em;
margin: 0px;
padding: 0px;
background-color: #eee;
border: 1px solid #ddd;
text-align: center;
vertical-align: middle;
}
#contextindicator {
position: fixed;
background-color: #c6f;
color: #000;
font-family: monospace;
font-weight: bold;
padding: 2px 10px;
display: none;
right: 0;
bottom: 0;
}
/* ---------------------------------------- */
/* Version */
.versionbox {
position: relative;
float: right;
left: 2em;
height: 0em;
width: 13em;
margin: 0em -13em 0em 0em;
}
.version {
font-size: small;
}
.versionNoNav {
font-size: xx-small; /* avoid overlap with author */
}
.version:before, .versionNoNav:before {
content: "Version ";
}
/* ---------------------------------------- */
/* Margin notes */
.refpara, .refelem {
position: relative;
float: right;
left: 2em;
height: 0em;
width: 13em;
margin: 0em -13em 0em 0em;
}
.refpara, .refparaleft {
top: -1em;
}
.refcolumn {
background-color: #F5F5DC;
display: block;
position: relative;
width: 13em;
font-size: 85%;
border: 0.5em solid #F5F5DC;
margin: 0 0 0 0;
}
.refcontent {
margin: 0 0 0 0;
}
.refcontent p {
margin-top: 0;
margin-bottom: 0;
}
.refparaleft, .refelemleft {
position: relative;
float: left;
right: 2em;
height: 0em;
width: 13em;
margin: 0em 0em 0em -13em;
}
.refcolumnleft {
background-color: #F5F5DC;
display: block;
position: relative;
width: 13em;
font-size: 85%;
border: 0.5em solid #F5F5DC;
margin: 0 0 0 0;
}
/* ---------------------------------------- */
/* Table of contents, inline */
.toclink {
text-decoration: none;
color: blue;
font-size: 85%;
}
.toptoclink {
text-decoration: none;
color: blue;
font-weight: bold;
}
/* ---------------------------------------- */
/* Table of contents, left margin */
.tocset {
position: relative;
float: left;
width: 12.5em;
margin-right: 2em;
}
.tocset td {
vertical-align: text-top;
}
.tocview {
text-align: left;
background-color: #f0f0e0;
}
.tocsub {
text-align: left;
margin-top: 0.5em;
background-color: #f0f0e0;
}
.tocviewlist, .tocsublist {
margin-left: 0.2em;
margin-right: 0.2em;
padding-top: 0.2em;
padding-bottom: 0.2em;
}
.tocviewlist table {
font-size: 82%;
}
.tocviewlisttopspace {
margin-bottom: 1em;
}
.tocviewsublist, .tocviewsublistonly, .tocviewsublisttop, .tocviewsublistbottom {
margin-left: 0.4em;
border-left: 1px solid #bbf;
padding-left: 0.8em;
}
.tocviewsublist {
margin-bottom: 1em;
}
.tocviewsublist table,
.tocviewsublistonly table,
.tocviewsublisttop table,
.tocviewsublistbottom table {
font-size: 75%;
}
.tocviewtitle * {
font-weight: bold;
}
.tocviewlink {
text-decoration: none;
color: blue;
}
.tocviewselflink {
text-decoration: underline;
color: blue;
}
.tocviewtoggle {
text-decoration: none;
color: blue;
font-size: 75%; /* looks better, and avoids bounce when toggling sub-sections due to font alignments */
}
.tocsublist td {
padding-left: 1em;
text-indent: -1em;
}
.tocsublinknumber {
font-size: 82%;
}
.tocsublink {
font-size: 82%;
text-decoration: none;
}
.tocsubseclink {
font-size: 82%;
text-decoration: none;
}
.tocsubnonseclink {
font-size: 82%;
text-decoration: none;
padding-left: 0.5em;
}
.tocsubtitle {
font-size: 82%;
font-style: italic;
margin: 0.2em;
}
/* ---------------------------------------- */
/* Some inline styles */
.indexlink {
text-decoration: none;
}
.nobreak {
white-space: nowrap;
}
pre { margin-left: 2em; }
blockquote { margin-left: 2em; }
ol { list-style-type: decimal; }
ol ol { list-style-type: lower-alpha; }
ol ol ol { list-style-type: lower-roman; }
ol ol ol ol { list-style-type: upper-alpha; }
.SCodeFlow {
display: block;
margin-left: 1em;
margin-bottom: 0em;
margin-right: 1em;
margin-top: 0em;
white-space: nowrap;
}
.SVInsetFlow {
display: block;
margin-left: 0em;
margin-bottom: 0em;
margin-right: 0em;
margin-top: 0em;
}
.SubFlow {
display: block;
margin: 0em;
}
.boxed {
width: 100%;
background-color: #E8E8FF;
}
.hspace {
}
.slant {
font-style: oblique;
}
.badlink {
text-decoration: underline;
color: red;
}
.plainlink {
text-decoration: none;
color: blue;
}
.techoutside { text-decoration: underline; color: #b0b0b0; }
.techoutside:hover { text-decoration: underline; color: blue; }
/* .techinside:hover doesn't work with FF, .techinside:hover>
.techinside doesn't work with IE, so use both (and IE doesn't
work with inherit in the second one, so use blue directly) */
.techinside { color: black; }
.techinside:hover { color: blue; }
.techoutside:hover>.techinside { color: inherit; }
.SCentered {
text-align: center;
}
.imageleft {
float: left;
margin-right: 0.3em;
}
.Smaller {
font-size: 82%;
}
.Larger {
font-size: 122%;
}
/* A hack, inserted to break some Scheme ids: */
.mywbr {
display: inline-block;
height: 0;
width: 0;
font-size: 1px;
}
.compact li p {
margin: 0em;
padding: 0em;
}
.noborder img {
border: 0;
}
.SAuthorListBox {
position: relative;
float: right;
left: 2em;
top: -2.5em;
height: 0em;
width: 13em;
margin: 0em -13em 0em 0em;
}
.SAuthorList {
font-size: 82%;
}
.SAuthorList:before {
content: "by ";
}
.author {
display: inline;
white-space: nowrap;
}
/* print styles : hide the navigation elements */
@media print {
.tocset,
.navsettop,
.navsetbottom { display: none; }
.maincolumn {
width: auto;
margin-right: 13em;
margin-left: 0;
}
}

1
scribblings/.gitignore vendored
View File

@ -1 +0,0 @@
out/

29
scribblings/Makefile
View File

@ -1,29 +0,0 @@
all: out
pages:
@(git branch -v | grep -q gh-pages || (echo local gh-pages branch missing; false))
@echo
@git branch -av | grep gh-pages
@echo
@(echo 'Is the branch up to date? Press enter to continue.'; read dummy)
git clone -b gh-pages .. pages
publish: out pages
rm -rf pages/*
cp -r out/marketplace/. pages/.
(cd pages; git add -A)
-(cd pages; git commit -m "Update $$(date +%Y%m%d%H%M%S)")
(cd pages; git push)
rm -rf pages
out:
raco scribble \
--htmls \
--dest out \
++main-xref-in \
--redirect-main http://docs.racket-lang.org/ \
\
marketplace.scrbl
clean:
rm -rf out

115
scribblings/background.scrbl
View File

@ -1,115 +0,0 @@
#lang scribble/manual
@require[racket/include]
@include{prelude.inc}
@title{Background}
@section{Network programming in the small}
Even the simplest of programs can be seen as a network. This program
sends a message containing @racket[3] and @racket[4] to @racket[+],
and awaits a reply message, which contains @racket[7]:
@interaction[(+ 3 4)]
Subroutines are network services. Here, when the message @racket[3] is
sent to @racket[add-four-to], it delegates to @racket[+]:
@interaction[(define (add-four-to n) (+ n 4))
(add-four-to 3)]
@note{In π-calculus encodings of programs, replication and state are
made explicit.} Immutable programs (of which stateless programs are a
special case) are easily able to be @emph{replicated}; programs using
mutable state, however, must be fixed in place. In fact, strictly
speaking, it is the @emph{state} that must be fixed in place, not the
program @emph{manipulating} the state. In the following program, the
mutable @racket[total] variable must not be replicated:
@interaction[(define accumulate
(let ((total 0))
(lambda (n)
(set! total (+ total n))
total)))
(accumulate 3)
(accumulate 4)
(accumulate 0)]
It would be a mistake to simply replace each occurrence of
@racket[accumulate] with its definition, since three separate
@racket[total] locations would be created. However, there is no
problem replicating the @racket[lambda] term, so long as
@racket[total] always refers to the same location:
@interaction[(define total 0)
((lambda (n) (set! total (+ total n)) total) 3)
((lambda (n) (set! total (+ total n)) total) 4)
((lambda (n) (set! total (+ total n)) total) 0)]
Programs raise exceptions to signal partial failure:
@interaction[(define accumulate
(let ((total 0))
(lambda (n)
(when (negative? n)
(error 'accumulate "n must be non-negative!"))
(set! total (+ total n))
total)))
(accumulate 3)
(accumulate -2)]
Programs can handle exceptions to @emph{contain} partial failure:
@interaction[(with-handlers ([exn:fail? (lambda (e) 'ok)])
(error 'oh-dear))]
Partial failures interact with shared, mutable state in unpredictable
ways, especially in larger programs that combine stateful subprograms.
@note{For a good overview of PL-based approaches to security and
trust, see Mark S. Miller's
"@hyperlink["http://www.erights.org/talks/thesis/markm-thesis.pdf"]{Robust
composition: Towards a unified approach to access control and
concurrency control}" and Jonathan A. Rees's
"@hyperlink["http://dspace.mit.edu/bitstream/handle/1721.1/5944/AIM-1564.pdf"]{A
Security Kernel Based on the Lambda-Calculus}".} Programmers often
ignore issues of security and trust between subprograms within a
larger program. Most programming languages entirely lack any means of
securely isolating subprograms from each other, leading to predictable
failures. Even memory-safe languages such as Racket, Java and .NET
only offer weak techniques for securely composing mutually suspicious
subprograms. Techniques such as avoiding @emph{ambient authority} and
using @emph{object capabilities} to compose subprograms
TODO ^
@section{Network programming in the large}
Programs which engage in I/O are very obviously part of a network:
@racketblock[(define (greet-user)
(define username (read-line))
(define greeting (format "Hello, ~a!\n" username))
(display greeting)
(newline))
(greet-user)]
Here, the network has two components: the program, and the user at the
terminal.
But look closely! There is a difference here between the kind of
communication between this program and its @emph{peer} and the
communication @emph{internal} to the program itself. Portions of the
program relay information from the outside world, translating it to
and from an internal representation as they go, while other portions
perform computations on the relayed information.
@vm-figure[(vm (vm-label "Operating System")
(network-label "")
(process "User")
(process-space)
(vm (vm-label "Program")
(network-label "")
(process "Read line")
(process "Format greeting")
(process "Print greeting")))]

254
scribblings/concepts.scrbl
View File

@ -1,254 +0,0 @@
#lang scribble/manual
@require[racket/include]
@include{prelude.inc}
@title{Concepts}
Marketplace integrates ideas from both distributed systems and
virtualized operating system designs to obtain an architecture of
nested @emph{virtual machines} (VMs). Each nested layer is equipped
with its own publish/subscribe network that also propagates
@emph{presence} information about the (dis)appearance of services.
Throughout this manual, diagrams such as the following will illustrate
various process structures:
@vm-figure[(vm (vm-label "Ground Virtual Machine")
(network-label "Ground-level Network Language")
(process "A Process")
(process "Another Process")
(parameterize ((process-height (* 2/3 (process-height)))
(vm-height (* 2 (vm-height))))
(vm (vc-append (vm-label "Nested VMs are")
(vm-label "processes too"))
(network-label "App-specific language")
(process "Process")
(process "Process")
(process "Process")))
(parameterize ((process-height (* 5/4 (process-height))))
(process "Yet another process"))
(parameterize ((process-height (* 2/3 (process-height))))
(vm (vm-label "Another Nested VM")
(network-label "Another language")
(process "Process")
(process "Process"))))]
Rectangular boxes represent VMs. The processes running within each VM
are placed atop its box. The narrow rectangular strip at the top of
each VM's box represents the network connecting all the VM's processes
to each other; it will frequently contain a short description of the
protocols used for communication across the represented network.
A central feature of Marketplace is that VMs are nothing more than
regular processes, making them recursively nestable. Each VM supports
a collection of processes all its own, and its internal IPC medium
carries a VM-specific protocol that is often different from the
protocol spoken by its containing VM.
The outermost VM is called the @emph{ground VM}. The protocol spoken
by processes running within the ground VM is a simple protocol
relating Racket's @tech{synchronizable events} to Marketplace network
messages. See @;{@secref{writing-new-drivers} and} @secref{Drivers} for
information on using Racket events from Marketplace programs.
@section{What is a process, what are event handlers?}
A Marketplace @deftech{process} is a collection of @deftech{event
handlers}, plus a piece of private @deftech{process state}. Every
process@note{The exception to this rule is the Ground VM, which plays
a special role.} runs within a containing VM.
When an event occurs that is relevant to a process, one of its event
handlers is called with the process's current state and a description
of the event. The handler is expected to return an updated state value
and a collection of actions for the containing VM to perform. An event
handler, then, has the following approximate type:
@centered{@italic{State} × @italic{Event} → @italic{State} × (Listof @italic{Action})}
Event handlers are registered with the VM by creating @tech{endpoints}
using the @racket[endpoint] macro (described in @secref{endpoint-dsl}) or
the low-level @racket[add-endpoint] structure (described in
@secref{endpoints-and-messages}).
@deftech{Events}, passed to event handlers, describe the results of
actions from the outside world, neighbouring processes in the VM, or
the VM itself. They are implemented as @racket[struct]s. See
@secref{endpoint-events} for a description of the available event
structures.
@deftech{Actions}, passed back to the VM by event handlers, describe
actions the process wishes to perform. See @secref{Actions} for the
possible actions a process can take.
Note that the result of an event handler function is actually a
@racket[transition] structure containing a new state and a sequence of
actions, rather than the explicit pair shown in the approximate type
above. See @secref{handler-functions} for more on handler functions.
@section{What is a VM?}
@deftech[#:key "vm"]{Virtual Machines (VMs)} are simply a collection
of processes, plus a shared medium of communication that the contained
processes use to communicate with each other. VMs offer access to both
their own @emph{internal} network as well as to the @emph{external}
network owned by the VM's own containing VM.@note{Again, the only
exception here is the Ground VM, which interfaces to the underlying
Racket system and so has no containing VM.}
@section{Endpoints: Subscription and Advertisement}
The Marketplace operating system's inter-process communication
facility is structured around @deftech[#:key
"pub/sub"]{publish/subscribe (pub/sub)} messaging.@note{For a survey
of pub/sub messaging, see
@hyperlink["http://www.cs.ru.nl/~pieter/oss/manyfaces.pdf"]{"The Many
Faces of Publish/Subscribe"}, ACM Computing Surveys, Vol. 35, No. 2,
June 2003, pp. 114–131. There's also plenty out there on the Internet;
a good starting point is to google for
@hyperlink["https://www.google.com/search?q=pub/sub message-oriented middleware"]{pub/sub message-oriented middleware}.}
@deftech{Endpoints} are the representation of a process's engagement
in some protocol. They pair a description of the process's @tech{role}
in a conversation with an @tech{event handler} that responds to events
relating to that role.
A @deftech{role} describes the role some process is playing in a
conversation. Concretely, roles are represented by @racket[Role]
structures. A role can be used by the currently-running process to
describe some role it wishes to play, or can be carried in some
@racket[EndpointEvent] to describe the role some @emph{peer} process
is playing in a conversation.
Roles have three parts:
@itemlist[
@item{An @deftech{orientation} (type @racket[Orientation]) describes
whether this role is concerned primarily with @emph{producing} or
@emph{consuming} messages.}
@item{A @deftech{topic} is a @deftech{pattern} over messages. Topics
perform double duty: they both scope conversations and filter
incoming messages. More on topics below.}
@item{An @deftech{interest-type} (type @racket[InterestType])
determines whether the endpoint playing the given role is genuinely
a participant in matching conversations or is simply observing the
real participants. See @secref{endpoint-dsl} for more on
interest-types.}
]
@section[#:tag "messages-and-topics"]{Messages and Topics}
@declare-exporting[marketplace]
@deftech{Messages} are simply Racket data structures. They can be any
value for which @racket[equal?] is defined, any @racket[#:prefab]
structure, most @racket[#:transparent] structures, or any non-object
structure for which @racket[prop:struct-map] can be defined.
As mentioned above, topics are simply patterns over messages. They are
represented as normal data structures @emph{with embedded wildcards}.
Use @racket[?] or @racket[(wild)] to construct a wildcard. For
example, given the following definition,
@racketblock[(struct chat-message (speaker text) #:transparent)]
we can not only create instances that might be used with
@racket[send-message],
@racketblock[(chat-message "Tony" "Hello World!")]
but also create topic patterns using @racket[?]. For example, this
pattern matches anything said by @racket["Tony"]:
@racketblock[(chat-message "Tony" ?)]
This pattern matches chat-messages sent by anyone saying "Hello":
@racketblock[(chat-message ? "Hello")]
And finally, this pattern matches any chat-message at all:
@racketblock[(chat-message ? ?)]
Patterns can be nested. For instance, given the above definition of
@racket[chat-message], the following pattern matches any chat message
greeting anybody at all:
@racketblock[(struct greeting (target) #:transparent)
(chat-message ? (greeting ?))]
@section{Presence}
@deftech{Presence} (respectively its opposite, @deftech{absence}) is
an indication that a matching conversational partner exists (resp. no
longer exists) in the network. Presence can be used to synchronize
conversations, setting up a conversational context before messages are
sent.
The term "presence" itself is lifted from Instant Messaging protocols
like XMPP, where it describes the online/offline status of one's chat
buddies. Here, it describes the online/offline status of peer
processes, in terms of which conversations they are willing to engage
in.
The system derives presence information from the set of active pub/sub
subscription and advertisement endpoints a process has created.
Creating a new endpoint with a topic pattern that matches some other
process's endpoint and an orientation @emph{opposite} to the other
process's endpoint causes @racket[presence-event]s to be sent to both
endpoints, informing them of the presence of the other. When a process
crashes, or an endpoint is withdrawn with @racket[delete-endpoint], a
corresponding @racket[absence-event] is sent to the remaining
endpoint.
@section{Nesting, relaying, and levels of discourse}
Because VMs can be nested, and each VM has an IPC network of its own
for the use of its processes, information sometimes needs to be
relayed from a VM's external network to its internal network and vice
versa.
In general, the protocol messages sent across a VM's internal network
may be quite different in syntax and meaning from those sent across
the same VM's external network: consider the case of the
@secref{chat-server-example}, which employs a nested VM to separate
out TCP-related messages from higher-level, application-specific chat
messages:
@vm-figure[(vm (vm-label "Ground VM")
(network-label "TCP")
(process "TCP driver")
(process "TCP listener")
(process-space)
(process "TCP socket mgr.")
(process "TCP socket mgr.")
(process-ellipsis)
(process-space)
(vm (vm-label "Nested VM")
(network-label "(X says Y)")
(process "Listener")
(process-space)
(process "Chat session")
(process "Chat session")
(process-ellipsis)))]
Each VM's network corresponds to a distinct @emph{level of discourse}.
The nesting of VMs is then roughly analogous to the layering of
network protocol stacks. For example (and purely hypothetically!) the
TCP-IP/HTTP/Webapp stack could perhaps be represented as
@vm-figure[(vm (vm-label "Ground VM")
(network-label "TCP/IP")
(process "TCP driver")
(vm (vm-label "HTTP VM")
(network-label "HTTP sessions/reqs/reps")
(process "HTTP accepter")
(vm (vm-label "Session VM")
(network-label "Session-specific msgs")
(process "App process")
(process-ellipsis))
(process-ellipsis)))]

209
scribblings/drivers.scrbl
View File

@ -1,209 +0,0 @@
#lang scribble/manual
@require[racket/include]
@include{prelude.inc}
@require[(for-label marketplace/drivers/event-relay
marketplace/drivers/tcp-bare)]
@title{Drivers}
@section{event-relay}
@defmodule[marketplace/drivers/event-relay]{
@defproc[(event-relay [self-id Symbol]) Spawn]{
Lets processes in some nested VM interact with the outside
world using @racket[ground-vm]-level event-based subscriptions.
Returns a @racket[spawn] which starts an event-relay process with
debug-name @racket[`(event-relay ,self-id)].
The relay process observes subscriptions matching the topic-pattern
@racket[(cons (? evt?) _)], and when one appears, constructs an
analogous one using @racket[at-meta-level] to connect to the next VM
down the stack. Messages from the meta-level will be relayed up to the
current level. When the subscription disappears, the relay withdraws
the subscription at the meta-level as well.
}
}
@section{tcp-bare}
@defmodule[marketplace/drivers/tcp-bare]{
This module is included by default in programs using @tt{#lang
marketplace}; see @secref{hashlang-variations} for information on
other language variants.
@defproc[(tcp-driver) Spawn]{
Returns a @racket[spawn] action which starts a TCP driver. The TCP
driver should run either directly in a ground VM, or in a nested VM
with a running @racket[event-relay].
}
@defthing[tcp Spawn]{
A pre-made @racket[spawn] action equivalent to @racket[(tcp-driver)].
}
}
@subsection{TCP channels}
@defstruct*[tcp-channel ([source (or/c tcp-address? tcp-handle? tcp-listener?)]
[destination (or/c tcp-address? tcp-handle? tcp-listener?)]
[subpacket (or/c eof-object? bytes?)]) #:prefab]{
A TCP channel represents a section of a unidirectional TCP flow
appearing on our local "subnet" of the full TCP network, complete with
source, destination and subpacket. Each TCP connection has two such
flows: one inbound (remote-to-local) bytestream, and one outbound
(local-to-remote) bytestream.
Packets carried by @racket[tcp-channel] structures are either
end-of-file objects or raw binary data represented as Racket byte
vectors.
}
@subsection{TCP addresses}
A TCP address describes one end of a TCP connection. It can be either
@itemlist[
@item{a @racket[tcp-address], representing a remote socket;}
@item{a @racket[tcp-handle], representing a local socket on a kernel-assigned port; or}
@item{a @racket[tcp-listener], representing a local socket on a user-assigned port.}
]
@defstruct*[tcp-address ([host string?]
[port (integer-in 0 65535)]) #:prefab]{
Describes a remote half-connection. The @racket[host] part is to be a
string containing either a hostname (e.g. @racket["localhost"]) or an
ASCII representation of an IP address (e.g. @racket["127.0.0.1"]).
}
@defstruct*[tcp-handle ([id any/c]) #:prefab]{
Describes a local half-connection with a kernel-assigned port number.
The port number is not directly accessible; the @racket[id] is used as
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
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
used in @racket[tcp-channel] to mean a specific @emph{instance} of a TCP
connection, so if you are likely to want to reconnect individual
flows, use different values for @racket[id].
}
@defstruct*[tcp-listener ([port (integer-in 0 65535)]) #:prefab]{
Describes a local half-connection with a user-assigned port number.
Use this to describe server sockets.
}
@subsection{Opening an outbound connection}
Choose a @racket[tcp-handle], and then create endpoints as follows:
@racketblock[
(let ((local (tcp-handle 'some-unique-value))
(remote (tcp-address "the.remote.host.example.com" 5999)))
(transition/no-state
(publisher (tcp-channel local remote ?))
(subscriber (tcp-channel remote local ?)
(on-message
[(tcp-channel _ _ (? eof-object?))
(code:comment "Handle a received end-of-file object")
(transition ...)]
[(tcp-channel _ _ (? bytes? data))
(code:comment "Handle received data")
(transition ...)]))))
]
The TCP driver will automatically create an outbound connection in
response to the presence of the endpoints. When the endpoints are
deleted (or the process exits), the TCP driver will notice the absence
and will close the underlying TCP socket.
For a complete example, see @secref{chat-client-example}.
@subsection{Accepting inbound connections}
Choose a port number, and then create an @emph{observer} endpoint as
follows:
@racketblock[
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
(match-conversation (tcp-channel them us _)
(on-presence (spawn (chat-session them us)))))
]
The use of @racket[observe-publishers] here indicates that this endpoint isn't
actually interested in exchanging any TCP data; instead, it is
monitoring demand for such exchanges. The TCP driver uses the unusual
@racket['everything] @racket[InterestType] to monitor the presence of
@racket['observer]s, and creates listening TCP server sockets in
response. When a connection comes in, the TCP driver spawns a manager
process which offers regular @racket['participant] endpoints for
communicating on the newly-arrived socket.
To illustrate the code for handling a newly-arrived connection,
@racketblock[
(define (chat-session them us)
(transition/no-state
(subscriber (tcp-channel them us ?)
(on-absence (quit))
(on-message [(tcp-channel _ _ (? bytes? data))
(code:comment "Handle incoming data")
(transition ...)]))))
]
@subsection{Receiving data}
TCP-related messages will be of the form
@racketblock[(tcp-channel remote-address local-address subpacket)]
where the @racket[subpacket] is either @racket[eof] or a
@racket[bytes?].
@subsection{Sending data}
Send data with
@racketblock[(send-message (tcp-channel local-address remote-address subpacket))]
where, as for receiving data, the @racket[subpacket] is either
@racket[eof] or a @racket[bytes?].
@;{
@section{tcp}
Not yet documented.
}
@section{timer}
For examples of the use of the timer driver, see uses of
@racket[set-timer] and @racket[timer-expired] in
@hyperlink["https://github.com/tonyg/marketplace-dns/blob/master/network-query.rkt"]{the
Marketplace-based DNS resolver}.
@section{udp}
For examples of the use of the UDP driver, see uses of
@racket[udp-packet] etc. in
@hyperlink["https://github.com/tonyg/marketplace-dns/blob/master/tk-dns.rkt"]{the
Marketplace-based DNS resolver}.

139
scribblings/examples.scrbl
View File

@ -1,139 +0,0 @@
#lang scribble/manual
@require[racket/include]
@include{prelude.inc}
@title{Examples}
@section[#:tag "echo-server-example"]{TCP echo server}
Here is a complete Marketplace program:
@#reader scribble/comment-reader (racketmod #:file "examples/echo-paper.rkt" marketplace
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
(match-conversation (tcp-channel from to _)
(on-presence (spawn (echoer from to)))))
(define (echoer from to)
(transition stateless
(publisher (tcp-channel to from ?))
(subscriber (tcp-channel from to ?)
(on-absence (quit))
(on-message
[(tcp-channel _ _ data)
(send-message (tcp-channel to from data))]))))
)
The top-level @racket[observe-publishers] monitors TCP connections
arriving on port 5999 and @racket[spawn]s a fresh process in response
to each with the help of the auxiliary @racket[echoer] function. The
topic of conversation associated with the each new connection is
parsed (with @racket[match-conversation]) to name the remote
(@racket[from]) and local (@racket[to]) TCP addresses, which are
passed to @racket[echoer] to create the initial state and actions for
the corresponding process. In this case, the process is stateless,
indicated by the special constant @racket[stateless].
Each connection's process watches for incoming data, using
@racket[from] and @racket[to] to configure a @racket[subscriber]. It
also declares its intent to produce outbound TCP data, using
@racket[publisher]. When data arrives, it is echoed back to the remote
peer using the @racket[send-message] operation. Absence notifications
signal disconnection; when the remote peer closes the TCP connection,
the @racket[on-absence] handler issues a @racket[quit] action, which
terminates the connection's process.
@section[#:tag "chat-server-example"]{TCP chat server}
@#reader scribble/comment-reader (racketmod #:file "examples/chat-paper.rkt" marketplace
(spawn-vm
(at-meta-level
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
(match-conversation (tcp-channel them us _)
(on-presence (spawn (chat-session them us)))))))
(define (chat-session them us)
(define user (gensym 'user))
(transition stateless
(listen-to-user user them us)
(speak-to-user user them us)))
(define (listen-to-user user them us)
(list
(at-meta-level
(subscriber (tcp-channel them us ?)
(on-absence (quit))
(on-message
[(tcp-channel _ _ (? bytes? text))
(send-message `(,user says ,text))])))
(publisher `(,user says ,?))))
(define (speak-to-user user them us)
(define (say fmt . args)
(at-meta-level
(send-message
(tcp-channel us them (apply format fmt args)))))
(define (announce who did-what)
(unless (equal? who user)
(say "~s ~s.~n" who did-what)))
(list
(say "You are ~s.~n" user)
(at-meta-level
(publisher (tcp-channel us them ?)))
(subscriber `(,? says ,?)
(match-conversation `(,who says ,_)
(on-presence (announce who 'arrived))
(on-absence (announce who 'departed))
(on-message [`(,who says ,what)
(say "~a: ~a" who what)])))))
)
@section[#:tag "chat-client-example"]{TCP chat client}
@#reader scribble/comment-reader (racketmod #:file "examples/chat-client.rkt" marketplace
(require racket/port)
;; Usually it's OK to just use display and friends directly.
;; Here we have a console output driver just to show how it's done.
(name-process 'console-output-driver
(spawn (transition/no-state
(subscriber (list 'console-output ?)
(on-message [(list 'console-output item)
(printf "~a" item)
(void)])))))
(name-process 'console-input-driver
(spawn (transition/no-state
(name-endpoint 'input-relay
(publisher (list 'console-input ?)
(on-absence
(send-message (list 'console-output "Connection terminated.\n"))
(quit))))
(subscriber (cons (read-line-evt (current-input-port) 'any) ?)
(on-message
[(cons _ (? eof-object?))
(send-message (list 'console-output "Terminating on local EOF.\n"))
(delete-endpoint 'input-relay)]
[(cons _ (? string? line))
(send-message (list 'console-input line))])))))
(name-process 'outbound-connection
(spawn (let ((local (tcp-handle 'outbound))
(remote (tcp-address "localhost" 5999)))
(transition/no-state
(subscriber (list 'console-input ?)
(on-absence (quit))
(on-message
[(list 'console-input line)
(send-message (list 'console-output (format "> ~a \n" line)))
(send-message (tcp-channel local remote (string-append line "\n")))]))
(publisher (tcp-channel local remote ?))
(subscriber (tcp-channel remote local ?)
(on-absence (quit))
(on-message
[(tcp-channel _ _ (? eof-object?))
(quit)]
[(tcp-channel _ _ data)
(send-message (list 'console-output (format "< ~a" data)))]))))))
)

12
scribblings/from.rkt
View File

@ -1,12 +0,0 @@
#lang racket/base
;; Provides |from|, useful for importing identifiers from non-default
;; contexts without spelling them differently.
(require scribble/decode)
(provide from)
(define-syntax-rule (from require-spec pre-content ...)
(let ()
(local-require require-spec)
(splice (list pre-content ...))))

677
scribblings/highlevel.scrbl
View File

@ -1,677 +0,0 @@
#lang scribble/manual
@require[racket/include]
@include{prelude.inc}
@title[#:tag "high-level-interface"]{High-level interface}
@declare-exporting[#:use-sources (marketplace/sugar)]
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
@secref{low-level-interface} corresponds to the @emph{system call
interface} of a Unix-like operating system.
@section[#:tag "hashlang-variations"]{Using @tt{#lang marketplace} and friends}
@;{
@defmodulelang*[(marketplace
marketplace/flow-control)]
}
@defmodulelang[marketplace]
Programs written for Marketplace differ from normal Racket modules
only in their selection of language. A Racket module written with
@tt{#lang marketplace}, such as the echo server in
@secref["echo-server-example"], specifies a sequence of definitions
and startup @tech{actions} for an application. Typically, initial
actions spawn application processes and nested VMs, which in turn
subscribe to sources of events from the outside world.
At present, there's just @tt{#lang marketplace}. In future, there will
be languages providing greater support for flow control,
responsibility transfer, and other networking concepts.
@;{
@itemlist[
@item{@racket[marketplace] is for ordinary Racket programs, and uses
the @secref{tcp-bare} TCP driver;}
@item{@racket[marketplace/flow-control] is like
@racket[marketplace], but uses the flow-controlled @secref{tcp}
driver;}
]
}
@section{Using Marketplace as a library}
@defmodule*[(marketplace/sugar)
#:use-sources (marketplace/sugar)]
Instead of using Racket's @tt{#lang} feature, ordinary Racket programs
can use Marketplace features by requiring Marketplace modules
directly.
Such programs need to use @racket[ground-vm] to
start the ground-level VM explicitly. They also need to explicitly
start any drivers they need; for example, the file
@filepath{examples/echo-plain.rkt} uses @racket[ground-vm] along with
@racket[tcp] and an initial @racket[endpoint] action:
@racketblock[
(ground-vm tcp
(subscriber (tcp-channel ? (tcp-listener 5999) ?)
(match-conversation (tcp-channel from to _)
(on-presence (spawn (echoer from to))))))
]
@defform[(ground-vm maybe-boot-pid-binding maybe-initial-state initial-action ...)
#:grammar
[(maybe-boot-pid-binding (code:line)
(code:line #:boot-pid id))
(maybe-initial-state (code:line)
(code:line #:initial-state expr))
(initial-action expr)]]{
Starts the ground VM. If @racket[#:boot-pid] is specified, the given
identifier is bound within the form to the PID of the @emph{primordial
process} that performs the initial actions. If
@racket[#:initial-state] is specified, it is used as the initial state
for the primordial process; if it is not supplied, the primordial
process is given @racket[(void)] as its initial state.
}
@section[#:tag "constructing-transitions"]{Constructing transitions}
@declare-exporting[#:use-sources (marketplace
marketplace/sugar)]
@deftogether[(
@defform[(transition new-state action-tree ...)]
@defform[(transition/no-state action-tree ...)]
)]{
Each of these forms produces a @racket[transition] structure.
Each @racket[action-tree] must be an @tech{action tree}.
It's fine to include @emph{no} action trees, in which case the
transition merely updates the state of the process without taking any
actions.
In the case of @racket[transition/no-state], the value @racket[(void)]
is used for the process state. @racket[transition/no-state] is useful
for processes that are stateless other than the implicit state of
their endpoints.
}
@defstruct*[transition ([state State] [actions action-tree?]) #:transparent]{
A transition structure. The @racket[transition-state] field is the new
private state the process will have after the transition is applied,
and the @racket[transition-actions] are the actions that will be
performed by the VM in order to apply the transition.
}
@defproc[(action-tree? [value any/c]) boolean?]{
Predicate that recognises an @deftech{action tree}. An action tree is
either
@itemlist[
@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
continues with the next leaf in the tree.
For example, all of the following are valid action trees which will
send messages @racket[1], @racket[2] and @racket[3] in that order:
@racketblock[(list (send-message 1)
(send-message 2)
(send-message 3))]
@racketblock[(list (list (send-message 1))
(cons (send-message 2) (cons '() (send-message 3))))]
@racketblock[(cons (cons (send-message 1)
(send-message 2))
(list #f #f (send-message 3)))]
Because @racket[#f] and @racket[(void)] are valid, ignored, members of
an action-tree, @racket[and] and @racket[when] can be used to
selectively include actions in an action-tree:
@racketblock[(list (first-action)
(when (condition?)
(optional-action))
(final-action))]
@racketblock[(list (first-action)
(and (condition?)
(optional-action))
(final-action))]
Finally, these inert placeholders can be used to represent "no action
at all" in a transition:
@racketblock[(transition new-state) (code:comment "No action-trees at all")
(transition new-state '())
(transition new-state (void))
(transition new-state #f)]
}
@defproc[(sequence-actions [initial-transition transition?]
[item (or/c action-tree? (any/c -> transition?))]
...) transition?]{
Returns a transition formed from the @racket[initial-transition]
extended with new actions, possibly updating its carried state. Each
of the supplied @racket[item]s is examined: if it is an
@racket[ActionTree], it is appended to the pending transition's
actions; if it is a procedure, it is called with the @emph{state} of
the pending transition, and is expected to return an updated
transition.
For example,
@racketblock[(sequence-actions (transition 'x
(send-message (list 'message 0)))
(send-message (list 'message 1))
(send-message (list 'message 2))
(lambda (old-state)
(transition (cons 'y old-state)
(send-message (list 'message 3))))
(send-message (list 'message 4)))]
produces the equivalent of
@racketblock[(transition (cons 'y 'x)
(send-message (list 'message 0))
(send-message (list 'message 1))
(send-message (list 'message 2))
(send-message (list 'message 3))
(send-message (list 'message 4)))]
}
@section[#:tag "endpoint-dsl"]{Creating endpoints}
The primitive action that creates new endpoints is
@racket[add-endpoint], but because endpoints are the most flexible and
complex point of interaction between a process and its VM, a
collection of macros helps streamline endpoint setup.
@deftogether[(
@defform[(publisher topic handler ...)]
@defform[(subscriber topic handler ...)]
@defform[(observe-subscribers topic handler ...)]
@defform[(observe-publishers topic handler ...)]
@defform[(observe-subscribers/everything topic handler ...)]
@defform[(observe-publishers/everything topic handler ...)]
@defform[(build-endpoint pre-eid role handler ...)]
)]{
The many variations on the core
@racket[build-endpoint] form exist to give
good control over @racket[InterestType] in the endpoint under
construction;
see @secref{participating-vs-observing}.
Almost everything is optional in an endpoint definition. The only
mandatory part is the topic.
For example, a minimal endpoint subscribing to all messages would be:
@racketblock[(subscriber ?)]
A minimal publishing endpoint would be:
@racketblock[(publisher ?)]
While topic patterns are ordinary Racket data with embedded @racket[?]
wildcards (see @secref{messages-and-topics}), all the other patterns
in an endpoint definition are @racket[match]-patterns. In particular
note that @racket[?] is a wildcard in a topic pattern, while
@racket[_] is a wildcard in a @racket[match]-pattern.
@subsection{Receiving messages}
@defform[(on-message [pattern expr ...] ...)]{
Supply an @racket[on-message] handler clause to an endpoint definition
to handle incoming message events (as distinct from presence- or
absence-events).
The following endpoint @emph{subscribes} to all messages, but only
@emph{handles} some of them:
@racketblock[(subscriber ?
(on-message
['ping (send-message 'pong)]
['hello (list (send-message 'goodbye)
(quit))]))]
}
}
@subsection{Action-only vs. State updates}
@defform[(match-state pattern handler ...)]{
If a group of handlers is wrapped in @racket[match-state], then all
the wrapped handlers are expected to return
@seclink["constructing-transitions"]{transition structures}.
If not, however, the handler expressions are expected to return plain
@tech{action tree}s.
This way, simple handlers that do not need to examine the process
state, and simply act in response to whichever event triggered them,
can be written without the clutter of threading the process state
value through the code.
For example, a simple endpoint could be written either as
@racketblock[(subscriber 'ping
(on-message ['ping (send-message 'pong)]))]
or, explicitly accessing the endpoint's process's state,
@racketblock[(subscriber 'ping
(match-state old-state
(on-message ['ping (transition old-state
(send-message 'pong))])))]
}
@subsection{Handling presence and absence events}
@deftogether[(
@defform[(on-presence expr ...)]
@defform[(on-absence expr ...)]
)]{
Other endpoints (in this or other processes) may have matching topics
and complementary orientations to the current endpoint. When such
endpoints come and go, presence and absence events are generated in
the current endpoint.
By default, no actions are taken on such events, but
@racket[on-presence] and @racket[on-absence] handlers override this
behaviour.
For example, say process A establishes the following endpoint:
@racketblock[(subscriber 'ping
(on-presence (send-message 'pinger-arrived))
(on-absence (send-message 'pinger-departed))
(on-message ['ping (send-message 'pong)]))]
Some time later, process B takes the following endpoint-establishing
action:
@racketblock[(let-fresh (ping-endpoint-name pong-waiter-name)
(name-endpoint ping-endpoint-name
(publisher 'ping
(on-presence
(list (name-endpoint pong-waiter-name
(subscriber 'pong
(on-message
['pong (list (delete-endpoint ping-endpoint-name)
(delete-endpoint pong-waiter-name))])))
(send-message 'ping))))))]
The sequence of events will be:
@itemlist[
@item{Process A's @racket[on-presence] handler will run, and the
@racket['pinger-arrived] message will be sent. At the same
time,@note{In the current implementation, one happens before the
other, but it is nondeterministic which is run first.} process B's
@racket[on-presence] handler runs, installing a second endpoint
and sending the @racket['ping] message.}
@item{Process A's endpoint receives the @racket['ping] message, and
sends the @racket['pong] message.}
@item{Process B's second endpoint receives the @racket['pong]
message, and deletes both of process B's endpoints.}
@item{The @racket[on-absence] handler in process A runs, sending
the @racket['pinger-departed] message.}
#:style 'ordered]
One possible trace of messages in the VM containing processes A and B is
@racketblock['pinger-arrived
'ping
'pong
'pinger-departed]
By sending the @racket['ping] message @emph{only} once the
@racket[on-presence] handler has fired, process B ensures that
someone is listening for pings.
This way, if process B starts before process A, then B will
automatically wait until A is ready to receive ping requests before
issuing any.
}
@subsection{Exit reasons}
@defform[(match-reason pattern handler ...)]{
If a handler is wrapped in a @racket[match-reason] form, then the exit
reason supplied to the @racket[delete-endpoint] or @racket[quit]
action that led to the @racket[absence-event] is available to the
endpoint's @racket[on-absence] handler expression.
}
@subsection[#:tag "updating-endpoints"]{Updating endpoints}
If, when an endpoint is created, an existing endpoint with an
@racket[equal?] name is already present, then if the existing and
to-be-added endpoints have exactly equal roles (meaning equal
orientations, interest-types, and topic patterns), the @emph{handlers}
for the endpoint are @emph{updated} without emitting presence or
absence notifications.
This dubious feature can be used to avoid "glitching" of presence
signals. A future release of this library will include better
automatic support for avoiding such transients.
@subsection{Who am I talking to?}
@deftogether[(
@defform[(match-orientation pattern handler ...)]
@defform[(match-conversation pattern handler ...)]
@defform[(match-interest-type pattern handler ...)]
)]{
Wrapping a handler in @racket[match-orientation],
@racket[match-conversation], and/or @racket[match-interest-type] gives
a handler access to the contents of the @racket[role] structure
carried in the triggering @racket[EndpointEvent].
The carried role describes the @emph{intersection of interests}
between the current endpoint and the peer endpoint, and so can proxy
for the identity of the other party. It is in a sense a description of
the scope of the current conversation.
It is most common to simply use @racket[match-conversation] to extract
the @racket[role-topic] alone, since it is seldom necessary to examine
@racket[role-orientation] (since it's guaranteed to be complementary
to the orientation of the current endpoint) or
@racket[role-interest-type].
See @secref{Examples} for examples of the use of
@racket[match-conversation] and friends.
}
@subsection[#:tag "participating-vs-observing"]{Participating in a conversation vs. observing conversations}
The core @racket[build-endpoint] form takes an expression evaluating
to a @racket[role], rather than a simple topic. This gives full
control over the new endpoint's @racket[Orientation] and
@racket[InterestType].
The other forms exist for convenience, since usually the orientation
and interest-type is known statically, and only the topic varies
dynamically:
@itemlist[
@item{@racket[publisher] and @racket[subscriber] are for ordinary
@emph{participation} in conversations;}
@item{@racket[observe-subscribers] and @racket[observe-publishers]
are for @emph{observing} conversations without participating in them; and}
@item{@racket[observe-subscribers/everything] and
@racket[observe-publishers/everything] are like the ordinary
@tt{observe-...} variants, but use interest-type @racket['everything]
instead of @racket['observer].}
]
The @racket[publisher], @racket[observe-subscribers] and
@racket[observe-subscribers/everything] forms create
@emph{publisher}-oriented endpoints, and @racket[subscriber],
@racket[observe-publishers] and @racket[observe-publishers/everything]
create @emph{subscriber}-oriented endpoints. The rationale for this is
that as a participant, the code should declare the role being played;
but as an observer, the code should declare the roles being observed.
@subsection[#:tag "naming-endpoints"]{Naming endpoints}
Endpoint names can be used to @seclink["updating-endpoints"]{update}
or @seclink["deleting-endpoints"]{delete} endpoints.
@defproc[(name-endpoint [id any/c] [add-endpoint-action AddEndpoint]) AddEndpoint]{
Returns a copy of the passed-in @racket[add-endpoint] action
structure, with the @racket[id] field set to the passed-in identifying
value.
}
@defform[(let-fresh (identifier ...) expr ...)]{
Binds the @racket[identifier]s to freshly-gensymmed symbols so that
they are available to the @racket[exprs]. @racket[let-fresh] is useful
for inventing a guaranteed-unused name for a temporary endpoint:
@racketblock[(let-fresh (my-name)
(name-endpoint my-name
(subscriber ?
(on-message [_ (list (delete-endpoint my-name)
...)]))))]
}
@section[#:tag "deleting-endpoints"]{Deleting endpoints}
@defproc[(delete-endpoint [id Any] [reason Any #f]) Action]{
Use this action to delete a previously-added endpoint by name. The
@racket[id] given must be @racket[equal?] to the corresponding
@racket[add-endpoint-pre-eid]; when @racket[endpoint] was used to
construct the endpoint to be deleted, the relevant name is that bound
by @racket[#:let-name] or supplied to @racket[#:name]. See
@secref{naming-endpoints}.
If @racket[reason] is supplied, it is included in the corresponding
action, and made available in any resulting @racket[absence-event]s.
}
@section{Sending messages and feedback}
@defproc[(send-message [body Any] [orientation Orientation 'publisher]) Action]{
Constructs a message-sending action with the given orientation.
Usually the correct orientation to use is @racket['publisher]; it
means that the sender of the message is acting in the "publisher"
role. Use @racket['subscriber] instead when acting in the "subscriber"
role, i.e. sending feedback.
}
@defproc[(send-feedback [body Any]) Action]{
Equivalent to @racket[(send-message body 'subscriber)].
}
@section{Creating processes}
@deftogether[(
@defform[(spawn maybe-pid-binding boot-expr)]
@defform[(spawn/continue maybe-pid-binding
#:parent parent-state-pattern k-expr
#:child boot-expr)
#:grammar
[(maybe-pid-binding (code:line)
(code:line #:pid identifier))
(k-expr expr)
(boot-expr expr)]]
)]{
Action describing a new process to create. The @racket[boot-expr]
should be an expression yielding a @racket[transition] that contains
the child process's initial state and initial actions.
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
@racket[k-expr].
The @racket[spawn/continue] variation includes a @racket[k-expr],
which will run in the parent process after the child process has been
created. Note that @racket[k-expr] must return a @racket[transition],
since @racket[parent-state-pattern] is always supplied for these
variations.
}
@defproc[(name-process [id Any] [spawn-action Spawn]) Spawn]{
Returns a copy of the passed-in @racket[spawn] action structure, with
the @racket[debug-name] field set to the passed-in identifying value.
The debug name of a process is used in VM debug output. See also
@secref{logging}.
}
@section{Exiting and killing processes}
@defproc[(quit [who (Option PID) #f] [reason Any #f]) Action]{
Action causing the termination of a process. If @racket[who] is
omitted or @racket[#f], terminates the acting process; otherwise,
terminates the peer process having @racket[who] as its PID.
If @racket[reason] is supplied, it is included in the corresponding
action, and made available in any resulting @racket[absence-event]s.
Terminating the current process is as simple as:
@racketblock[(quit)]
When a process raises an exception that it does not catch, its
containing VM catches the exception and turns it into an implicit quit
action. In that case, the @racket[reason] will be the raised exception
itself.
}
@section{Cooperative scheduling}
@defform[(yield state-pattern k-expr)]{
Lets other processes in the system run for a step, returning to
evaluate @racket[k-expr] only after doing a complete round of the
scheduler.
The state of the yielding process will be matched against
@racket[state-pattern] when the process is resumed, and
@racket[k-expr] must evaluate to a @racket[transition].
}
@section{Creating nested VMs}
@defform[(spawn-vm maybe-vm-pid-binding maybe-boot-pid-binding
maybe-initial-state
maybe-debug-name
boot-action-expr ...)
#:grammar
[(maybe-vm-pid-binding (code:line)
(code:line #:vm-pid identifier))
(maybe-boot-pid-binding (code:line)
(code:line #:boot-pid identifier))
(maybe-initial-state (code:line)
(code:line #:initial-state expr))
(maybe-debug-name (code:line)
(code:line #:debug-name expr))
(boot-action-expr expr)]]{
Results in a @racket[spawn] action that starts a nested VM. The
primordial process in the new VM executes the boot-actions with the
given initial state. (If no initial state is supplied, @racket[(void)]
is used.)
If @racket[#:vm-pid] is present, the corresponding identifier is bound
in the boot-action expressions to the container-relative PID of the
new VM itself. If @racket[#:boot-pid] is present, however, the
corresponding identifier is bound to the new-VM-relative PID of the
primordial process in the new VM.
}
@section{Relaying across layers}
@defproc[(at-meta-level [preaction (PreAction State)] ...) (Action StateType)]{
Each VM gives its processes access to two distinct IPC facilities: the
@emph{internal} one, provided for the VM's processes to talk amongst
themselves, and the @emph{external} one, the network that the VM
itself is a process within.
Marketplace's actions can apply to either of those two networks. By
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
action to make it apply at the level of the acting process's VM's
container instead.
For example, wrapping an @racket[endpoint] in @racket[at-meta-level]
adds a subscription to the VM's container's network. Instead of
listening to sibling processes of the acting process, the new endpoint
will listen to sibling processes of the acting process's VM. In this
example, the primordial process in the nested VM creates an
endpoint in the VM's own network, the ground VM:
@racketblock[
(spawn-vm
(at-meta-level
(subscriber (tcp-channel ? (tcp-listener 5999) ?) ...)))
]
In this example, a new process is spawned as a sibling of the
nested VM rather than as a sibling of its primordial process:
@racketblock[
(spawn-vm
(at-meta-level
(spawn (transition/no-state (send-message 'hello-world)))))
]
Compare to this example, which spawns a sibling of the
nested VM's primordial process:
@racketblock[
(spawn-vm
(spawn (transition/no-state (send-message 'hello-world))))
]
}

333
scribblings/lowlevel.scrbl
View File

@ -1,333 +0,0 @@
#lang scribble/manual
@require[racket/include]
@include{prelude.inc}
@title[#:tag "low-level-interface"]{Low-level interface}
@defmodule[marketplace]
At its heart, the interface between each @tech{process} and its
containing @tech{VM} is based on @tech{handler functions} exchanging
@tech{event} and @tech{action} structures with the VM. Both events and
actions are simple Racket structures.
This low-level interface between a VM and a process is analogous to
the @emph{system call interface} of a Unix-like operating system. The
@secref{high-level-interface} corresponds to the @emph{C library
interface} of a Unix-like operating system.
@section[#:tag "handler-functions"]{Handler Functions}
Each @deftech{handler function} is always associated with a particular
@tech{endpoint}, registered with the VM via
@racket[endpoint]/@racket[add-endpoint]. A handler
function for a given process with state type @racket[State] has type:
@racketblock[(EndpointEvent -> State -> (Transition State))]
That is, given an @racket[EndpointEvent] followed by the process's
current state, the handler should reply with a @racket[Transition]
containing a new process state and a collection of @racket[Action]s.
@deftogether[(
@deftype[(Handler State) (TrapK State)]
@deftype[(TrapK State) (EndpointEvent -> (InterruptK State))]
@deftype[(InterruptK State) (State -> (Transition State))]
)]{
Typed Racket types capturing various notions of handler function.
}
@section{Messages, Topics and Roles}
@declare-exporting[marketplace marketplace/sugar
#:use-sources (marketplace marketplace/sugar)]
@deftogether[(
@deftype[Message Any]
@deftype[Topic Any]
)]{
As previously mentioned, @tech{messages} are ordinary Racket values,
and @tech{topics} are ordinary Racket values which may have embedded
wildcards.
}
@deftogether[(
@defproc[(wild) Topic]
@defthing[#:kind "syntax" ? Topic]
)]{
Each time @racket[?] (or @racket[(wild)]) is used in an expression
context, it produces a fresh topic wildcard, suitable for use in a
topic pattern.
}
@deftogether[(
@defstruct*[role ([orientation Orientation] [topic Topic] [interest-type InterestType]) #:prefab]
@deftype[Role role]
)]{
Roles are almost always constructed by the
@racket[endpoint]/@racket[endpoint:] macros or by the VM
implementations themselves. User programs generally only need to
destructure @racket[role] instances.
A @racket[role] describes the conversational role of a peer as seen by
some process. For example, a subscriber to topic @racket['foo] with
interest-type @racket['participant] might receive a presence
notification carrying the role
@racketblock[(role 'publisher 'foo 'participant)]
Notice that the orientation of the role is the opposite of the
orientation of the endpoint.
}
@deftype[Orientation (U 'publisher 'subscriber)]{
Describes an endpoint's orientation: will it be acting as a publisher
of messages, or as a subscriber to messages? Publishers (orientation
@racket['publisher]) tend to use @racket[send-message] and tend to
respond to feedback from subscribers; subscribers
(@racket['subscriber]) tend to use @racket[send-feedback] and respond
to messages from publishers.
}
@deftype[InterestType (U 'participant 'observer 'everything)]{
Using interest-type @racket['participant] in an endpoint's role
indicates that the endpoint is intending to act as a genuine
participant in whatever protocol is associated with the endpoint and
its topic.
Using @racket['observer] indicates that the endpoint is intended to
@emph{monitor} other ongoing (participant) conversations instead.
Observer endpoints receive presence and absence notifications about
participant endpoints, but participant endpoints only receive
notifications about other participant endpoints, and not about
observer endpoints.
The @racket['observer] interest-type is intended to make it easier to
monitor resource demand and supply. The monitoring endpoints/processes
can react to changing demand by creating or destroying resources to
match.
Finally, the @racket['everything] interest-type receives notifications
about presence and absence of @emph{all} the types of endpoint,
@racket['participant], @racket['observer], and @racket['everything].
Endpoints with interest-type @racket['everything] are rare: they are
relevant for managing demand for @emph{observers}, as well as in some
cases of cross-layer presence/absence propagation. Most programs (and
even most drivers) will not need to use the @racket['everything]
interest-type.
}
@section[#:tag "endpoint-events"]{Endpoint Events}
@deftogether[(
@deftype[EndpointEvent (U PresenceEvent AbsenceEvent MessageEvent)]
@deftype[PresenceEvent presence-event]
@deftype[AbsenceEvent absence-event]
@deftype[MessageEvent message-event]
)]{
Endpoint events are passed to handler functions by VMs, conveying some
change in the world the process lives in. An endpoint event can signal
the arrival or departure of a conversational peer, or can deliver a
message that has been sent on a VM's IPC facility.
}
@defstruct*[presence-event ([role Role]) #:prefab]{
Indicates the arrival of a new conversational partner: an endpoint
with a topic that intersects our own, with @racket[Orientation]
opposite to our own.
The @racket[presence-event-role] describes the arriving peer, or more
precisely, describes the shared interest between ourselves and the new
peer. In particular, the @racket[role-orientation] of the
@racket[presence-event-role] is the orientation that the @emph{peer}
supplied in its @racket[add-endpoint] structure.
}
@defstruct*[absence-event ([role Role] [reason Any]) #:prefab]{
Indicates the departure of an existing conversational partner, through
either an explicit @racket[delete-endpoint] action or the implicit
deleting of all of a process's endpoints when a process exits.
The @racket[absence-event-role] describes the departing peer,
analogously to @racket[presence-event-role].
}
@defstruct*[message-event ([role Role] [message Message]) #:prefab]{
Indicates the arrival of a message matching the topic pattern in the
handler's @tech{endpoint}.
}
@section{Actions}
@declare-exporting[marketplace]
@deftogether[(
@deftype[(Action State) (U (PreAction State)
(yield State)
(at-meta-level State))]
@deftype[(PreAction State) (U (add-endpoint State)
delete-endpoint
send-message
(spawn State)
quit)]
)]{
Actions are requests from a process to its containing VM. If wrapped
in an @racket[at-meta-level] structure, the action is to apply to
@emph{the VM's own containing VM}; otherwise, the action applies to
the process's containing VM.
}
@deftogether[(
@defstruct*[at-meta-level ([preaction (PreAction State)]) #:prefab]
@deftype[(AtMetaLevel State) (at-meta-level State)]
)]{
An @racket[at-meta-level] structure wraps a plain action, and makes it
apply to the outer VM instead of the inner VM (the default).
}
@deftogether[(
@defstruct*[yield ([k (InterruptK State)]) #:prefab]
@deftype[(Yield State) (yield State)]
)]{
Because current VM implementations are cooperatively scheduled, it can
sometimes be necessary to explicitly yield the CPU to other processes
using a @racket[yield] action. When control returns to the yielding
process, the @racket[yield-k] is invoked.
}
@subsection[#:tag "endpoints-and-messages"]{Endpoints and Messages}
@deftogether[(
@defstruct*[add-endpoint ([pre-eid Any] [role Role] [handler (Handler State)]) #:prefab]
@deftype[(AddEndpoint State) (add-endpoint State)]
)]{
Creates a new endpoint subscribing to the given @racket[Role]. When
events pertaining to the given role occur, the @racket[Handler] is
invoked.@note{If invoked @racket[at-meta-level], subscribes to events
in the containing VM's container.}
The name of the new endpoint will be the @racket[pre-eid]; it must be
unique within the current process, but otherwise can be any value at
all. If the endpoint's name matches an existing endpoint, and the new
role is the same as the existing endpoint's role, the handler function
is @emph{replaced} in the existing endpoint.
To delete an endpoint, perform a @racket[delete-endpoint] action built
with the name of the endpoint to delete.
}
@deftogether[(
@defstruct*[delete-endpoint ([pre-eid Any] [reason Any]) #:prefab]
@deftype[DeleteEndpoint delete-endpoint]
)]{
Deletes an existing endpoint named @racket[pre-eid]. The given
@racket[reason] is passed along to peer endpoints as part of an
@racket[absence-event].
If no specific reason is needed, it is conventional to supply
@racket[#f] as the @racket[delete-endpoint-reason]. See also the
convenience @from[marketplace/sugar]{@racket[delete-endpoint]}
function from @racket[marketplace/sugar].
}
@deftogether[(
@defstruct*[send-message ([body Message] [orientation Orientation]) #:prefab]
@deftype[SendMessage send-message]
)]{
Sends a message to peers.@note{Or, if @racket[at-meta-level], peers of
the containing VM.} The given @racket[Orientation] should describe the
role the sender is playing when sending this message: usually, it will
be @racket['publisher], but when the message is @emph{feedback} for
some publisher, it will be @racket['subscriber].
@from[marketplace/sugar]{See also the @racket[send-message] and
@racket[send-feedback] convenience functions from
@racket[marketplace/sugar].}
}
@subsection{Process Management}
@deftogether[(
@defstruct*[spawn ([spec process-spec] [k (Option (PID -> (InterruptK State)))] [debug-name Any])
#:prefab]
@defstruct*[process-spec ([boot (PID -> CoTransition)]) #:prefab]
@deftype[CoTransition
(All (Result)
(All (State) (Transition State) -> Result)
-> Result)]
@deftype[(Spawn State) (spawn State)]
@deftype[ProcessSpec process-spec]
)]{
A @racket[spawn] requests the creation of a sibling process@note{If
wrapped in an @racket[at-meta-level], the new process will instead be
a sibling of the creating process's VM.}. The @racket[spawn-k] runs in
the context of the @emph{creating} process, communicating to it the
PID of the new process.
The @racket[spawn-spec] describes the new process to be created. Its
@racket[process-spec-boot] field is a function taking the PID of the
new process and returning a "cotransition". Cotransitions use a
second-order encoding of existential types to guarantee that the VM
remains oblivious to the specific process state type of the new
process. The downside of this approach is its syntactic and type
complexity: see @racket[spawn:] for an easier-to-use, higher-level
approach.
}
@deftogether[(
@defstruct*[quit ([pid (Option PID)] [reason Any]) #:prefab]
@deftype[Quit quit]
)]{
Kills a sibling process.@note{Or, if @racket[at-meta-level], a sibling
process of the containing VM.} If @racket[quit-pid] is @racket[#f],
kills the current process; otherwise, kills the process with the given
PID. The @racket[quit-reason] is passed on to peers of
currently-active endpoints in the process to be killed, as part of a
@racket[absence-event], just as if each active endpoint were deleted
manually before the process exited.
If no specific reason is needed, it is conventional to supply
@racket[#f] as the @racket[quit-reason].
}
@deftype[PID Number]{
In the current VM implementations, process IDs are simply numbers.
PIDs are scoped to and allocated by each individual VM instance.
}

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

@ -1,86 +0,0 @@
#lang scribble/manual
@require[racket/include]
@include{prelude.inc}
@require[(for-label marketplace/support/spy
marketplace/support/debug
marketplace/log)]
@title{Management and Monitoring}
@section{generic-spy}
@defmodule[marketplace/support/spy]{
@defproc[(generic-spy [label Any]) Spawn]{
Returns a @racket[spawn] action that, when executed, creates a process
with a @racket[#:subscriber] @racket[endpoint] listening for every
message. Each @racket[EndpointEvent] received by the endpoint is
printed to the current output port. Using this process gives a crude
trace of activity within a VM: @racket[presence-event]s and
@racket[absence-event]s (of @racket[#:publishers]) are logged, as is
each @racket['publisher] message sent to the VM's network.
}
}
@section[#:tag "logging"]{logging (MARKETPLACE_LOG)}
@defmodule*[(marketplace/log)]{
@defform[#:kind "environment variable" #:id MARKETPLACE_LOG MARKETPLACE_LOG]{
Set the @tt{MARKETPLACE_LOG} environment variable to "debug", "info",
"warning", "error" or "fatal" (i.e. any of Racket's
@racket[log-level?]s) to enable output of log messages at that level
and higher.
If @tt{MARKETPLACE_LOG} is not defined in the environment, @emph{no log
output will be produced}.
}
@defform[(marketplace-log level format-str arg ...)
#:grammar
((level expr)
(format-str expr)
(arg expr))]{
Analogous to Racket's core @racket[log-message], but uses
@racket[marketplace-root-logger] instead of the system logger. The
@racket[level] expression must evaluate to a level symbol (see
@racket[log-level?]), and @racket[format-str] must evaluate to a
format string for use with @racket[format].
}
@defthing[marketplace-root-logger logger?]{
The root logger for marketplace logging.
}
}
@section{debugger (experimental)}
@defmodule[marketplace/support/debug]{
@defproc[(debug [p Spawn]) Spawn]{
Translates a @racket[spawn] action to another spawn action which wraps
the to-be-spawned process in a debugging interface. Executing the
resulting action will not only create a process in the executing VM,
but will also open a debugger GUI.
N.B.: The debugger is experimental and likely to change quite quickly
and unpredictably.
See the file @filepath["examples/debug-chat.rkt"] for an example of the
use of @racket[debug].
}
}

76
scribblings/marketplace.scrbl
View File

@ -1,76 +0,0 @@
#lang scribble/manual
@require[racket/include]
@include{prelude.inc}
@title[#:tag "marketplace"]{Marketplace: Network-Aware Programming}
@;{Marketplace: A Functional Operating System}
@;{Marketplace: A Functional Network Operating System}
@;{Marketplace: A Functional Distributed Operating System}
@author[(author+email "Tony Garnock-Jones" "tonyg@ccs.neu.edu")]
@bold{Every program is a network.}
This is the insight behind the π-calculus. Encoding a program as a
π-calculus term shows it as a network of communicating processes. It
is also one of the original inspirations for Smalltalk, where every
object, every value, was imagined to be a separate computer in a vast
network, and where objects communicated by message-passing.
@bold{Every program is part of a network.}
A program that computes a result but cannot communicate it is useless
indeed. Every complete program both @emph{computes} and
@emph{communicates}. Furthermore, it does so with some finite set of
@emph{resources}, which it must carefully manage.
@bold{Our programming languages do not recognise that every program is
a network.} They blur the distinction between stateful and stateless
portions of a program, making it difficult for programmers to reason
about concurrency, contention, and distribution. They often treat
partial failure as an afterthought, despite its importance in
reasoning about program behaviour, particularly in connection with the
effect of exceptions on stateful programs. They seldom consider issues
of trust and security.
@bold{Our programming languages do not recognise that every program is part of a network.}
They treat communication with the outside world in an ad-hoc manner.
They frequently treat network communication separately from
@tt{1950s-style terminal input and output}. They force the programmer
to divine failures in other parts of the network by arcane means such
as timeouts and examining the entrails of dead communication channels.
They offer no support for allocating or releasing local resources in
response to changes in other parts of the network. They seldom
consider issues of trust and security.
@bold{Marketplace is a network-aware programming language.} As a
corollary, because every program not only computes but also
communicates and manages its resources, Marketplace is also a
distributed operating system.
By recognising that programs communicate both
@emph{internally} (between subprograms) and @emph{externally} (between
peers), we recognise an inherently recursive layered architecture. We
see at every level the @emph{same} concerns of resource management,
location of mutable state, failure detection and recovery, access
control, I/O and user interface, debugging and profiling.
Marketplace addresses these concerns with a small set of primitives
chosen to make network programming in-the-small as flexible, scalable,
manageable and securable as network programming in-the-large---and
vice versa.
@;{
Networks must be manageable. Networks must be monitorable. Networks
must tolerate partial failure. Networks must scale. Networks must
communicate with other networks, via yet other networks.
}
@local-table-of-contents[]
@;@include-section["background.scrbl"]
@include-section["concepts.scrbl"]
@include-section["highlevel.scrbl"]
@include-section["lowlevel.scrbl"]
@include-section["drivers.scrbl"]
@;@include-section["writing-drivers.scrbl"]
@include-section["management-and-monitoring.scrbl"]
@include-section["examples.scrbl"]

31
scribblings/prelude.inc
View File

@ -1,31 +0,0 @@
;; -*- scheme -*-
(require scribble/racket
scribble/eval
scriblib/footnote
slideshow/pict
"vm-pictures.rkt"
"from.rkt"
(for-syntax racket)
(for-label typed/racket/base))
(require (for-label (only-in marketplace/drivers/tcp-bare tcp)
marketplace/sugar))
;; TODO: make it display "=" instead of ":" connecting the defined
;; type to the definition.
(define-syntax deftype
(lambda (stx)
(syntax-case stx ()
[(_ (t a ...) d desc ...)
#`(defthing #:kind "type" t
;; This is in column zero because scribble is overscrupulous about location preservation.
#,(quasisyntax/loc #'d (All (a ...) d))
desc ...)]
[(_ t d desc ...)
#`(defthing #:kind "type" t d desc ...)])))
(define (vm-figure p)
(centered (to-element (render (scale p 1.2) #:target 'pict))))

113
scribblings/vm-pictures.rkt
View File

@ -1,113 +0,0 @@
#lang racket/base
(require (only-in racket/math pi))
(require slideshow/pict)
(require file/convertible)
(provide (all-defined-out))
(define default-process-height 98)
(define default-font (make-parameter 'roman))
(define final-border (make-parameter 1))
(define process-angle (make-parameter 90))
(define process-width (make-parameter 24))
(define process-corner (make-parameter 6))
(define process-height (make-parameter default-process-height))
(define process-gap (make-parameter 6))
(define process-fill-color (make-parameter "white"))
(define PROCESS-SHADED (list #xdd #xdd #xdd))
(define leg-offset (make-parameter 4))
(define leg-width (make-parameter 2))
(define leg-spot-width (make-parameter 4))
(define (default-leg-height)
(/ (network-height) 2))
(define (meta-leg-height)
(+ (default-leg-height) (vm-height) (network-height)))
(define network-height (make-parameter 12))
(define vm-height (make-parameter 27))
(define process-label-size (make-parameter 12))
(define network-label-size (make-parameter 9))
(define vm-label-size (make-parameter 12))
(define ellipsis-size (make-parameter 24))
(define (process label)
(cb-superimpose
(colorize (filled-rounded-rectangle (process-width) (process-height) (process-corner))
(process-fill-color))
(rounded-rectangle (process-width) (process-height) (process-corner))
(vc-append (text label (default-font) (process-label-size) (d2r (process-angle)))
(blank (/ (- (process-width) (process-label-size)) 2)))))
(define (process-group . ps)
(apply hb-append (process-gap) ps))
(define (process-space [n 1])
(blank (+ (* (- n 1) (/ (process-width) 2))
(- (/ (process-width) 2) (* 2 (process-gap)))) (process-height)))
(define (vm-label str)
(text str (default-font) (vm-label-size) (d2r 0)))
(define (network-label str)
(text str (default-font) (network-label-size) (d2r 0)))
(define (vm label net-label . ps)
(define ps-pict (apply process-group ps))
(define label-width (max (pict-width label) (pict-width net-label)))
(define width (max (+ label-width (* 2 (max (vm-label-size) (network-label-size))))
(pict-width ps-pict)))
(vl-append ps-pict
(cb-superimpose (colorize (filled-rectangle width (network-height))
(process-fill-color))
(rectangle width (network-height))
net-label)
(cc-superimpose (colorize (filled-rectangle width (vm-height))
(process-fill-color))
(rectangle width (vm-height))
label)))
(define (process-ellipsis)
(cc-superimpose (text ". . ." (default-font) (ellipsis-size) 0)
(blank 0 (process-height))))
(define (d2r d)
(* pi (/ d 180.0)))
(define (leg p offset height)
(define x (+ (/ (pict-width p) 2) (* offset (leg-offset))))
(define y (pict-height p))
(define leg-pict (vc-append (vline (leg-width) (- height (/ (leg-spot-width) 2)))
(disk (leg-spot-width) #:draw-border? #f)))
(pin-over p (- x (/ (pict-width leg-pict) 2)) y leg-pict))
(define (relay-legs p)
(leg (leg p 1 (default-leg-height)) -1 (meta-leg-height)))
(define (local-leg p)
(leg p 0 (default-leg-height)))
(define (render p #:target [target (string->symbol (or (getenv "VM_PICTURES_TARGET") "eps"))])
(define final-pict (cc-superimpose (blank (+ (pict-width p) (* 2 (final-border)))
(+ (pict-height p) (* 2 (final-border))))
(panorama p)))
(case target
[(pict)
final-pict]
[(screen)
;; FFS. This connects to the display even if you don't use it.
;; (local-require racket/gui/base)
;; (show-pict final-pict 800 600)
(log-error "You need to uncomment a couple of lines in vm-pictures.rkt")
(void)]
[(png)
(display (convert final-pict 'png-bytes))]
[(eps)
(display (convert final-pict 'eps-bytes))]))

12
scribblings/writing-drivers.scrbl
View File

@ -1,12 +0,0 @@
#lang scribble/manual
@require[racket/include]
@include{prelude.inc}
@title[#:tag "writing-new-drivers"]{Writing New Drivers}
*** ground-vm's usage of Racket evt?s
TODO
example of chat-client.rkt
*** pseudo-substruct
TODO

47
struct-map.rkt
View File

@ -1,47 +0,0 @@
#lang racket/base
(provide prop:struct-map
struct-mappable?
extract-struct-mapper
struct-map
struct-map/accumulator)
(define-values (prop:struct-map struct-mappable? extract-struct-mapper)
(make-struct-type-property 'struct-map))
;; (X -> Y) Struct<X> -> Struct<Y>
(define (struct-map f x)
(define-values (result acc)
(struct-map* 'struct-map (lambda (v acc) (values (f v) acc)) (void) x))
result)
;; (X Seed -> Y Seed) Seed Struct<X> -> Struct<Y> Seed
(define (struct-map/accumulator f seed x)
(struct-map* 'struct-map/accumulator f seed x))
(define (struct-map* name f seed x)
(define m (cond
[(struct-mappable? x) (extract-struct-mapper x)]
[(prefab-struct-key x) => prefab-struct-mapper]
[(struct? x)
(define-values (struct-type skipped?) (struct-info x))
(when skipped? (error name "Partial struct-info for ~v" x))
(transparent-struct-mapper struct-type)]
[else (error name "No struct-map property or mapper for ~v" x)]))
(m f seed x))
(define ((prefab-struct-mapper key) f initial-seed x)
(define-values (new-fields final-seed)
(for/fold ([new-fields '()] [old-seed initial-seed])
([old-field (cdr (vector->list (struct->vector x)))])
(define-values (new-field new-seed) (f old-field old-seed))
(values (cons new-field new-fields) new-seed)))
(values (apply make-prefab-struct key (reverse new-fields)) final-seed))
(define ((transparent-struct-mapper struct-type) f initial-seed x)
(define-values (new-fields final-seed)
(for/fold ([new-fields '()] [old-seed initial-seed])
([old-field (cdr (vector->list (struct->vector x)))])
(define-values (new-field new-seed) (f old-field old-seed))
(values (cons new-field new-fields) new-seed)))
(values (apply (struct-type-make-constructor struct-type) (reverse new-fields)) final-seed))

96
structs.rkt
View File

@ -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:

392
sugar.rkt
View File

@ -1,392 +0,0 @@
#lang racket/base
(require (for-syntax syntax/parse))
(require (for-syntax racket/base))
(require racket/match)
(require (prefix-in core: "main.rkt"))
(require (except-in "main.rkt"
at-meta-level
spawn
yield
transition
delete-endpoint
send-message
quit))
(require "support/dsl-untyped.rkt")
(provide (all-from-out "main.rkt")
transition
delete-endpoint
send-message
send-feedback
quit
sequence-actions
(rename-out [core:wild wild])
name-endpoint
let-fresh
observe-subscribers
observe-subscribers/everything
observe-publishers
observe-publishers/everything
publisher
subscriber
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:
;; - 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)
(define (name-endpoint n e)
(match e
[(core:add-endpoint _ role handler)
(core:add-endpoint n role handler)]))
(define-syntax-rule (let-fresh (id ...) exp ...)
(let ((id (gensym 'id)) ...) exp ...))
(define-syntax-rule (observe-subscribers topic clause ...)
(build-endpoint (gensym 'anonymous-endpoint)
(core:role 'publisher topic 'observer)
clause ...))
(define-syntax-rule (observe-subscribers/everything topic clause ...)
(build-endpoint (gensym 'anonymous-endpoint)
(core:role 'publisher topic 'everything)
clause ...))
(define-syntax-rule (observe-publishers topic clause ...)
(build-endpoint (gensym 'anonymous-endpoint)
(core:role 'subscriber topic 'observer)
clause ...))
(define-syntax-rule (observe-publishers/everything topic clause ...)
(build-endpoint (gensym 'anonymous-endpoint)
(core:role 'subscriber topic 'everything)
clause ...))
(define-syntax-rule (publisher topic clause ...)
(build-endpoint (gensym 'anonymous-endpoint)
(core:role 'publisher topic 'participant)
clause ...))
(define-syntax-rule (subscriber topic clause ...)
(build-endpoint (gensym 'anonymous-endpoint)
(core:role 'subscriber topic 'participant)
clause ...))
(define-syntax build-endpoint
(lambda (stx)
(define (combine-handler-clauses clauses-stx
stateful?
state-stx
orientation-stx
conversation-stx
interest-type-stx
reason-stx)
(define (do-tail new-clauses-stx)
(combine-handler-clauses 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)
#`(match-lambda [#,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) (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 (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 (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 (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 (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 (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) (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 pre-eid-exp role-exp handler-clause ...)
#`(core:add-endpoint pre-eid-exp
role-exp
(match-lambda
#,@(reverse
(combine-handler-clauses
(syntax (handler-clause ...))
#f
(syntax old-state)
(syntax _)
(syntax _)
(syntax _)
(syntax _)))
[_ (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:
;;; 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 'let-fresh 'scheme-indent-function 1)
;;; eval: (put 'observe-subscribers 'scheme-indent-function 1)
;;; eval: (put 'observe-subscribers/everything 'scheme-indent-function 1)
;;; eval: (put 'observe-publishers 'scheme-indent-function 1)
;;; eval: (put 'observe-publishers/everything 'scheme-indent-function 1)
;;; eval: (put 'publisher 'scheme-indent-function 1)
;;; eval: (put 'subscriber 'scheme-indent-function 1)
;;; 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:

105
support/debug.rkt
View File

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

15
support/dsl-untyped.rkt
View File

@ -1,15 +0,0 @@
#lang racket/base
(require (for-syntax racket/base))
(provide define&provide-dsl-helper-syntaxes)
(define-syntax-rule (define&provide-dsl-helper-syntaxes context (identifier ...))
(begin (provide identifier ...)
(define-syntax identifier
(lambda (stx)
(raise-syntax-error #f
(format "Illegal use of ~a outside ~a"
'identifier
context)
stx)))
...))

52
support/dump-bytes.rkt
View File

@ -1,52 +0,0 @@
#lang racket/base
;; Copyright (C) 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>
;; Pretty hex dump output of a Bytes.
(provide dump-bytes!)
;; Exact Exact -> String
;; Returns the "0"-padded, width-digit hex representation of n
(define (hex width n)
(define s (number->string n 16))
(define slen (string-length s))
(cond
((< slen width) (string-append (make-string (- width slen) #\0) s))
((= slen width) s)
((> slen width) (substring s 0 width))))
;; Bytes Exact -> Void
;; Prints a pretty hex/ASCII dump of bs on (current-output-port).
(define (dump-bytes! bs [requested-count (bytes-length bs)] #:base [baseaddr 0])
(define count (min requested-count (bytes-length bs)))
(define clipped (subbytes bs 0 count))
(define (dump-hex i)
(if (< i count)
(display (hex 2 (bytes-ref clipped i)))
(display " "))
(display #\space))
(define (dump-char i)
(if (< i count)
(let ((ch (bytes-ref clipped i)))
(if (<= 32 ch 127)
(display (integer->char ch))
(display #\.)))
(display #\space)))
(define (for-each-between f low high)
(do ((i low (+ i 1)))
((= i high))
(f i)))
(define (dump-line i)
(display (hex 8 (+ i baseaddr)))
(display #\space)
(for-each-between dump-hex i (+ i 8))
(display ": ")
(for-each-between dump-hex (+ i 8) (+ i 16))
(display #\space)
(for-each-between dump-char i (+ i 8))
(display " : ")
(for-each-between dump-char (+ i 8) (+ i 16))
(newline))
(do ((i 0 (+ i 16)))
((>= i count))
(dump-line i)))

416
support/gui.rkt
View File

@ -1,416 +0,0 @@
#lang racket/base
(require racket/set)
(require racket/match)
(require racket/class)
(require racket/async-channel)
(require racket/gui/base)
(require racket/date)
(require racket/format)
(require racket/math)
(require images/icons/control)
(require images/icons/arrow)
(require images/icons/symbol)
(require images/icons/misc)
(require images/icons/style)
(require data/queue)
(require racket/pretty)
(require (prefix-in core: "../structs.rkt")
(prefix-in core: "../vm.rkt"))
(provide open-debugger)
;; Frame
;; Toolbar
;; Rewind one step - moves without executing
;; Fast-forward one step - moves without executing
;; --
;; Stop
;; Run one step
;; Play
;; --
;; Select history depth
;; --
;; Kill this process
;; State display
;; If the state is (vm?), special display; permits spawning debuggers on nested processes
;; Endpoints display
;; Shows ID and role
;; Permits deletion of endpoint
;; Permits interaction with endpoint??
;; Trace display
;; Selection of a row rewinds to that point
(struct historical-moment (alive? state endpoints) #:transparent)
(define (open-debugger name)
(define to-debugger (make-channel))
(define from-debugger (make-channel))
(parameterize ((current-eventspace (make-eventspace)))
(new debugger%
[name name]
[from-vm to-debugger]
[to-vm from-debugger]))
(lambda (v)
(channel-put to-debugger v)
(channel-get from-debugger)))
(define sane-tab-panel%
(class tab-panel%
(super-new)
(define/override (place-children l width height)
(for/list [(child-spec (in-list l))]
(match-define (list min-w min-h v-stretch? h-stretch?) child-spec)
(list 0
0
(if h-stretch? width min-w)
(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%
(class object%
(init-field name)
(init-field from-vm)
(init-field to-vm)
(define mutex (make-semaphore 1))
(define stepping? #t)
(define k-queue (make-queue))
(define (reply-to-vm reply)
(call-with-semaphore mutex
(lambda () (if stepping?
(channel-put to-vm reply)
(enqueue! k-queue reply)))))
(define current-historical-moment (historical-moment #t (void) '()))
(define displayed-endpoints '())
(define booted? #f)
(define frame (new frame%
[label (format "~a" name)]
[width 480]
[height 700]))
(define menu-bar (new menu-bar% [parent frame]))
(define edit-menu (new menu% [label "Edit"] [parent menu-bar]))
(append-editor-operation-menu-items edit-menu #f)
(define state-panel (new sane-tab-panel%
[parent frame]
[choices '("Process State")]
[callback (lambda (p e) (select-state-tab))]))
(define endpoints (new list-box%
[style '(single column-headers)]
[label #f]
[choices '()]
[parent frame]
[columns '("ID" "" "" "" "Topic")]))
(define events (new list-box%
[style '(single column-headers)]
[callback (lambda (lb e)
(define sel (or (send lb get-selection)
(- (send lb get-number) 1)))
(define m (and sel (send lb get-data sel)))
(when m (select-historical-moment m)))]
[label #f]
[choices '()]
[parent frame]
[columns '("Time" "Dir" "Type" "Detail")]))
(define FIXED-COLUMN-WIDTH 40)
(send endpoints set-column-width 1 FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH)
(send endpoints set-column-width 2 FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH)
(send endpoints set-column-width 3 FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH)
(send events set-column-width 1 FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH)
(define toolbar (new horizontal-pane%
[parent frame]
[stretchable-height #f]
[alignment '(right center)]))
(define (toolbar-button label [handler void])
(new button%
[label label]
[min-width 32]
[parent toolbar]
[callback handler]))
(define (toolbar-spacer)
(new pane% [parent toolbar] [min-width 16] [stretchable-width #f]))
;; (toolbar-button (left-over-arrow-icon #:color syntax-icon-color))
;; (toolbar-button (right-over-arrow-icon #:color syntax-icon-color))
;; (toolbar-spacer)
(define pause-button
(toolbar-button (pause-icon #:color halt-icon-color)
(lambda (b e)
(send pause-button enable #f)
(send play-button enable #t)
(send step-button enable #t)
(call-with-semaphore
mutex
(lambda ()
(set! stepping? #f))))))
(define play-button
(toolbar-button (play-icon #:color run-icon-color)
(lambda (b e)
(send pause-button enable #t)
(send play-button enable #f)
(send step-button enable #f)
(call-with-semaphore
mutex
(lambda ()
(set! stepping? #t)
(when (non-empty-queue? k-queue)
(channel-put to-vm (dequeue! k-queue))))))))
(toolbar-spacer)
(define step-button
(toolbar-button (step-icon #:color run-icon-color)
(lambda (b e)
(call-with-semaphore
mutex
(lambda ()
(when (non-empty-queue? k-queue)
(channel-put to-vm (dequeue! k-queue))))))))
(send play-button enable #f)
(send step-button enable #f)
;; (toolbar-spacer)
;; (toolbar-button "Settings...")
;; (toolbar-spacer)
;; (toolbar-button (stop-sign-icon))
(define status-indicator
(new canvas%
[parent toolbar]
[min-width 32]
[min-height 32]
[stretchable-width #f]
[style '(transparent no-focus)]
[paint-callback (lambda (c dc)
(define mx (/ (send c get-width) 2))
(define my (/ (send c get-height) 2))
(define r (/ (min mx my) 2))
(send dc set-brush
(if (historical-moment-alive? current-historical-moment)
"green"
"red")
'solid)
(send dc draw-ellipse (- mx r) (- my r) (* r 2) (* r 2)))]))
(define state-text (new text%))
(define state-canvas (new editor-canvas%
[parent state-panel]
[editor state-text]
[label "State"]))
(define vm-display (new list-box%
[style '(single column-headers)]
[label #f]
[choices '()]
[parent state-panel]
[columns '("PID" "#Endpoints" "#MetaEndpoints" "Name")]))
(send vm-display show #f)
(define (select-historical-moment m)
(match-define (historical-moment alive? state new-endpoints) m)
(when (not (equal? displayed-endpoints new-endpoints))
(send endpoints clear)
(for [(ep (in-list new-endpoints))]
(match-define (list pre-eid meta? (core:role orientation topic interest-type)) ep)
(define n (send endpoints get-number))
(send endpoints append (~v pre-eid))
(send endpoints set-string n (if meta? "Meta" "") 1)
(send endpoints set-string n (case orientation
[(publisher) "Pub"]
[(subscriber) "Sub"]) 2)
(send endpoints set-string n (case interest-type
[(participant) ""]
[(observer) "Obs"]
[(everything) "***"]) 3)
(send endpoints set-string n (~v topic) 4))
(set! displayed-endpoints new-endpoints))
(send state-canvas set-canvas-background
(if alive?
(make-color #xff #xff #xff)
(make-color #xff #xd0 #xd0)))
(send status-indicator refresh)
(send state-text erase)
(send state-text insert (pretty-format state))
(when (core:vm? state)
(refresh-vm-display state)
(when (= 1 (send state-panel get-number))
(send state-panel append "VM State")
(send state-panel set-selection 1)
(select-state-tab))))
(define (refresh-vm-display v)
;; (define procs (sort (hash->list (core:vm-processes v)) < #:key car))
(send vm-display clear)
;; (for [(entry (in-list procs))]
;; (match-define (cons pid wp) entry)
;; ;;(wp (lambda (p) (displayln `(P ,p))))
;; (displayln (cons pid wp)))
)
(define (select-state-tab)
(define selection (send state-panel get-selection))
(send state-canvas show (= selection 0))
(send vm-display show (= selection 1)))
(define controller-thread
(thread
(lambda ()
(controller-thread-loop))))
(define (current-timestamp)
(define (p n w) (~a (exact-truncate n) #:width w #:align 'right #:pad-string "0"))
(define d (current-date))
(format "~a:~a:~a.~a ~a-~a-~a"
(p (date-hour d) 2)
(p (date-minute d) 2)
(p (date-second d) 2)
(p (/ (date*-nanosecond d) 1000000.0) 3)
(date-year d)
(p (date-month d) 2)
(p (date-day d) 2)))
(define (record-event! stamp dir type detail)
(define n (send events get-number))
(send events append stamp)
(send events set-data n current-historical-moment)
(send events set-string n dir 1)
(send events set-string n type 2)
(send events set-string n (string->label-string (~a detail)) 3)
(define current-selection (send events get-selection))
(when (or (not current-selection) (= current-selection (- n 1)))
(send events set-first-visible-item n)
(send events set-selection n)
(select-historical-moment current-historical-moment)))
(define (format-action action)
(cond
[(core:yield? action)
(values "Yield" "")]
[(core:at-meta-level? action)
(format-preaction "Meta" (core:at-meta-level-preaction action))]
[else
(format-preaction "" action)]))
(define (format-preaction layer preaction)
(define-values (type detail)
(match preaction
[(core:add-endpoint pre-eid role handler)
(values "Sub" (string-append (format-role role) " " (~a pre-eid)))]
[(core:delete-endpoint pre-eid reason)
(values "Unsub" (format "~a ~v" pre-eid reason))]
[(core:send-message body 'publisher)
(values "Send" (~v body))]
[(core:send-message body 'subscriber)
(values "Feedback" (~v body))]
[(core:spawn spec maybe-k child-debug-name)
(values "Spawn" (~v child-debug-name))]
[(core:quit #f reason)
(values "Exit" (~v reason))]
[(core:quit pid reason)
(values "Kill" (format "~a ~v" pid reason))]))
(values (string-append layer type) detail))
(define (format-role r)
(match-define (core:role orientation topic interest-type) r)
(format "~a/~a ~v"
(string-ref (symbol->string orientation) 0)
(string-ref (symbol->string interest-type) 0)
topic))
(define (apply-action! a)
(cond
[(core:yield? a) (void)]
[(core:at-meta-level? a) (apply-preaction! #t (core:at-meta-level-preaction a))]
[else (apply-preaction! #f a)]))
(define (apply-preaction! meta? p)
(match p
[(core:quit #f reason)
(set! current-historical-moment
(struct-copy historical-moment current-historical-moment
[alive? #f]))]
[(core:add-endpoint pre-eid role handler)
(set! current-historical-moment
(struct-copy historical-moment current-historical-moment
[endpoints (append (filter (lambda (e) (not (equal? (car e) pre-eid)))
(historical-moment-endpoints
current-historical-moment))
(list (list pre-eid meta? role)))]))]
[(core:delete-endpoint pre-eid reason)
(set! current-historical-moment
(struct-copy historical-moment current-historical-moment
[endpoints (filter (lambda (e) (not (equal? (car e) pre-eid)))
(historical-moment-endpoints
current-historical-moment))]))]
[_ (void)]))
(define (handle-from-vm x)
(define now (current-timestamp))
(match x
[(core:transition state actions)
(when (or (not booted?)
(not (equal? state (historical-moment-state current-historical-moment))))
(set! booted? #t)
(set! current-historical-moment
(struct-copy historical-moment current-historical-moment [state state]))
(record-event! now "Txn" "State" (~v state)))
(let loop ((a actions))
(cond
[(pair? a) (loop (car a)) (loop (cdr a))]
[(or (null? a) (eq? a #f) (void? a)) (void)]
[else (define-values (type detail) (format-action a))
(apply-action! a)
(record-event! now "Act" type detail)]))
(reply-to-vm x)]
[(cons meta? e)
(define prefix (if meta? "Meta" ""))
(match e
[(core:presence-event role)
(record-event! now "Evt" (string-append prefix "Presence") (format-role role))]
[(core:absence-event role reason)
(record-event! now "Evt" (string-append prefix "Absence")
(string-append (format-role role) " " (~v reason)))]
[(core:message-event _ message)
(record-event! now "Evt" (string-append prefix "Recv") (~v message))])
(reply-to-vm x)]))
(define (controller-thread-loop)
(sync (handle-evt from-vm
(lambda (x)
(queue-callback (lambda () (handle-from-vm x)))
(controller-thread-loop)))))
(super-new)
(select-historical-moment current-historical-moment)
(send frame show #t)
))

30
support/spy.rkt
View File

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

14
test-struct-map.rkt
View File

@ -1,14 +0,0 @@
#lang racket/base
(require "struct-map.rkt")
(require rackunit)
(provide (struct-out foo))
(struct foo (bar zot)
#:transparent
#:property prop:struct-map (lambda (f seed x)
(define-values (bar* seed*) (f (foo-bar x) seed))
(values (foo bar* (foo-zot x)) seed)))
(check-equal? (struct-map (lambda (x) (list '! x)) (foo 123 234))
(foo (list '! 123) 234))

297
unify.rkt
View File

@ -1,297 +0,0 @@
#lang racket/base
(require racket/set)
(require racket/match)
(require (only-in racket/class object?))
(require "struct-map.rkt")
(provide (struct-out variable)
(struct-out canonical-variable)
wild
wild?
non-wild?
ground?
variables-in
unify
unify/env
unify/vars
unify-match/vars
freshen
canonicalize
mgu-freshen
mgu-canonical
apply-subst
specialization?
upper-case-symbols->variables
upper-case-symbols->canonical)
;; A Subst is a Maybe<AList<Variable,Any>>.
;; TODO: semantics
;; Compared by eq?, not equal?. In particular, info is not involved in
;; equivalence.
(struct variable (info)
#:property prop:custom-write
(lambda (v port mode)
(display "?" port)
(write (variable-info v) port)))
;; Compared by equal?, not eq?. The number is a part of the
;; appropriate equivalence relation for canonical-variables.
(struct canonical-variable (index) #:transparent
#:property prop:custom-write
(lambda (v port mode)
(display "?!" port)
(write (canonical-variable-index v) port)))
;; -> Variable
;; Create a fresh (and hence unconstrained) variable.
(define (wild [base-name '_])
(variable (gensym base-name)))
;; Any -> Boolean
;; True iff the argument is a variable or canonical-variable.
(define (wild? x)
(or (variable? x) (canonical-variable? x)))
;; Any -> Boolean
;; True iff the argument is neither a variable nor a canonical-variable.
(define (non-wild? x)
(not (wild? x)))
;; Any -> Boolean
;; Racket objects are structures, so we reject them explicitly for
;; now, leaving them opaque to unification.
(define (non-object-struct? x)
(and (struct? x)
(not (object? x))))
;; Any -> Set<Variable>
(define (variables-in x)
(let walk ((x x) (acc (set)))
(cond
[(wild? x) (set-add acc x)]
[(pair? x) (walk (car x) (walk (cdr x) acc))]
[(vector? x) (foldl walk acc (vector->list x))]
[(non-object-struct? x) (walk (struct->vector x #f) acc)]
[else acc])))
;; Any -> Boolean
;; True iff the term is completely ground, that is has no variables or
;; canonical-variables in it.
(define (ground? x)
(let walk ((x x))
(cond
[(wild? x) #f]
[(pair? x) (and (walk (car x)) (walk (cdr x)))]
[(vector? x) (andmap walk (vector->list x))]
[(non-object-struct? x) (walk (struct->vector x #f))]
[else #t])))
;; Variable Any -> Boolean
(define (occurs? var val)
(let walk ((x val))
(cond
[(eq? var x) #t]
[(pair? x) (or (walk (car x)) (walk (cdr x)))]
[(vector? x) (ormap walk (vector->list x))]
[(non-object-struct? x) (walk (struct->vector x #f))]
[else #f])))
;; Variable Any Subst -> Subst
(define (extend-subst var val env)
(cond
[(eq? var val)
;; Avoid trivial tautologies. Less trivial ones are not detected,
;; but are harmless.
env]
[(occurs? var val)
;; Occurs check.
#f]
[else
(cons (cons var val) env)]))
;; Any Subst Set<Variable> -> Any
(define (chase x env seen)
(if (variable? x)
(cond [(set-member? seen x) x]
[(assq x env) => (lambda (cell) (chase (cdr cell) env (set-add seen x)))]
[else x])
x))
;; Any Any -> Subst
(define (unify a b)
(unify/env a b '()))
;; Any Any Subst -> Subst
(define (unify/env a0 b0 env)
(let walk ((a0 a0) (b0 b0) (env env))
(and env
(let ((a (chase a0 env (set)))
(b (chase b0 env (set))))
(cond
[(variable? a) (extend-subst a b env)]
[(variable? b) (extend-subst b a env)]
[(and (pair? a) (pair? b))
(walk (car a) (car b) (walk (cdr a) (cdr b) env))]
[(and (vector? a) (vector? b) (= (vector-length a) (vector-length b)))
(for/fold ([env env]) ([ea a] [eb b]) (walk ea eb env))]
[(and (non-object-struct? a) (non-object-struct? b))
(walk (struct->vector a #f) (struct->vector b #f) env)]
[else (and (equal? a b) env)])))))
;; Any -> (values Any AList<Symbol,Variable>)
;; Converts upper-case symbols to variables, making sure that
;; eq? symbols map to eq? variables.
(define (upper-case-symbols->variables x)
(let walk ((x x) (env '()))
(cond
[(upper-case-symbol? x)
(cond [(assq x env) => (lambda (cell) (values (cdr cell) env))]
[else (let ((v (variable x))) (values v (cons (cons x v) env)))])]
[(pair? x)
(define-values (a env1) (walk (car x) env))
(define-values (d env2) (walk (cdr x) env1))
(values (cons a d) env2)]
[(vector? x)
(define result (make-vector (vector-length x)))
(values result (for/fold ([env env]) ([i (vector-length x)])
(define-values (val env1) (walk (vector-ref x i) env))
(vector-set! result i val)
env1))]
[(non-object-struct? x) (struct-map/accumulator walk env x)]
[else (values x env)])))
;; Any -> Any
(define (upper-case-symbols->canonical t)
(define env (make-hash)) ;; cheeky use of mutation
(let walk ((t t))
(cond
[(or (upper-case-symbol? t) (wild? t))
(cond [(hash-ref env t #f)]
[else (define v (canonical-variable (hash-count env))) (hash-set! env t v) v])]
[(pair? t) (cons (walk (car t)) (walk (cdr t)))]
[(vector? t) (list->vector (map walk (vector->list t)))]
[(non-object-struct? t) (struct-map walk t)]
[else t])))
;; Any -> Boolean
(define (upper-case-symbol? x)
(and (symbol? x)
(let ((name (symbol->string x)))
(and (positive? (string-length name))
(char-upper-case? (string-ref name 0))))))
;; AList<A,B> -> AList<B,A>
(define (flip-env env)
(map (lambda (x) (cons (cdr x) (car x))) env))
;; Any Any -> Subst
;; Like unify after upper-case-symbols->variables on both arguments.
(define (unify/vars a b)
(define-values (processed env) (upper-case-symbols->variables (cons a b)))
(define s (unify (car processed) (cdr processed)))
(and s (apply-subst s env)))
;; Any Any -> Subst
;; Like unify-match after upper-case-symbols->variables on both
;; arguments, extracting bindings only from the first argument.
(define (unify-match/vars a b)
(define-values (pa a-env) (upper-case-symbols->variables a))
(define-values (pb b-env) (upper-case-symbols->variables b))
(define s (unify pa pb))
(and s (apply-subst s a-env)))
;; Utility used by freshen and canonicalize below.
;; Must visit the term in the order specified by canonicalize
;; below. Here we rely both upon Racket's left-to-right evaluation
;; order and upon defined struct-mappers traversing their arguments in
;; some deterministic order.
(define (freshen* t var-handler canon-handler)
(define env (make-hash)) ;; cheeky use of mutation
(let walk ((t t))
(cond
[(wild? t)
(cond [(hash-ref env t #f)]
[else (define v ((if (canonical-variable? t) canon-handler var-handler) t env))
(hash-set! env t v)
v])]
[(pair? t) (cons (walk (car t)) (walk (cdr t)))]
[(vector? t) (list->vector (map walk (vector->list t)))]
[(non-object-struct? t) (struct-map walk t)]
[else t])))
;; Any -> Any
;;
;; Freshens a term by substituting out variables in the term with
;; fresh variables to produce an arbitrary member of the term's
;; alpha-equivalence-class that shares no variables with the original.
;;
;; Treats canonical-variables just like regular ones, freshening them
;; with new ordinary (non-canonical) variables.
(define (freshen t)
(freshen* t
(lambda (var env) (variable (variable-info var)))
(lambda (var env) (variable (canonical-variable-index var)))))
;; Any -> Any
;;
;; Canonicalizes a term by substituting out variables in the term with
;; canonical-variables to produce a canonical member of the term's
;; alpha-equivalence-class.
;;
;; Canonical variables are used in a structurally-determined order
;; related to print order: generally, all unseen variables to the left
;; of a term's print representation are given canonical equivalents
;; before those to the right.
;;
;; Canonical-variables may not appear in the input term.
(define (canonicalize t)
(freshen* t
(lambda (var env) (canonical-variable (hash-count env)))
(lambda (var env) (canonical-variable (hash-count env)))))
;; Any Any -> Any
;; If the arguments unify, applies the substitution to one of them,
;; yielding a most general unifier, and then freshens the result.
(define (mgu-freshen a b)
(define sub (unify a b))
(and sub (freshen (apply-subst sub a))))
;; Any Any -> Any
;; If the arguments unify, applies the substitution to one of them,
;; yielding a most general unifier, and then canonicalizes the result.
(define (mgu-canonical a b)
(define sub (unify a b))
(and sub (canonicalize (apply-subst sub a))))
;; Subst Any -> Any
(define (apply-subst env x)
(let walk ((x0 x))
(define x (chase x0 env (set)))
(cond
[(pair? x) (cons (walk (car x)) (walk (cdr x)))]
[(vector? x) (list->vector (map walk (vector->list x)))]
[(non-object-struct? x) (struct-map walk x)]
[else x])))
;; True iff a is a specialization (or instance) of b.
(define (specialization? a b)
(let walk ((a a) (b b))
(cond
[(wild? b) #t]
[(wild? a) #f]
[(and (pair? a) (pair? b))
(and (walk (car a) (car b)) (walk (cdr a) (cdr b)))]
[(and (vector? a) (vector? b) (= (vector-length a) (vector-length b)))
(for/and ([aa a] [bb b]) (walk aa bb))]
[(and (non-object-struct? a) (non-object-struct? b))
(walk (struct->vector a #f) (struct->vector b #f))]
[else (equal? a b)])))
(require racket/trace)
(trace ;;unify/env
;;upper-case-symbols->variables
;;apply-subst
;;specialization?
)

104
vm.rkt
View File

@ -1,104 +0,0 @@
#lang racket/base
(require racket/match)
(require "structs.rkt")
(require "roles.rkt")
(require "quasiqueue.rkt")
(provide vm-processes ;; (struct-out vm) doesn't work because of make-vm below (See PR13161)
vm-next-process-id
vm
vm?
(struct-out process)
(struct-out endpoint)
(struct-out eid)
make-vm
inject-process
extract-process
always-false
reset-pending-actions
process-map
endpoint-fold)
(struct vm (processes ;; (HashTable PID Process)
next-process-id ;; PID
)
#:transparent)
(struct process (debug-name ;; Any
pid ;; PID
state ;; State
spawn-ks ;; (Listof (Pairof Integer (TrapK PID State))) ;; hmm
endpoints ;; (HashTable PreEID (endpoint State))
meta-endpoints ;; (HashTable PreEID (endpoint State))
pending-actions ;; (QuasiQueue (Action State))
)
#:transparent)
(struct endpoint (id ;; eid
role ;; role
handler ;; (Handler State)
)
#:transparent)
(struct eid (pid ;; PID
pre-eid ;; PreEID
)
#:transparent)
;;---------------------------------------------------------------------------
;; make-vm : process-spec -> vm
(define (make-vm boot)
(define primordial (process '#:primordial
-1
(void)
(list)
#hash()
#hash()
(quasiqueue (spawn boot #f '#:boot-process))))
(vm (hash-set #hash() (process-pid primordial) primordial) 0))
;; inject-process : vm Process -> vm
(define (inject-process state wp)
(struct-copy vm state [processes (hash-set (vm-processes state) (process-pid wp) wp)]))
;; always-false : -> False
(define (always-false) #f)
;; extract-process : vm PID -> (values vm (Option Process))
(define (extract-process state pid)
(define wp (hash-ref (vm-processes state) pid always-false))
(values (if wp
(struct-copy vm state [processes (hash-remove (vm-processes state) pid)])
state)
wp))
;; reset-pending-actions : (All (State) (process State) -> (process State))
(define (reset-pending-actions p)
(struct-copy process p [pending-actions (empty-quasiqueue)]))
;; process-map : (All (State) (process State) -> (process State)) vm -> vm
;; TODO: simplify
(define (process-map f state)
(for/fold ([state state]) ([pid (in-hash-keys (vm-processes state))])
(let-values (((state wp) (extract-process state pid)))
(if (not wp)
state
(inject-process state (f wp))))))
;; endpoint-fold : (All (A) (All (State) (process State) (endpoint State) A -> A) A vm -> A)
(define (endpoint-fold f seed state)
(for/fold ([seed seed]) ([pid (in-hash-keys (vm-processes state))])
(let-values (((state wp) (extract-process state pid)))
(if (not wp)
seed
(for/fold ([seed seed]) ([pre-eid (in-hash-keys (process-endpoints wp))])
(define ep (hash-ref (process-endpoints wp) pre-eid))
(f wp ep seed))))))
;;; Local Variables:
;;; eval: (put 'unwrap-process 'scheme-indent-function 3)
;;; End: