├── .gitignore
├── LICENSE
├── README.md
├── doc
├── distributed-algorithms.md
├── evaluation-layout-complete-3.svg
├── evaluation-layout-complete-4.svg
├── evaluation-layout-complete-5.svg
├── evaluation-layout-complete-6.svg
├── evaluation-layout-complete-7.svg
├── evaluation-layout-manual-3.svg
├── evaluation-layout-manual-4.svg
├── evaluation-layout-manual-5.svg
├── evaluation-layout-manual-6.svg
├── evaluation-layout-manual-7.svg
├── evaluation.md
├── pldi-2024.pdf
├── reference-01-language.md
├── reference-02-runtime.md
├── tutorial-01-introduction.md
├── tutorial-02-basics.md
├── tutorial-03-sharing-knowledge.md
├── tutorial-04-composition.md
└── tutorial-05-execution.md
├── klor.svg
├── project.clj
└── src
└── klor
├── analyzer.clj
├── benchmark.clj
├── core.clj
├── defchor.clj
├── driver.clj
├── emit_form.clj
├── events.clj
├── examples.clj
├── fokkink.clj
├── fokkink_plain.clj
├── instrument.clj
├── opts.clj
├── projection.clj
├── runtime.clj
├── simulator.clj
├── sockets.clj
├── specials.clj
├── stdlib.clj
├── typecheck.clj
├── types.clj
├── util.clj
└── validate_roles.clj
/.gitignore:
--------------------------------------------------------------------------------
1 | /target
2 | /classes
3 | /checkouts
4 | profiles.clj
5 | pom.xml
6 | pom.xml.asc
7 | *.jar
8 | *.class
9 | /.lein-*
10 | /.nrepl-port
11 | /.prepl-port
12 | .hgignore
13 | .hg/
14 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | Eclipse Public License - v 2.0
2 |
3 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE
4 | PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION
5 | OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT.
6 |
7 | 1. DEFINITIONS
8 |
9 | "Contribution" means:
10 |
11 | a) in the case of the initial Contributor, the initial content
12 | Distributed under this Agreement, and
13 |
14 | b) in the case of each subsequent Contributor:
15 | i) changes to the Program, and
16 | ii) additions to the Program;
17 | where such changes and/or additions to the Program originate from
18 | and are Distributed by that particular Contributor. A Contribution
19 | "originates" from a Contributor if it was added to the Program by
20 | such Contributor itself or anyone acting on such Contributor's behalf.
21 | Contributions do not include changes or additions to the Program that
22 | are not Modified Works.
23 |
24 | "Contributor" means any person or entity that Distributes the Program.
25 |
26 | "Licensed Patents" mean patent claims licensable by a Contributor which
27 | are necessarily infringed by the use or sale of its Contribution alone
28 | or when combined with the Program.
29 |
30 | "Program" means the Contributions Distributed in accordance with this
31 | Agreement.
32 |
33 | "Recipient" means anyone who receives the Program under this Agreement
34 | or any Secondary License (as applicable), including Contributors.
35 |
36 | "Derivative Works" shall mean any work, whether in Source Code or other
37 | form, that is based on (or derived from) the Program and for which the
38 | editorial revisions, annotations, elaborations, or other modifications
39 | represent, as a whole, an original work of authorship.
40 |
41 | "Modified Works" shall mean any work in Source Code or other form that
42 | results from an addition to, deletion from, or modification of the
43 | contents of the Program, including, for purposes of clarity any new file
44 | in Source Code form that contains any contents of the Program. Modified
45 | Works shall not include works that contain only declarations,
46 | interfaces, types, classes, structures, or files of the Program solely
47 | in each case in order to link to, bind by name, or subclass the Program
48 | or Modified Works thereof.
49 |
50 | "Distribute" means the acts of a) distributing or b) making available
51 | in any manner that enables the transfer of a copy.
52 |
53 | "Source Code" means the form of a Program preferred for making
54 | modifications, including but not limited to software source code,
55 | documentation source, and configuration files.
56 |
57 | "Secondary License" means either the GNU General Public License,
58 | Version 2.0, or any later versions of that license, including any
59 | exceptions or additional permissions as identified by the initial
60 | Contributor.
61 |
62 | 2. GRANT OF RIGHTS
63 |
64 | a) Subject to the terms of this Agreement, each Contributor hereby
65 | grants Recipient a non-exclusive, worldwide, royalty-free copyright
66 | license to reproduce, prepare Derivative Works of, publicly display,
67 | publicly perform, Distribute and sublicense the Contribution of such
68 | Contributor, if any, and such Derivative Works.
69 |
70 | b) Subject to the terms of this Agreement, each Contributor hereby
71 | grants Recipient a non-exclusive, worldwide, royalty-free patent
72 | license under Licensed Patents to make, use, sell, offer to sell,
73 | import and otherwise transfer the Contribution of such Contributor,
74 | if any, in Source Code or other form. This patent license shall
75 | apply to the combination of the Contribution and the Program if, at
76 | the time the Contribution is added by the Contributor, such addition
77 | of the Contribution causes such combination to be covered by the
78 | Licensed Patents. The patent license shall not apply to any other
79 | combinations which include the Contribution. No hardware per se is
80 | licensed hereunder.
81 |
82 | c) Recipient understands that although each Contributor grants the
83 | licenses to its Contributions set forth herein, no assurances are
84 | provided by any Contributor that the Program does not infringe the
85 | patent or other intellectual property rights of any other entity.
86 | Each Contributor disclaims any liability to Recipient for claims
87 | brought by any other entity based on infringement of intellectual
88 | property rights or otherwise. As a condition to exercising the
89 | rights and licenses granted hereunder, each Recipient hereby
90 | assumes sole responsibility to secure any other intellectual
91 | property rights needed, if any. For example, if a third party
92 | patent license is required to allow Recipient to Distribute the
93 | Program, it is Recipient's responsibility to acquire that license
94 | before distributing the Program.
95 |
96 | d) Each Contributor represents that to its knowledge it has
97 | sufficient copyright rights in its Contribution, if any, to grant
98 | the copyright license set forth in this Agreement.
99 |
100 | e) Notwithstanding the terms of any Secondary License, no
101 | Contributor makes additional grants to any Recipient (other than
102 | those set forth in this Agreement) as a result of such Recipient's
103 | receipt of the Program under the terms of a Secondary License
104 | (if permitted under the terms of Section 3).
105 |
106 | 3. REQUIREMENTS
107 |
108 | 3.1 If a Contributor Distributes the Program in any form, then:
109 |
110 | a) the Program must also be made available as Source Code, in
111 | accordance with section 3.2, and the Contributor must accompany
112 | the Program with a statement that the Source Code for the Program
113 | is available under this Agreement, and informs Recipients how to
114 | obtain it in a reasonable manner on or through a medium customarily
115 | used for software exchange; and
116 |
117 | b) the Contributor may Distribute the Program under a license
118 | different than this Agreement, provided that such license:
119 | i) effectively disclaims on behalf of all other Contributors all
120 | warranties and conditions, express and implied, including
121 | warranties or conditions of title and non-infringement, and
122 | implied warranties or conditions of merchantability and fitness
123 | for a particular purpose;
124 |
125 | ii) effectively excludes on behalf of all other Contributors all
126 | liability for damages, including direct, indirect, special,
127 | incidental and consequential damages, such as lost profits;
128 |
129 | iii) does not attempt to limit or alter the recipients' rights
130 | in the Source Code under section 3.2; and
131 |
132 | iv) requires any subsequent distribution of the Program by any
133 | party to be under a license that satisfies the requirements
134 | of this section 3.
135 |
136 | 3.2 When the Program is Distributed as Source Code:
137 |
138 | a) it must be made available under this Agreement, or if the
139 | Program (i) is combined with other material in a separate file or
140 | files made available under a Secondary License, and (ii) the initial
141 | Contributor attached to the Source Code the notice described in
142 | Exhibit A of this Agreement, then the Program may be made available
143 | under the terms of such Secondary Licenses, and
144 |
145 | b) a copy of this Agreement must be included with each copy of
146 | the Program.
147 |
148 | 3.3 Contributors may not remove or alter any copyright, patent,
149 | trademark, attribution notices, disclaimers of warranty, or limitations
150 | of liability ("notices") contained within the Program from any copy of
151 | the Program which they Distribute, provided that Contributors may add
152 | their own appropriate notices.
153 |
154 | 4. COMMERCIAL DISTRIBUTION
155 |
156 | Commercial distributors of software may accept certain responsibilities
157 | with respect to end users, business partners and the like. While this
158 | license is intended to facilitate the commercial use of the Program,
159 | the Contributor who includes the Program in a commercial product
160 | offering should do so in a manner which does not create potential
161 | liability for other Contributors. Therefore, if a Contributor includes
162 | the Program in a commercial product offering, such Contributor
163 | ("Commercial Contributor") hereby agrees to defend and indemnify every
164 | other Contributor ("Indemnified Contributor") against any losses,
165 | damages and costs (collectively "Losses") arising from claims, lawsuits
166 | and other legal actions brought by a third party against the Indemnified
167 | Contributor to the extent caused by the acts or omissions of such
168 | Commercial Contributor in connection with its distribution of the Program
169 | in a commercial product offering. The obligations in this section do not
170 | apply to any claims or Losses relating to any actual or alleged
171 | intellectual property infringement. In order to qualify, an Indemnified
172 | Contributor must: a) promptly notify the Commercial Contributor in
173 | writing of such claim, and b) allow the Commercial Contributor to control,
174 | and cooperate with the Commercial Contributor in, the defense and any
175 | related settlement negotiations. The Indemnified Contributor may
176 | participate in any such claim at its own expense.
177 |
178 | For example, a Contributor might include the Program in a commercial
179 | product offering, Product X. That Contributor is then a Commercial
180 | Contributor. If that Commercial Contributor then makes performance
181 | claims, or offers warranties related to Product X, those performance
182 | claims and warranties are such Commercial Contributor's responsibility
183 | alone. Under this section, the Commercial Contributor would have to
184 | defend claims against the other Contributors related to those performance
185 | claims and warranties, and if a court requires any other Contributor to
186 | pay any damages as a result, the Commercial Contributor must pay
187 | those damages.
188 |
189 | 5. NO WARRANTY
190 |
191 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT
192 | PERMITTED BY APPLICABLE LAW, THE PROGRAM IS PROVIDED ON AN "AS IS"
193 | BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR
194 | IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF
195 | TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR
196 | PURPOSE. Each Recipient is solely responsible for determining the
197 | appropriateness of using and distributing the Program and assumes all
198 | risks associated with its exercise of rights under this Agreement,
199 | including but not limited to the risks and costs of program errors,
200 | compliance with applicable laws, damage to or loss of data, programs
201 | or equipment, and unavailability or interruption of operations.
202 |
203 | 6. DISCLAIMER OF LIABILITY
204 |
205 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT
206 | PERMITTED BY APPLICABLE LAW, NEITHER RECIPIENT NOR ANY CONTRIBUTORS
207 | SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
208 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION LOST
209 | PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
210 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
211 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE
212 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE
213 | POSSIBILITY OF SUCH DAMAGES.
214 |
215 | 7. GENERAL
216 |
217 | If any provision of this Agreement is invalid or unenforceable under
218 | applicable law, it shall not affect the validity or enforceability of
219 | the remainder of the terms of this Agreement, and without further
220 | action by the parties hereto, such provision shall be reformed to the
221 | minimum extent necessary to make such provision valid and enforceable.
222 |
223 | If Recipient institutes patent litigation against any entity
224 | (including a cross-claim or counterclaim in a lawsuit) alleging that the
225 | Program itself (excluding combinations of the Program with other software
226 | or hardware) infringes such Recipient's patent(s), then such Recipient's
227 | rights granted under Section 2(b) shall terminate as of the date such
228 | litigation is filed.
229 |
230 | All Recipient's rights under this Agreement shall terminate if it
231 | fails to comply with any of the material terms or conditions of this
232 | Agreement and does not cure such failure in a reasonable period of
233 | time after becoming aware of such noncompliance. If all Recipient's
234 | rights under this Agreement terminate, Recipient agrees to cease use
235 | and distribution of the Program as soon as reasonably practicable.
236 | However, Recipient's obligations under this Agreement and any licenses
237 | granted by Recipient relating to the Program shall continue and survive.
238 |
239 | Everyone is permitted to copy and distribute copies of this Agreement,
240 | but in order to avoid inconsistency the Agreement is copyrighted and
241 | may only be modified in the following manner. The Agreement Steward
242 | reserves the right to publish new versions (including revisions) of
243 | this Agreement from time to time. No one other than the Agreement
244 | Steward has the right to modify this Agreement. The Eclipse Foundation
245 | is the initial Agreement Steward. The Eclipse Foundation may assign the
246 | responsibility to serve as the Agreement Steward to a suitable separate
247 | entity. Each new version of the Agreement will be given a distinguishing
248 | version number. The Program (including Contributions) may always be
249 | Distributed subject to the version of the Agreement under which it was
250 | received. In addition, after a new version of the Agreement is published,
251 | Contributor may elect to Distribute the Program (including its
252 | Contributions) under the new version.
253 |
254 | Except as expressly stated in Sections 2(a) and 2(b) above, Recipient
255 | receives no rights or licenses to the intellectual property of any
256 | Contributor under this Agreement, whether expressly, by implication,
257 | estoppel or otherwise. All rights in the Program not expressly granted
258 | under this Agreement are reserved. Nothing in this Agreement is intended
259 | to be enforceable by any entity that is not a Contributor or Recipient.
260 | No third-party beneficiary rights are created under this Agreement.
261 |
262 | Exhibit A - Form of Secondary Licenses Notice
263 |
264 | "This Source Code may also be made available under the following
265 | Secondary Licenses when the conditions for such availability set forth
266 | in the Eclipse Public License, v. 2.0 are satisfied: GNU General Public
267 | License as published by the Free Software Foundation, either version 2
268 | of the License, or (at your option) any later version, with the GNU
269 | Classpath Exception which is available at
270 | https://www.gnu.org/software/classpath/license.html."
271 |
272 | Simply including a copy of this Agreement, including this Exhibit A
273 | is not sufficient to license the Source Code under Secondary Licenses.
274 |
275 | If it is not possible or desirable to put the notice in a particular
276 | file, then You may include the notice in a location (such as a LICENSE
277 | file in a relevant directory) where a recipient would be likely to
278 | look for such a notice.
279 |
280 | You may add additional accurate notices of copyright ownership.
281 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # Klor: Choreographies in Clojure
2 |
3 |
4 |
5 |
6 |
7 | [](https://clojars.org/org.clojars.klor/klor)
8 |
9 | Klor is a domain-specific language for choreographic programming, embedded in Clojure.
10 |
11 | ## Tutorial
12 |
13 | If you're new to Klor or choreographic programming, check out the tutorial to learn more:
14 |
15 | - [Introduction](./doc/tutorial-01-introduction.md)
16 | - [Basics](./doc/tutorial-02-basics.md)
17 | - [Sharing Knowledge](./doc/tutorial-03-sharing-knowledge.md)
18 | - [Composition](./doc/tutorial-04-composition.md)
19 | - [Execution](./doc/tutorial-05-execution.md)
20 |
21 | We also gave a [talk](https://www.youtube.com/watch?v=E-QzNKqdqo4) on Klor at [Heart of Clojure 2024](https://2024.heartofclojure.eu/):
22 |
23 |
24 |
25 |
26 |
27 | ## Reference
28 |
29 | The reference provides a compact technical description of Klor:
30 |
31 | - [Language](./doc/reference-01-language.md)
32 | - [Runtime](./doc/reference-02-runtime.md)
33 |
34 | ## Funding
35 |
36 | This project is funded through the [NGI Assure Fund](https://nlnet.nl/assure), a fund established by [NLnet](https://nlnet.nl) with financial support from the European Commission's [Next Generation Internet](https://ngi.eu) program.
37 | Learn more at the [NLnet project page](https://nlnet.nl/project/ChoreographicProgramming).
38 |
39 | [](https://nlnet.nl)
40 |
41 | [](https://nlnet.nl/assure)
42 |
--------------------------------------------------------------------------------
/doc/distributed-algorithms.md:
--------------------------------------------------------------------------------
1 | # Distributed Algorithms
2 |
3 | ## Chang--Roberts algorithm
4 |
5 | The Chang--Roberts algorithm is a *leader election algorithm* for *ring networks*.
6 | It assumes that each role has a *unique identifier*.
7 |
8 | It is implemented by the Klor choreography `(chang-roberts [+] +)`:
9 |
10 | - The given roles are connected in a ring formation from left to right, with the last role wrapping around to the first.
11 |
12 | - Each `` is an expression that evaluates to a map providing the initial state of each role, in order of their appearance in the role list.
13 | The map must contain an `:id` key whose value is the identifier, distinct from any other role's identifier.
14 | The map can also contain a `:passive?` key whose value is a boolean that determines whether the role participates in the election process or only forwards messages.
15 |
16 | - The return value is a choreographic tuple containing the final states of the roles, in order of their appearance in the role list.
17 | The state will contain the `:leader` key whose value is the identifier of the elected leader.
18 |
19 | The following example uses Chang--Roberts to elect a leader among 3 roles (`B`, `C` and `D`) whose identifiers are randomly-chosen (but unique) by a separate role `A`:
20 |
21 | ```clojure
22 | (defchor elect-leader-1 [A B C D] (-> [B C D]) []
23 | (unpack [[id1 id2 id3]
24 | (scatter-seq [A B C D] (A (take 3 (shuffle (range 10)))))]
25 | (chang-roberts [B C D] (B {:id id1}) (C {:id id2}) (D {:id id3}))))
26 | ```
27 |
28 | ```
29 | A --> C: 3
30 | A --> B: 7
31 | A --> D: 0
32 | C --> D: [:propose {:id 3}]
33 | B --> C: [:propose {:id 7}]
34 | C --> D: [:propose {:id 7}]
35 | D --> B: [:propose {:id 0}]
36 | D --> B: [:propose {:id 3}]
37 | D --> B: [:propose {:id 7}]
38 | B --> C: [:exit {:id 7}]
39 | C --> D: [:exit {:id 7}]
40 | D --> B: [:exit {:id 7}]
41 | ```
42 |
43 | ```
44 | {A #function[klor.runtime/noop],
45 | B [{:id 7, :leader 7, :leader? true}],
46 | C [{:id 3, :passive? true, :leader 7}],
47 | D [{:id 0, :passive? true, :leader 7}]}
48 | ```
49 |
50 | ## Itai--Rodeh algorithm
51 |
52 | The Itai--Rodeh algorithm is a refinement of Chang--Roberts that can deal with *duplicate identifiers* using a *probabilistic approach*.
53 | This is useful in the context of *anonymous networks* where nodes either don't have or cannot reveal their unique identifier.
54 |
55 | It is implemented by the Klor choreography `(itai-rodeh [+] +)`:
56 |
57 | - The parameters have the same meaning as in `chang-roberts`, except that the roles' individual `:id` keys do not have to be unique.
58 | Actually, the `:id` keys can even be left out in which case they will be randomly-chosen integers.
59 |
60 | - The return value is a choreographic tuple as in `chang-roberts`.
61 |
62 | The following example uses Itai--Rodeh to elect a leader among 3 roles that start out with randomly-chosen identifiers:
63 |
64 | ```clojure
65 | (defchor elect-leader-2 [A B C] (-> [A B C]) []
66 | (itai-rodeh [A B C] (A {}) (B {:id (rand-int 5)}) (C {})))
67 | ```
68 |
69 | ```
70 | A --> B: [:propose {:hops 1, :round 0, :id 1, :dup? false}]
71 | C --> A: [:propose {:hops 1, :round 0, :id 2, :dup? false}]
72 | B --> C: [:propose {:hops 1, :round 0, :id 1, :dup? false}]
73 | A --> B: [:propose {:hops 2, :round 0, :id 2, :dup? false}]
74 | B --> C: [:propose {:id 1, :round 0, :hops 2, :dup? true}]
75 | B --> C: [:propose {:hops 3, :round 0, :id 2, :dup? false}]
76 | C --> A: [:exit {:hops 1}]
77 | A --> B: [:exit {:hops 2}]
78 | B --> C: [:exit {:hops 3}]
79 | ```
80 |
81 | ```
82 | {A [{:round 0, :id 1, :passive? true, :leader 2}],
83 | B [{:round 0, :id 1, :passive? true, :leader 2}],
84 | C [{:round 0, :id 2, :leader 2, :leader? true}]}
85 | ```
86 |
87 | ## Tarry's algorithm
88 |
89 | Tarry's algorithm is a *traversal algorithm* for *undirected networks*.
90 | A message will be passed throughout the whole network with the guarantee that each node will send to each of its neighbors *exactly once*.
91 |
92 | It is implemented by the Klor choreography `(tarry [+] )`:
93 |
94 | - The given roles are connected in a formation as described by `` using the following grammar:
95 |
96 | ```
97 | ::= [*]
98 | ::= (+)
99 | ::=
100 | ::= -> | <- | --
101 | ```
102 |
103 | The layout is essentially a sequence of chains, each consisting of one or more uni- or bidirectional links.
104 | This makes it convenient to specify arbitrary connectivity graphs.
105 |
106 | - The first role in the list is the *initiator* of the traversal.
107 |
108 | - The return value is a choreographic tuple containing the final states of the roles, in order of their appearance in the role list.
109 | The state will contain the `:parent` key whose value is the name of the role that first forwarded a message to the respective role, or `:root` if the role was the initiator.
110 |
111 | The following example uses Tarry's algorithm to traverse a small network of 5 roles:
112 |
113 | ```clojure
114 | (defchor traverse-1 [A B C D E] (-> [A B C D E]) []
115 | (tarry [A B C D E] [(C -- B -- A -- D -- E -- B) (A -- E)]))
116 | ```
117 |
118 | ```
119 | A --> D: [:token {:hops 1}]
120 | D --> E: [:token {:hops 2}]
121 | E --> A: [:token {:hops 3}]
122 | A --> E: [:token {:hops 4}]
123 | E --> B: [:token {:hops 5}]
124 | B --> A: [:token {:hops 6}]
125 | A --> B: [:token {:hops 7}]
126 | B --> C: [:token {:hops 8}]
127 | C --> B: [:token {:hops 9}]
128 | B --> E: [:token {:hops 10}]
129 | E --> D: [:token {:hops 11}]
130 | D --> A: [:token {:hops 12}]
131 | ```
132 |
133 | ```
134 | {A [{:parent :root, :seen #{D B E}}],
135 | B [{:seen #{A C E}, :parent E}],
136 | C [{:seen #{B}, :parent B}],
137 | D [{:seen #{A E}, :parent A}],
138 | E [{:seen #{A D B}, :parent D}]}
139 | ```
140 |
141 | ## Depth-first search
142 |
143 | Depth-first search is a refinement of Tarry's algorithm that traverses the network in a *depth-first order*.
144 |
145 | It is implemented by the Klor choreography `(dfs [+] )`:
146 |
147 | - The parameters and the return value are as in `tarry`.
148 |
149 | The following example uses depth-first search to traverse the same example network from above:
150 |
151 | ```clojure
152 | (defchor traverse-2 [A B C D E] (-> [A B C D E]) []
153 | (dfs [A B C D E] [(C -- B -- A -- D -- E -- B) (A -- E)]))
154 | ```
155 |
156 | ```
157 | A --> D: [:token {:hops 1}]
158 | D --> E: [:token {:hops 2}]
159 | E --> A: [:token {:hops 3}]
160 | A --> E: [:token {:hops 4}]
161 | E --> B: [:token {:hops 5}]
162 | B --> C: [:token {:hops 6}]
163 | C --> B: [:token {:hops 7}]
164 | B --> A: [:token {:hops 8}]
165 | A --> B: [:token {:hops 9}]
166 | B --> E: [:token {:hops 10}]
167 | E --> D: [:token {:hops 11}]
168 | D --> A: [:token {:hops 12}]
169 | ```
170 |
171 | ```
172 | {A [{:parent :root, :seen #{D B E}}],
173 | B [{:seen #{A C E}, :parent E}],
174 | C [{:seen #{B}, :parent B}],
175 | D [{:seen #{A E}, :parent A}],
176 | E [{:seen #{A D B}, :parent D}]}
177 | ```
178 |
179 | ## Echo algorithm
180 |
181 | The echo algorithm is a *wave algorithm* for *undirected networks*, which will distribute a message across a network in a manner similar to *breadth-first* search.
182 |
183 | It is implemented by the Klor choreography `(echo [+] )`:
184 |
185 | - The parameters and the return value are as in `tarry`.
186 |
187 | The following example uses the echo algorithm to distribute a message throughout the example network:
188 |
189 | ```clojure
190 | (defchor distribute [A B C D E] (-> [A B C D E]) []
191 | (echo [A B C D E] [(C -- B -- A -- D -- E -- B -- D) (A -- E)]))
192 | ```
193 |
194 | ```
195 | A --> B: [:token {:hops 1}]
196 | B --> D: [:token {:hops 2}]
197 | A --> D: [:token {:hops 1}]
198 | B --> C: [:token {:hops 2}]
199 | D --> A: [:token {:hops 3}]
200 | C --> B: [:token {:hops 3}]
201 | B --> E: [:token {:hops 2}]
202 | A --> E: [:token {:hops 1}]
203 | E --> A: [:token {:hops 3}]
204 | E --> D: [:token {:hops 3}]
205 | D --> B: [:token {:hops 4}]
206 | D --> E: [:token {:hops 3}]
207 | E --> B: [:token {:hops 4}]
208 | B --> A: [:token {:hops 5}]
209 | ```
210 |
211 | ```
212 | {A [{:todo #{}, :parent :root}],
213 | B [{:todo #{}, :parent A}],
214 | C [{:todo #{}, :parent B}],
215 | D [{:todo #{}, :parent B}],
216 | E [{:todo #{}, :parent B}]}
217 | ```
218 |
219 | ## Echo algorithm with extinction
220 |
221 | The echo algorithm with extinction is a *leader election algorithm* for *undirected networks* based on the echo algorithm.
222 | Each node initiates a wave of the echo algorithm in hope of becoming a leader.
223 | The algorithm assumes that each role has a *unique identifier*.
224 |
225 | It is implemented by the Klor choreography `(echoex [+] +)`:
226 |
227 | - The `` and `` arguments are as in `tarry`.
228 |
229 | - The `` arguments are as in `chang-roberts`: they represent the initial states of the roles and must contain an `:id` key whose value is the unique role identifier.
230 |
231 | - The return value is a choreographic tuple containing the final states of the roles, in order of their appearance in the role list.
232 | The state will contain the `:wave` key whose value is the identifier of the elected leader..
233 |
234 | The following example uses the echo algorithm with extinction to elect a leader within the example network:
235 |
236 | ```clojure
237 | (defchor elect-leader-3 [A B C D E] (-> [A B C D E]) []
238 | (let [ids (A (take 5 (shuffle (range 10))))
239 | id1 (A (first ids))]
240 | (unpack [[id2 id3 id4 id5] (scatter-seq [A B C D E] (rest ids))]
241 | (echoex [A B C D E] [(C -- B -- A -- D -- E -- B -- D) (A -- E)]
242 | (A {:id id1}) (B {:id id2}) (C {:id id3})
243 | (D {:id id4}) (E {:id id5})))))
244 | ```
245 |
246 | ```
247 | A --> B: 0
248 | A --> D: 3
249 | A --> E: 5
250 | A --> C: 7
251 | B --> D: [:token {:id 0}]
252 | D --> A: [:token {:id 3}]
253 | B --> A: [:token {:id 0}]
254 | A --> D: [:token {:id 6}]
255 | ...
256 | A --> E: [:token {:id 7}]
257 | D --> E: [:token {:id 7}]
258 | E --> D: [:token {:id 7}]
259 | E --> B: [:token {:id 7}]
260 | D --> B: [:token {:id 7}]
261 | B --> C: [:token {:id 7}]
262 | ```
263 |
264 | ```
265 | {A [{:id 6, :itodo #{D B E}, :parent B, :todo #{}, :wave 7, :exit true}],
266 | B [{:id 0, :itodo #{A D C E}, :parent C, :todo #{}, :wave 7, :exit true}],
267 | C [{:id 7, :itodo #{B}, :parent :root, :todo #{}, :wave 7, :exit true}],
268 | D [{:id 3, :itodo #{A B E}, :parent B, :todo #{}, :wave 7, :exit true}],
269 | E [{:id 5, :itodo #{A D B}, :parent B, :todo #{}, :wave 7, :exit true}]}
270 | ```
271 |
--------------------------------------------------------------------------------
/doc/evaluation-layout-complete-3.svg:
--------------------------------------------------------------------------------
1 |
2 |
4 |
6 |
7 |
42 |
--------------------------------------------------------------------------------
/doc/evaluation-layout-complete-4.svg:
--------------------------------------------------------------------------------
1 |
2 |
4 |
6 |
7 |
62 |
--------------------------------------------------------------------------------
/doc/evaluation-layout-complete-5.svg:
--------------------------------------------------------------------------------
1 |
2 |
4 |
6 |
7 |
87 |
--------------------------------------------------------------------------------
/doc/evaluation-layout-complete-6.svg:
--------------------------------------------------------------------------------
1 |
2 |
4 |
6 |
7 |
117 |
--------------------------------------------------------------------------------
/doc/evaluation-layout-complete-7.svg:
--------------------------------------------------------------------------------
1 |
2 |
4 |
6 |
7 |
152 |
--------------------------------------------------------------------------------
/doc/evaluation-layout-manual-3.svg:
--------------------------------------------------------------------------------
1 |
2 |
4 |
6 |
7 |
42 |
--------------------------------------------------------------------------------
/doc/evaluation-layout-manual-4.svg:
--------------------------------------------------------------------------------
1 |
2 |
4 |
6 |
7 |
57 |
--------------------------------------------------------------------------------
/doc/evaluation-layout-manual-5.svg:
--------------------------------------------------------------------------------
1 |
2 |
4 |
6 |
7 |
67 |
--------------------------------------------------------------------------------
/doc/evaluation-layout-manual-6.svg:
--------------------------------------------------------------------------------
1 |
2 |
4 |
6 |
7 |
87 |
--------------------------------------------------------------------------------
/doc/evaluation-layout-manual-7.svg:
--------------------------------------------------------------------------------
1 |
2 |
4 |
6 |
7 |
92 |
--------------------------------------------------------------------------------
/doc/evaluation.md:
--------------------------------------------------------------------------------
1 | # Evaluation
2 |
3 | ## Methodology
4 |
5 | We implemented a [benchmark](../src/klor/benchmark.clj) to carry out a performance evaluation of Klor based on the [implemented](../src/klor/fokkink.clj) [distributed algorithms](./distributed-algorithms.md).
6 | We evaluated the compile-time and the run-time performance using the following selection of algorithms: Chang--Roberts, Itai--Rodeh, Tarry's algorithm, Depth-first search, Echo algorithm, and Echo algorithm with extinction.
7 |
8 | In particular, we performed a series of measurements for each combination of algorithm, number of roles (from 3 to 7) and network layout.
9 | The first two algorithms, Chang--Roberts and Itai--Rodeh, specifically work only on ring networks.
10 | The other algorithms work on arbitrary undirected networks, so we tested each one with both a manually chosen layout and a fully connected layout.
11 | The following table shows the layouts we used:
12 |
13 | | n | Manually chosen layout | Fully connected layout |
14 | |--:|:----------------------------------------------:|:------------------------------------------------:|
15 | | 3 | | |
16 | | 4 | | |
17 | | 5 | | |
18 | | 6 | | |
19 | | 7 | | |
20 |
21 | To make measurements consistent and statistically meaningful, we made use of the [Criterium](https://github.com/hugoduncan/criterium) library to aggregate the data from a series of executions and account for the peculiarities of the JVM's just-in-time compiler and garbage collector.
22 | All of the measurements were made on a Linux x86-64 system with an Intel i5-6500 3.20 GHz CPU and 40 GiB of RAM.
23 |
24 | ## Compile-time Performance
25 |
26 | The compile-time phase of Klor consists of parsing the Klor code into an AST, analyzing the AST (type checking, etc.) and compiling (projecting) it to separate pieces of Clojure code for each role.
27 | Evaluating the performance of this phase gives us an idea of how fast Klor is at processing code, which indirectly affects the compilation of any Clojure project using Klor and the experience of developers using Klor interactively at a Clojure REPL.
28 |
29 | We measured the compile-time performance by timing the expansion of Klor's `defchor` macro, which implements all of the above.
30 | The tables below report the means and the standard deviations of the measurements for the manually chosen and the fully connected layouts, respectively:
31 |
32 | | Algorithm | n = 3 | n = 4 | n = 5 | n = 6 | n = 7 |
33 | |--------------------|------------:|-------------:|------------:|-------------:|-------------:|
34 | | Chang--Roberts | (44 ± 1) ms | (58 ± 3) ms | (72 ± 2) ms | (91 ± 6) ms | (101 ± 3) ms |
35 | | Itai--Rodeh | (50 ± 2) ms | (76 ± 18) ms | (78 ± 5) ms | (93 ± 3) ms | (113 ± 6) ms |
36 | | Tarry's algorithm | (41 ± 2) ms | (58 ± 3) ms | (71 ± 2) ms | (91 ± 3) ms | (105 ± 4) ms |
37 | | Depth-first search | (41 ± 2) ms | (58 ± 3) ms | (70 ± 1) ms | (93 ± 3) ms | (105 ± 4) ms |
38 | | Echo algorithm | (40 ± 2) ms | (56 ± 3) ms | (69 ± 2) ms | (91 ± 3) ms | (101 ± 3) ms |
39 | | Echo w/ extinction | (43 ± 2) ms | (62 ± 3) ms | (77 ± 2) ms | (106 ± 6) ms | (120 ± 6) ms |
40 |
41 | | Algorithm | n = 3 | n = 4 | n = 5 | n = 6 | n = 7 |
42 | |--------------------|------------:|------------:|------------:|-------------:|-------------:|
43 | | Chang--Roberts | (44 ± 2) ms | (58 ± 4) ms | (71 ± 3) ms | (87 ± 3) ms | (104 ± 3) ms |
44 | | Itai--Rodeh | (50 ± 2) ms | (65 ± 3) ms | (77 ± 2) ms | (93 ± 3) ms | (110 ± 6) ms |
45 | | Tarry's algorithm | (42 ± 2) ms | (59 ± 4) ms | (71 ± 2) ms | (93 ± 3) ms | (104 ± 4) ms |
46 | | Depth-first search | (42 ± 2) ms | (58 ± 3) ms | (70 ± 2) ms | (92 ± 3) ms | (104 ± 4) ms |
47 | | Echo algorithm | (40 ± 2) ms | (56 ± 3) ms | (69 ± 2) ms | (90 ± 3) ms | (101 ± 4) ms |
48 | | Echo w/ extinction | (44 ± 2) ms | (62 ± 3) ms | (78 ± 2) ms | (107 ± 6) ms | (119 ± 6) ms |
49 |
50 | The above data shows that it takes Klor only a fraction of a second to analyze and compile various instances of the distributed algorithms.
51 | Compilation also scales well with the number of roles (roughly linearly), though in general this will depend on the particular choreography and the way it is implemented (due to Klor's support for macros which can generate arbitrary amounts of code).
52 |
53 | We find that Klor is already quite fast and perfectly suitable for the REPL-centric style of development that Clojurians (and other Lispers) find indispensable.
54 | This also matches our own personal experience of working with Klor while implementing the mentioned distributed algorithms.
55 | In general, having a tight feedback loop significantly increases developer productivity.
56 |
57 | ## Run-time Performance
58 |
59 | Klor's run-time phase corresponds to the execution of the projected code.
60 | Since Klor freely interoperates with and compiles down to Clojure, it naturally inherits all of its performance characteristics.
61 | However, for run-time performance we are mainly interested in measuring the overhead introduced by Klor compared to plain Clojure.
62 |
63 | For this reason, in addition to the Klor implementations of the algorithms, we also implemented [plain Clojure variants](../src/klor/fokkink_plain.clj) of each algorithm.
64 | We measured the run-time performance by timing the execution of each variant of the algorithm (`K` for Klor vs. `P` for plain Clojure).
65 | In both cases we've used the shared memory `core.async` channels as the underlying transport mechanism, which allows us to avoid highly variable transport latencies as much as possible and measure the overhead.
66 |
67 | The tables below report the means and the standard deviations of the measurements for the manually chosen and the fully connected layouts, respectively:
68 |
69 | | Algorithm | n = 3 | n = 4 | n = 5 | n = 6 | n = 7 |
70 | |------------------------|----------------:|----------------:|----------------:|----------------:|----------------:|
71 | | Chang--Roberts (K) | (867 ± 115) μs | (1076 ± 128) μs | (1319 ± 140) μs | (1556 ± 157) μs | (1766 ± 188) μs |
72 | | Chang--Roberts (P) | (367 ± 11) μs | (471 ± 60) μs | (568 ± 13) μs | (759 ± 114) μs | (785 ± 34) μs |
73 | | Itai--Rodeh (K) | (1058 ± 88) μs | (1267 ± 161) μs | (1751 ± 365) μs | (1832 ± 200) μs | (2137 ± 263) μs |
74 | | Itai--Rodeh (P) | (519 ± 35) μs | (677 ± 25) μs | (803 ± 49) μs | (1056 ± 310) μs | (1093 ± 51) μs |
75 | | Tarry's algorithm (K) | (1053 ± 161) μs | (1580 ± 200) μs | (1886 ± 229) μs | (2772 ± 360) μs | (2666 ± 313) μs |
76 | | Tarry's algorithm (P) | (410 ± 13) μs | (590 ± 42) μs | (755 ± 30) μs | (1106 ± 157) μs | (1050 ± 79) μs |
77 | | Depth-first search (K) | (1061 ± 149) μs | (1610 ± 198) μs | (1865 ± 182) μs | (2744 ± 353) μs | (2706 ± 259) μs |
78 | | Depth-first search (P) | (365 ± 34) μs | (626 ± 17) μs | (737 ± 21) μs | (1049 ± 48) μs | (969 ± 86) μs |
79 | | Echo algorithm (K) | (766 ± 154) μs | (1037 ± 204) μs | (1225 ± 172) μs | (1659 ± 263) μs | (1793 ± 317) μs |
80 | | Echo algorithm (P) | (293 ± 37) μs | (411 ± 40) μs | (472 ± 69) μs | (623 ± 53) μs | (701 ± 72) μs |
81 | | Echo w/ extinction (K) | (1413 ± 303) μs | (1651 ± 270) μs | (1916 ± 290) μs | (2576 ± 396) μs | (3000 ± 413) μs |
82 | | Echo w/ extinction (P) | (540 ± 13) μs | (847 ± 96) μs | (1224 ± 145) μs | (1205 ± 113) μs | (1577 ± 90) μs |
83 |
84 | | Algorithm | n = 3 | n = 4 | n = 5 | n = 6 | n = 7 |
85 | |------------------------|----------------:|----------------:|----------------:|----------------:|----------------:|
86 | | Chang--Roberts (K) | (883 ± 121) μs | (1078 ± 104) μs | (1285 ± 137) μs | (1531 ± 144) μs | (1751 ± 167) μs |
87 | | Chang--Roberts (P) | (379 ± 25) μs | (468 ± 46) μs | (547 ± 29) μs | (682 ± 80) μs | (758 ± 25) μs |
88 | | Itai--Rodeh (K) | (993 ± 129) μs | (1270 ± 146) μs | (1537 ± 142) μs | (1787 ± 206) μs | (2070 ± 169) μs |
89 | | Itai--Rodeh (P) | (451 ± 67) μs | (654 ± 42) μs | (824 ± 30) μs | (951 ± 60) μs | (1077 ± 62) μs |
90 | | Tarry's algorithm (K) | (1065 ± 143) μs | (1590 ± 212) μs | (1903 ± 225) μs | (2760 ± 325) μs | (2688 ± 308) μs |
91 | | Tarry's algorithm (P) | (351 ± 17) μs | (616 ± 43) μs | (729 ± 36) μs | (1020 ± 50) μs | (1068 ± 82) μs |
92 | | Depth-first search (K) | (1064 ± 143) μs | (1584 ± 204) μs | (1899 ± 218) μs | (2786 ± 312) μs | (2712 ± 331) μs |
93 | | Depth-first search (P) | (377 ± 36) μs | (602 ± 52) μs | (668 ± 57) μs | (1136 ± 76) μs | (1036 ± 68) μs |
94 | | Echo algorithm (K) | (781 ± 135) μs | (1057 ± 209) μs | (1813 ± 318) μs | (1669 ± 280) μs | (1763 ± 339) μs |
95 | | Echo algorithm (P) | (328 ± 14) μs | (404 ± 32) μs | (447 ± 43) μs | (617 ± 87) μs | (694 ± 47) μs |
96 | | Echo w/ extinction (K) | (1153 ± 150) μs | (1676 ± 241) μs | (1916 ± 264) μs | (2741 ± 500) μs | (2995 ± 375) μs |
97 | | Echo w/ extinction (P) | (538 ± 20) μs | (778 ± 54) μs | (990 ± 100) μs | (1188 ± 92) μs | (1566 ± 104) μs |
98 |
99 | From the above data we can see that Klor does introduce some overhead compared to the plain Clojure variants of the algorithms, roughly 2-3x depending on the scenario.
100 | In absolute terms however, the overhead is in the order of a few hundred microseconds or a single millisecond in all cases, which is negligible compared to the latencies of transport mechanisms (i.e. IO) normally used by real-world distributed systems, such as those backed by a network rather than shared memory.
101 |
102 | Overall, we think Klor's current performance is satisfactory, especially given the fact that additional optimizations could be implemented in the future.
103 |
--------------------------------------------------------------------------------
/doc/pldi-2024.pdf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/lovrosdu/klor/991c9ad5867ef85c1d09e50b2f0090fb30257603/doc/pldi-2024.pdf
--------------------------------------------------------------------------------
/doc/reference-02-runtime.md:
--------------------------------------------------------------------------------
1 | # Reference: Runtime
2 |
3 | ## Execution Model
4 |
5 | Choreographic programming assumes the **concurrent execution** of all roles in a choreography.
6 | Abstractly, all subexpressions of a choreography are evaluated **out-of-order up to role dependency**.
7 | This means that their evaluation can be arbitrarily interleaved, except that sequentiality is maintained between all expressions located at the same role, including any **communication actions** initiated by the role (sends and receives to/from other roles).
8 | Receives are assumed to be **blocking (synchronous)** while sends can be either blocking or non-blocking.
9 |
10 | ## Projection
11 |
12 | The execution model is implemented by **projecting** a choreography to a separate Clojure function for each role and executing all of them concurrently via some concurrency mechanism -- multiple threads, processes, nodes, any combination thereof, etc.
13 | Each projection retains only the subexpressions relevant to the particular role and incorporates the necessary communication actions to interact with other roles as specified by the choreography.
14 |
15 | A full treatment of the theory of projection with all of its details and properties is out of the scope of this document, but we try to give a working summary here.
16 | For more details the [Introduction to Choreographies](https://doi.org/10.1017/9781108981491) book is a good starting point.
17 |
18 | In general, the projection of a Klor expression for a role depends on the expression's choreographic type and the roles it **mentions**.
19 | An expression is projected differently for a role `r` depending on whether it **has a result** for `r` (involves `r` in its type), **only mentions** `r` (only involves `r` in its subexpressions), or **doesn't mention** `r` at all.
20 | Projection works **recursively** through the subexpressions of a Klor expression and applies these considerations at every step in order to generate code that contains all of the necessary expressions and communication actions described by the choreography.
21 | The rough idea is:
22 |
23 | - If the expression **has a result** for `r`, the projection generates code to yield that result, including any necessary communication actions between the roles. All appropriate subexpressions are projected recursively.
24 | - Otherwise, if the expression **only mentions** `r` (in its subexpressions), it is projected to code that ultimately evaluates to the special `klor.runtime/noop` value representing the absence of a choreographic value, but first carries out all of the necessary computation required by the recursive projection of its subexpressions.
25 | - Otherwise, if the expression **doesn't mention** `r` at all, the projection is just the `klor.runtime/noop` value.
26 |
27 | Special operators are the base cases of the recursive procedure.
28 | A few of the more important ones are described briefly:
29 |
30 | - `copy` projects to corresponding send and receive actions at the source and destination, respectively.
31 | - `chor` projects to Clojure anonymous functions, each representing a projection of the anonymous choreography.
32 | - `do` projects to a Clojure `do` with each expression in its body projected recursively. The `do` is effectively "pulled apart" and its pieces are distributed among the roles. This means that it does **not** maintain sequential execution of its subexpressions across roles but only within each role. We call this **choreographic sequencing**.
33 | - `if` projects to a Clojure `if` for all of the roles that have a result for the guard expression. If a role does not have a result for the guard, it cannot participate in either of the branches.
34 |
35 | ## Invoking Projections
36 |
37 | The `(klor.runtime/play-role *)` function invokes a particular projection of a Klor choreography.
38 |
39 | `` is called the **role configuration**.
40 | It is a map that describes which role's projection to invoke and how to communicate with other roles.
41 | Its structure is the following:
42 |
43 | ```clojure
44 | {:role
45 | :send
46 | :recv
47 | :locators { ... }}
48 | ```
49 |
50 | `` is an unqualified symbol that names the role to play.
51 | It has to match one of the role parameters of the choreography (as they appear in its role vector).
52 |
53 | `` and `` form the **transport** that defines how values are actually communicated to/from other roles.
54 | When a role has to send or receive a normal value, Klor will call into one of these two functions:
55 |
56 | - ``: its parameter list is `()`; it should send the given `` and return; its result is ignored.
57 | - ``: its parameter list is `()`; it should receive a value and return it.
58 |
59 | The transport functions accept a **locator** `` as their first argument.
60 | Locators are supplied by the user via the `:locators` map (mapping each role parameter to its locator) and are forwarded by Klor to the transport functions.
61 | A locator is an arbitrary Clojure value representing the role to send to/receive from and should contain the information necessary for the transport functions to carry out their effects.
62 | Practically speaking, locators will most often be mechanisms such as `core.async` channels, TCP sockets, etc.
63 | If the played role doesn't communicate with a particular role, that role's locator can be left out.
64 |
65 | If a choreography invokes another choreography, Klor will make sure to properly "thread" the role configuration, taking into account the way the choreography was instantiated.
66 | Any communication actions performed by the invoked choreography will use the same transport functions and locators provided at the top.
67 | The Klor user only ever has to worry about the "top-level view" and getting the initial call to `play-role` right.
68 |
69 | `` should be the value of a var defined as a choreography with `defchor`.
70 | Its structure is left unspecified and is an implementation detail.
71 |
72 | All supplied arguments `*` are provided to the projection.
73 | Their number and structure is dependent on the played role `r` and is derived from the choreography's signature in an **erasure style**:
74 |
75 | - Parameters that do not mention `r` at all are erased from the projection's parameter list.
76 | - Parameters of agreement type are retained and assumed to be arbitrary Clojure values. Note that it is the **user's responsibility** to provide the same value for an agreement parameter to all projections.
77 | - Parameters of tuple or choreography type cannot be provided directly, so choreographies that take them are not directly usable with `play-role`. This is to reduce the possibility of user mistakes. Instead, the user can create a "wrapper choreography" that takes only parameters of agreement type and constructs the necessary tuples and choreographies to pass to the choreography of interest.
78 | Because this is done within the confines of the type system it is guaranteed that the constructed values will follow Klor's usual assumptions.
79 |
80 | The return value of `play-role` is derived from the return value of the choreography in a similar fashion:
81 |
82 | - If the type of the return value does not mention `r` at all, `klor.runtime/noop` is returned.
83 | - If the return value is of agreement type, the value is returned as is.
84 | - If the return value is of tuple type, a Clojure vector is returned whose elements are derived recursively. However, elements of the tuple that do not mention `r` at all are erased like in the projection's parameter list and so do not appear in the vector.
85 | - If the return value is of choreography type, a Clojure function is returned. Its parameter list and return value are derived recursively according to the rules above. The returned Clojure function effectively represents a projection of the returned choreography and has the role configuration "baked in". When called, it will use the same transport that was initially provided to `play-role`.
86 |
87 | ## TCP Transport
88 |
89 | The `klor.sockets` namespace provides a simple transport based on standard [`java.nio`](https://docs.oracle.com/javase/8/docs/api/java/nio/package-summary.html) TCP sockets and the [Nippy](https://github.com/taoensso/nippy) serialization library.
90 |
91 | The function `(klor.sockets/wrap-sockets & {:as })` can be used to construct a role configuration using the TCP transport, suitable as an argument to `play-role`:
92 |
93 | - `` is an existing role configuration. Its `:send`, `:recv` and `:locators` keys will be overriden and returned as a new configuration.
94 | - `` is a map of role parameters to Java [`SocketChannel`](https://docs.oracle.com/javase/8/docs/api/java/nio/channels/SocketChannel.html) objects. The sockets must be provided by the user and are used to send/receive data to/from other roles.
95 | - `` is a map of additional options. The `:log` option controls logging of socket sends and receives. If set to a boolean, the logging is enabled or disabled. If set to `:dynamic` (the default), the logging depends on the boolean value of the dynamic variable `klor.sockets/*log*` (false by default).
96 |
97 | ## Simulator
98 |
99 | The Klor simulator provides a simple way of executing choreographies within a single Clojure process.
100 | This comes in handy during development and debugging.
101 | Technically, the simulator just executes each projection on a separate thread and plugs in a transport based on in-memory `core.async` channels.
102 |
103 | The `(klor.simulator/simulate-chor *)` function is used to simulate the execution of a choreography.
104 | `` is the value of a var defined as a choreography with `defchor`, just like in `play-role`.
105 | The number and structure of the arguments `*` follows the signature of the choreography, without erasure like in `play-role`.
106 | `simulate-chor` will automatically distribute the arguments to the correct projections.
107 |
108 | Like with `play-role`, it is not possible to directly use `simulate-chor` with a choreography that makes use of parameters of tuple or choreography type.
109 | A "wrapper choreography" must be used instead in those cases.
110 |
--------------------------------------------------------------------------------
/doc/tutorial-01-introduction.md:
--------------------------------------------------------------------------------
1 | # Tutorial: Introduction
2 |
3 | This tutorial is aimed at programmers who already have a solid understanding of Clojure but haven't heard of Klor or [choreographic programming](https://en.wikipedia.org/wiki/Choreographic_programming) before.
4 | It first gives a quick overview of the general idea of choreographic programming and for the remainder focuses on showing how it's done in Klor specifically.
5 |
6 | ## Choreographic Programming
7 |
8 | In short, choreographic programming is a paradigm in which one programs a distributed system from a **global viewpoint**.
9 | A distributed system involes multiple **roles** (also called participants, endpoints or locations) that execute **concurrently** and communicate by passing messages between each other (most often over a network).
10 |
11 | A program written in the choreographic paradigm is called a **choreography**.
12 | Intuitively, it specifies the control flow of the distributed system as a whole -- the communications between the participants and the local computations they perform.
13 |
14 | A choreography's global view of the system's behavior offers certain advantages, such as the fact that a compiler can automatically transform the choreography into an executable implementation for each role.
15 | This compilation procedure is known as **projection** (also called endpoint projection or EPP) and the generated implementations as **projections**.
16 | Running the projections concurrently will yield the global behavior described by the choreography.
17 |
18 | Another advantage is that choreographic programming languages come with a syntactic primitive for communication, usually in the style of "Alice and Bob" notation found in security protocols.
19 | For example, in an imperative choreographic programming language, `p.e -> q.x` would be an instruction read as "the role `p` sends the result of expression `e` to role `q`, who stores it in its variable `x`".
20 | This style makes it syntactically impossible to write communications that would result in **send--receive mismatches or deadlocks**.
21 |
22 | Here's a small example involving 3 roles (`A`, `B` and `C`) that demonstrates what (imperative) choreographies look like and how projection works:
23 |
24 | ```
25 | A.x -> B.x; // A sends the value of x to B who stores it in x
26 | A.y -> C.x;
27 | C.y := f(); // C locally computes y
28 | C.y -> B.y;
29 | ```
30 |
31 | Projection will then produce 3 local programs, one for each of `A`, `B` and `C`, respectively.
32 | Note how each local program contains only the instructions related to the corresponding role:
33 |
34 | ```
35 | send(B, x); // Send the value of x to B
36 | send(C, y);
37 | ```
38 |
39 | ```
40 | x := recv(A); // Receive from A into x
41 | y := recv(C);
42 | ```
43 |
44 | ```
45 | x := recv(A);
46 | y := f(); // Compute y locally
47 | send(B, y);
48 | ```
49 |
50 | Choreographic programming languages also come with support for conditionals, procedures, recursion, etc.
51 | All of this and more will be explained throughout the tutorial as necessary.
52 |
53 | For a more formal treatment of choreographic programming we recommend looking into the literature.
54 | A good starting point is the [Introduction to Choreographies](https://doi.org/10.1017/9781108981491) book.
55 |
56 | ## Klor
57 |
58 | Klor brings choreographic programming to Clojure in the form of a **domain-specific language** (DSL) packaged as a normal Clojure library.
59 | Building on top of the powerful Lispy metaprogramming facilities (macros), Klor delivers a DSL without the use of a custom toolchain, yet with sophisticated compile-time analyses guaranteeing correctness.
60 |
61 | Unlike the custom imperative language used in the example above, Klor embraces the functional approach of Clojure and molds the DSL around it.
62 | Clojure was chosen as the base because it is a great fit for the inherently concurrent setting of choreographies -- it emphasizes a mostly-pure functional programming style and comes with a rich set of concurrency primitives and persistent data structures, drastically lowering the amount of concurrency bugs.
63 | Choreographies defined in Klor are projected to normal Clojure code during the macroexpansion process and can be seamlessly integrated with existing code.
64 |
65 | See [Tutorial: Basics](tutorial-02-basics.md) to get started with Klor.
66 |
--------------------------------------------------------------------------------
/doc/tutorial-02-basics.md:
--------------------------------------------------------------------------------
1 | # Tutorial: Basics
2 |
3 | ## Setup
4 |
5 | Throughout the tutorial we will explore a number of examples.
6 | The reader is encouraged to follow along and try things out at the REPL.
7 | All examples will assume that Klor has been loaded and imported into the current namespace as if by the following:
8 |
9 | ```clojure
10 | (require
11 | '[klor.core :refer :all]
12 | '[klor.simulator :refer [simulate-chor]])
13 | ```
14 |
15 | ## First Choreography
16 |
17 | Klor choreographies are similar to normal Clojure functions: they are pieces of behavior that take a number of inputs and produce an output.
18 | Unlike functions however, choreographies describe the behavior of multiple independent roles executing **concurrently**, including their interactions and local computations.
19 |
20 | We define choreographies using the `defchor` macro, reminiscent of Clojure's `defn`.
21 | Here is a trivial 1-role choreography to get acquainted with `defchor`'s syntax:
22 |
23 | ```clojure
24 | (defchor greet [A] (-> A) []
25 | (A (println "Hello world")))
26 | ```
27 |
28 | The above defines a choreography called `greet` taking no parameters (`[]`).
29 | The two additional elements between the name and the parameter vector are the **role vector** and the **choreographic type signature**.
30 | The role vector `[A]` specifies that the choreography involves just a single role, named `A`.
31 | The choreographic type signature `(-> A)` tells Klor that `greet` is a choreography taking no inputs and producing an output located at `A`.
32 |
33 | Klor tracks the locations of values within a choreography using its lightweight **choreographic type system** in order to ensure the correctness of choreographic code.
34 | The type system does not restrict the "structure" of a value, e.g. whether it is an integer or a string, but rather its **location**, i.e. whether it is located at role `A` or role `B`.
35 | Therefore, Clojure's usual dynamic typing of values is completely orthogonal and unaffected.
36 |
37 | The expression `(A ...)` in the body of the choreography is a **role expression**.
38 | It tells Klor that all literals and free names (referring to plain Clojure vars) in its body -- `"Hello world"` and `println` in this case -- should be treated as being located at `A`.
39 | We also say that they have been **lifted** to A.
40 | The end result is that `(A (println "Hello world"))` specifies an invocation of `println` performed at `A`.
41 | Generally, a choreographic programming language needs a way to specify where values are located and where computation takes place.
42 | Klor's role expressions provide a syntactically unobtrusive way of doing this.
43 |
44 | Aside from a handful of Klor-specific special operators like the mentioned role expressions, Klor can freely invoke existing Clojure code and use most of the standard Clojure special operators such as `do`, `let`, etc.
45 | Certain operators do require special considerations within a choreographic context however, and some are not supported at all.
46 | See [Reference: Language](./reference-01-language.md) for a full list of special operators supported by Klor, though most of them ones will be covered by the tutorial.
47 |
48 | Behind the scenes, the `defchor` macro will type check the choreography and, assuming everything is ok, produce a projection for each of the roles involved.
49 | Invoking the individual projections from Clojure will be covered later in [Tutorial: Execution](./tutorial-05-execution.md), so until then we will make use of Klor's **simulator** instead.
50 | The simulator allows us to test a choreography from within a single Clojure process by automatically executing each role's projection on a separate thread.
51 | This is a highly useful tool during development and debugging.
52 |
53 | To test `greet` we evaluate `@(simulate-chor greet)`:
54 |
55 | ```
56 | >> A spawned
57 | >> A: Hello world
58 | >> A exited normally
59 | => {A nil}
60 | ```
61 |
62 | (Throughout the tutorial, the standard output and the result of an evaluation will be shown prefixed with `>>` and `=>`, respectively).
63 | The simulator will show the output of each role prefixed with its name for easier reading, and will also produce some debugging output.
64 | The return value is a map of the results produced by each role (i.e. each projection).
65 | In this case `A` printed `Hello world` and produced `nil` as its result.
66 |
67 | Let us now extend the choreography to two roles, `A` and `B`, where each one will print a part of the message (though in some non-deterministic order due to the concurrent execution of roles):
68 |
69 | ```clojure
70 | (defchor greet-2 [A B] (-> B) []
71 | (A (println "Hello"))
72 | (B (println "World")))
73 | ```
74 |
75 | The role vector is now `[A B]` since we have two roles.
76 | The choreographic type `(-> B)` says that the choreography (still) takes no inputs but produces a single output located at `B`, because `(B (println "World"))` is the final form in the choreography's body.
77 | To test we evaluate `@(simulate-chor greet-2)`:
78 |
79 | ```
80 | >> A spawned
81 | >> B spawned
82 | >> A: Hello
83 | >> A exited normally
84 | >> B: World
85 | >> B exited normally
86 | => {A #function[klor.runtime/noop], B nil}
87 | ```
88 |
89 | The two roles independently print their messages and exit as expected.
90 | Keep in mind that we could observe different orderings of the messages depending on how the execution is scheduled.
91 | Also note the projections' results: `B` returned `nil`, which is the result of the choreography's final `println`, but `A` returned the special value `klor.runtime/noop`, which marks the absence of a value for `A` at the choreographic level.
92 | In other words, even though `greet-2` involves both role `A` and `B`, the result of invoking it produces only a value at `B`.
93 | We will see later how values can be returned at multiple roles simultaneously.
94 |
95 | ## Communication
96 |
97 | While the two roles in the previous example do execute concurrently, they have no interaction with one another.
98 | Here is a 2-role choreography where we perform a communication for the first time:
99 |
100 | ```clojure
101 | (defchor simple [A B] (-> B) []
102 | (A->B (A 5)))
103 | ```
104 |
105 | The special single-arrow communication operator `A->B` allows us to transfer a value from one role to another.
106 | To be able to do so, the operator's argument must be located at the source (the left-hand side of the arrow) and the result will be a value located at the destination (the right-hand side of the arrow).
107 | In this case, `A` communicates the value `5` to `B`.
108 | Had `5` not been located at `A`, Klor would've reported an error.
109 |
110 | If we now evaluate `@(simulate-chor simple)`, we will notice the simulator conveniently reporting the communication between the roles:
111 |
112 | ```
113 | >> A spawned
114 | >> B spawned
115 | >> A --> B: 5
116 | >> B exited normally
117 | >> A exited normally
118 | => {A #function[klor.runtime/noop], B 5}
119 | ```
120 |
121 | Let us modify the choreography so that it takes the value to communicate from `A` as input:
122 |
123 | ```clojure
124 | (defchor simple-2 [A B] (-> A B) [x]
125 | (A->B x))
126 | ```
127 |
128 | The type signature `(-> A B)` now specifies that the choreography takes a single input at `A` and produces an output at `B`.
129 | Note how we don't need a role expression around `x` in the body since it is not a free name and Klor already knows it is located at `A` due to the choreography's signature.
130 | Klor won't complain if you use a role expression anyway, even if the role doesn't match the actual location of the argument:
131 |
132 | ```clojure
133 | (defchor simple-2 [A B] (-> A B) [x]
134 | (A->B (B x)))
135 | ```
136 |
137 | Remember, role expressions only affect the type (i.e. location) of literals and free names; everything else is automatically **inferred** by Klor during type checking and is not affected by a role expression.
138 | In practice, you will want to avoid superfluous role expressions and try to push them as inward as possible for readability reasons (to better signal where local computation takes place).
139 |
140 | If we now wish to test `simulate-2`, we must give `simulate-chor` an additional argument, implicitly located at `A`.
141 | When a choreography takes arguments, the simulator will take care of correctly distributing the parameters to their respective locations.
142 | Evaluating `@(simulate-chor simple-2 "Hello")` gives us:
143 |
144 | ```
145 | >> A spawned
146 | >> B spawned
147 | >> A exited normally
148 | >> A --> B: "Hello"
149 | >> B exited normally
150 | => {A #function[klor.runtime/noop], B "Hello"}
151 | ```
152 |
153 | As mentioned before, it is `defchor` that will produce the projections and ensure that `A` contains a send and `B` contains a matching receive.
154 | All of the necessary code is generated automatically and does not in any way assume it will be running in the simulator.
155 | The simulator is just a convenience for local testing that schedules each projection on a separate thread and wires them up to communicate over in-memory `core.async` channels.
156 | Generally, Klor permits any value as an argument to a communication, with the assumption that the underlying transport will know how to (de)serialize it.
157 | Transport customization is covered later in [Tutorial: Execution](./tutorial-05-execution.md).
158 |
159 | ## More Examples
160 |
161 | Here's an example of a "remote increment" choreography.
162 | `A` will send a number to `B` who will increment it and return it to `A`:
163 |
164 | ```clojure
165 | (defchor remote-inc [A B] (-> A A) [x]
166 | (B->A (B (inc (A->B x)))))
167 | ```
168 |
169 | Note the role expression `(B ...)` which serves to lift `inc` to `B`.
170 | To test we can evaluate `@(simulate-chor remote-inc 5)`:
171 |
172 | ```
173 | >> A spawned
174 | >> B spawned
175 | >> A --> B: 5
176 | >> B exited normally
177 | >> B --> A: 6
178 | >> A exited normally
179 | => {A 6, B #function[klor.runtime/noop]}
180 | ```
181 |
182 | We could generalize our choreography to arbitrary functions at `B` with an additional parameter `f`:
183 |
184 | ```clojure
185 | (defchor remote-invoke [A B] (-> B A A) [f x]
186 | (B->A (f (A->B x))))
187 | ```
188 |
189 | To test decrementing with `dec`, `@(simulate-chor remote-invoke dec 5)`:
190 |
191 | ```
192 | >> A spawned
193 | >> B spawned
194 | >> A --> B: 5
195 | >> B exited normally
196 | >> B --> A: 4
197 | >> A exited normally
198 | => {A 4, B #function[klor.runtime/noop]}
199 | ```
200 |
201 | We could go a step further and generalize the invocation to an arbitrary number of arguments, though the single parameter `xs` has to be a vector as choreographies don't support variadic arguments like Clojure functions do:
202 |
203 | ```clojure
204 | (defchor remote-apply [A B] (-> B A A) [f xs]
205 | (B->A (B (apply f (A->B xs)))))
206 | ```
207 |
208 | To test calculating a sum, `@(simulate-chor remote-apply + [1 2 3])`:
209 |
210 | ```
211 | >> A spawned
212 | >> B spawned
213 | >> A --> B: [1 2 3]
214 | >> B exited normally
215 | >> B --> A: 6
216 | >> A exited normally
217 | => {A 6, B #function[klor.runtime/noop]}
218 | ```
219 |
220 | In [Tutorial: Sharing Knowledge](tutorial-03-sharing-knowledge.md) we introduce one of Klor's big ideas, demistify some of its syntax sugar and explore more control flow constructs.
221 |
--------------------------------------------------------------------------------
/doc/tutorial-03-sharing-knowledge.md:
--------------------------------------------------------------------------------
1 | # Tutorial: Sharing Knowledge
2 |
3 | ## Agreement
4 |
5 | It turns out that the single-role choreographic types (such as `A` and `B`) and the single-arrow communication operator (like `A->B`) are actually special cases of a more powerful idea.
6 | Consider the following choreography, very similar to the previous `simple`:
7 |
8 | ```clojure
9 | (defchor share [A B] (-> #{A B}) []
10 | (A=>B (A 5)))
11 | ```
12 |
13 | The type `#{A B}`, represented as a Clojure set of roles, is called an **agreement type**.
14 | It denotes that a value is located at both `A` and `B`, and furthermore that the two roles agree on what it is.
15 | In other words, `A` and `B` will at run-time hold values equivalent under Clojure's equality operator `=`.
16 | Single-role types such as `A` are just syntax sugar for the more verbose singleton agreement type `#{A}`.
17 |
18 | The double-arrow communication operator `A=>B` used in the body is like the single-arrow operator `A->B`, except that instead of just **moving** a value from `A` to `B`, it **copies** it to (or shares it with) `B`.
19 | When a value is copied, the resulting type is an agreement type whose set of roles is extended with the source location.
20 | Therefore, `A=>B` will take as an argument a value of an agreement type involving *at least* `A`, communicate it to `B`, and as a result produce a value of the initial agreement type extended with `B`.
21 |
22 | Klor fundamentally assumes that **copying preserves value**, i.e. that communication will not modify the value in a way that would change the outcome of any deterministic computation using it as input (all else being equal).
23 |
24 | A value of an agreement type is one kind of **multiply-located** value, so the above choreography will yield a result at both of the roles, equal in value in this case.
25 | We can check this with `@(simulate-chor share)`:
26 |
27 | ```
28 | >> A spawned
29 | >> B spawned
30 | >> A --> B: 5
31 | >> B exited normally
32 | >> A exited normally
33 | => {A 5, B 5}
34 | ```
35 |
36 | ## Agreement Operators
37 |
38 | With the idea of agreement laid down, we can now briefly revisit and expand on the previously introduced concept of role expressions and lifting.
39 | A role expression such as `(A ...)` is actually syntax sugar for Klor's special operator `(lifting [A] ...)`.
40 | While the syntax sugar only supports a single role, the explicit form supports lifting to any number of roles.
41 | `(lifting [A B C] ...)` will lift all literals and free names (referring to plain, i.e. non-choreographic, Clojure vars) within its body to the agreement type `#{A B C}`.
42 | Lifting is the way that Klor reuses existing Clojure code; the "Klor-calls-Clojure" direction of integration.
43 |
44 | by default, each choreography's body is implictily wrapped in a `lifting` block that includes all of its roles.
45 | For example, the following is a well-formed choreography as `5` is implicitly lifted to `#{A B}`:
46 |
47 | ```clojure
48 | (defchor together [A B] (-> #{A B}) []
49 | 5)
50 | ```
51 |
52 | Which could've also been written explicitly as:
53 |
54 | ```clojure
55 | (defchor together [A B] (-> #{A B}) []
56 | (lifting [A B] 5))
57 | ```
58 |
59 | The more interesting case however is the invocation of a lifted operator.
60 | We have seen this before in `greet` where we invoked `println` at just `A` or `B` separately.
61 | In the following however, we invoke `println` at both `A` *and* `B` with the use of a single invocation:
62 |
63 | ```clojure
64 | (defchor together-2 [A B] (-> #{A B}) []
65 | (println "Hello world"))
66 | ```
67 |
68 | Notice how the expected return type of the invocation of the lifted `println` is an agreement type, which implies that `println` must return the same value at both roles.
69 | This leads us to Klor's idea of **agreement operators** and its accompanying rule: Klor allows the invocation of any operator of agreement type, as long as all of its arguments are of that same agreement type.
70 | Furthermore, the result of such an operation is assumed to also be of the same agreement type.
71 | That is to say, Klor assumes that all **agreement operators are deterministic**, so that when the involved roles carry out the computation with the same arguments, they all end up with the same result.
72 | Note that the operators don't have to be exactly pure, just deterministic.
73 | Side-effects, as in the case of `println`, are allowed as long as the operator produces the same result at each involved role.
74 | **Violating this assumption will make agreement silently fail and lead to bugs.**
75 | Luckily, Clojure highly emphasizes stateless and pure functions so ensuring this condition is generally not an issue.
76 |
77 | To confirm, `@(simulate-chor together-2)`:
78 |
79 | ```
80 | >> A spawned
81 | >> B spawned
82 | >> A: Hello world
83 | >> A exited normally
84 | >> B: Hello world
85 | >> B exited normally
86 | => {A nil, B nil}
87 | ```
88 |
89 | Note that Klor doesn't in any way ensure that a value of agreement type is necessarily invokable.
90 | The underlying values are still dynamically typed, so if used in the operator position, Klor happily assumes they can be invoked, just like Clojure (and throws a run-time exception otherwise).
91 |
92 | ## Narrowing
93 |
94 | Opposite to extension, we can also **narrow** agreements: if `x` is a value of agreement type `#{A B C}`, the special operator `(narrow [A B] x)` will produce the same value but of agreement type `#{A B}`.
95 | This allows us to effectively "forget" an agreement in part or whole, which is useful when we want to use the value among a subset of the roles or purely locally.
96 | For example:
97 |
98 | ```clojure
99 | (defchor inc-locally [A B] (-> B) []
100 | (B (inc (narrow [B] (A=>B (A 5))))))
101 | ```
102 |
103 | `A` shares a value with `B`, but `B` then performs the increment operation on its own.
104 | The final type of the body is just `B`, so `A` has no result.
105 | To test, `@(simulate-chor inc-locally)`:
106 |
107 | ```
108 | >> A spawned
109 | >> B spawned
110 | >> A exited normally
111 | >> A --> B: 5
112 | >> B exited normally
113 | => {A #function[klor.runtime/noop], B 6}
114 | ```
115 |
116 | This *copy-then-narrow pattern* should immediately remind us of the move-style communication we used earlier in the tutorial.
117 | Klor's fundamental communication mechanism is actually the **double-arrow copy operator** `(A=>B )`, which is syntax sugar for the special operator `(copy [A B] )`.
118 | The single-arrow move operator `(A->B )` is just a shorthand for the copy-then-narrow pattern: `(narrow [B] (copy [A B] ))`.
119 |
120 | However, even if we didn't narrow the agreement established by the copy in the example above, the choreography would still type check:
121 |
122 | ```clojure
123 | (defchor inc-locally [A B] (-> B) []
124 | (B (inc (A=>B (A 5)))))
125 | ```
126 |
127 | This is because Klor allows **agreement subtyping** in certain cases for convenience and readability purposes.
128 | Specifically, the full agreement operator rule only requires that the operator's arguments are all *subtypes* of the operator's agreement type.
129 | This means that the arguments are allowed to be of a *wider* agreement type, as long as they contain *at least* the roles found in the operator's agreement type.
130 |
131 | ## Conditionals
132 |
133 | One of the big issues all choreographic programming lanugages have to overcome is the way they handle conditionals.
134 | The fundamental problem is known as the **problem of knowledge of choice**: if one role makes a decision regarding which branch of a conditional to take, how can the other roles involved be notified of its decision?
135 |
136 | Klor gives high importance to the idea of agreement because it provides an elegant way of dealing with this issue.
137 | We simply require that the guard of every conditional be of agreement type and that any roles present in either of its branches be part of that agreement type.
138 | This ensures that all roles will have sufficient knowledge to make the same decision, guaranteeing that their control will continue flowing along the same branch in the choreography.
139 |
140 | To start off simple, here's an example where knowledge of choice is **not** required:
141 |
142 | ```clojure
143 | (defchor check [A B] (-> A B) [x]
144 | (if (B (even? (A->B x)))
145 | (B (println "Even!"))
146 | (B (println "Odd!"))))
147 | ```
148 |
149 | `B` will receive a number from `A`, and based on a local decision will print either `Even!` or `Odd!`.
150 | `A` is not involved in either of the branches so it does not need to know the outcome of the decision.
151 | We could've also written the example more compactly by pushing the `if` inward:
152 |
153 | ```clojure
154 | (defchor check [A B] (-> A B) [x]
155 | (B (println (if (even? (A->B x)) "Even!" "Odd!"))))
156 | ```
157 |
158 | Now here's a choreography where both of the roles *are* involved in the branches of the conditional, and in such a way that the communication structure depends on the outcome of the decision:
159 |
160 | ```clojure
161 | (defchor check-2 [A B] (-> A B) [x]
162 | (if (A=>B (A (even? x)))
163 | (A->B (A (rand-int 5)))
164 | (B 42)))
165 | ```
166 |
167 | Here, `A` will communicate the outcome of its `even?` check to `B`, so both will be able to proceed to the same branch.
168 | In case the number is even, `A` will send `B` a random integer to return as the result.
169 | Otherwise, `B` will return the integer `42` instead.
170 |
171 | To test with an odd number, `@(simulate-chor check-2 1)`:
172 |
173 | ```
174 | >> A spawned
175 | >> B spawned
176 | >> A exited normally
177 | >> A --> B: false
178 | >> B exited normally
179 | => {A #function[klor.runtime/noop], B 42}
180 | ```
181 |
182 | Or with an even number, `@(simulate-chor check-2 2)`:
183 |
184 | ```
185 | >> A spawned
186 | >> B spawned
187 | >> A --> B: true
188 | >> A --> B: 3
189 | >> B exited normally
190 | >> A exited normally
191 | => {A #function[klor.runtime/noop], B 3}
192 | ```
193 |
194 | Notice the extra communication in the latter case.
195 |
196 | If for some reason we wanted each role to perform the `even?` check on its own rather than communicating a boolean, it would be enough to communicate the number instead by just pushing the communication inward:
197 |
198 | ```clojure
199 | (defchor check-3 [A B] (-> A B) [x]
200 | (if (even? (A=>B x))
201 | (A->B (A (rand-int 5)))
202 | (B 42)))
203 | ```
204 |
205 | Achieving these slight but sometimes important variations in behavior is quite easy with Klor's agreement framework.
206 |
207 | In [Tutorial: Composition](tutorial-04-composition.md) we go over how to effectively reuse and compose choreographies.
208 |
--------------------------------------------------------------------------------
/doc/tutorial-05-execution.md:
--------------------------------------------------------------------------------
1 | # Tutorial: Execution
2 |
3 | ## Clojure-calls-Klor
4 |
5 | So far we've been running all of our choreographies in a single Clojure process with the help of the Klor simulator.
6 | In practice we will want to distribute the execution of a choreography over multiple threads, processes, physical nodes or even a combination thereof.
7 | For that purpose, we need the ability to integrate the individual projections of a choreography with Clojure code, as well as customize the transport mechanism that the roles use to communicate.
8 |
9 | The main way to use a choreography from Clojure code is to "play one of its roles", i.e. invoke one of its projections.
10 | A single Clojure process can play one or multiple roles of a choreography, though it is important to ensure that the roles of a single choreography always execute **concurrently** (e.g. by executing them on different threads).
11 | A single process can also be involved in multiple different choreographies, either simultaneously or at different points in time.
12 |
13 | To demonstrate the above we will implement a toy bookseller choreography and run it over TCP sockets.
14 | A buyer `B` wants to buy a book from the seller `S` according to the following choreography:
15 |
16 | - `B` sends `S` the title of the book,
17 | - `S` receives the title, looks up the price of the book and sends it to `B`,
18 | - `B` receives the price and decides whether to buy the book depending on its budget,
19 | - `B` sends its decision to `S`, along with an address if necessary,
20 | - `S` receives the decision and possibly returns the delivery date to the `B`.
21 |
22 | Here's how we might implement this in Klor:
23 |
24 | ```clojure
25 | (defn ship! [address]
26 | ;; Assume some side effect occurs.
27 | (str (java.time.LocalDate/now)))
28 |
29 | (defchor buy-book [B S] (-> B S B) [order catalog]
30 | (let [price (S->B (S (get catalog (B->S (B (:title order))) :none)))]
31 | (if (B=>S (B (and (int? price) (>= (:budget order) price))))
32 | (let [date (S->B (S (ship! (B->S (B (:address order))))))]
33 | (B (println "I'll get the book on" (str date)))
34 | date)
35 | (do (S (println "Buyer changed his mind"))
36 | (B nil)))))
37 | ```
38 |
39 | We've used the following to model the problem:
40 |
41 | - `order` is a map `{:title :budget :address }`,
42 | - `catalog` is a map of `` pairs mapping book names to their prices,
43 | - `ship!` is a side effectful function that executes the book shipment and returns the delivery date.
44 |
45 | With the choreography in place, we can now write Clojure "driver code" that will invoke the respective projections.
46 | The fundamental way to do this is with Klor's `play-role` function.
47 | The drivers are `run-seller` and `run-buyer`:
48 |
49 | ```clojure
50 | (require
51 | '[klor.runtime :refer [play-role]]
52 | '[klor.sockets :refer [wrap-sockets with-server with-accept with-client]])
53 |
54 | (def port 1337)
55 |
56 | (defn run-seller [catalog & {:keys [host port forever log] :or
57 | {host "0.0.0.0" port port
58 | forever false log :dynamic}}]
59 | (let [catalog (or catalog {"To Mock A Mockingbird" 50})]
60 | (with-server [ssc {:host host :port port}]
61 | (loop []
62 | (println "Listening on" (str (.getLocalAddress ssc)))
63 | (with-accept [ssc sc]
64 | (println "Got client" (str (.getRemoteAddress sc)))
65 | (play-role (wrap-sockets {:role 'S} {'B sc} :log log)
66 | buy-book catalog))
67 | (when forever (recur))))))
68 |
69 | (defn run-buyer [order & {:keys [host port log]
70 | :or {host "127.0.0.1" port port log :dynamic}}]
71 | (let [order (merge {:title "To Mock A Mockingbird"
72 | :budget 50
73 | :address "Some Address 123"}
74 | order)]
75 | (with-client [sc {:host host :port port}]
76 | (println "Connected to" (str (.getRemoteAddress sc)))
77 | (play-role (wrap-sockets {:role 'B} {'S sc} :log log)
78 | buy-book order))))
79 | ```
80 |
81 | The most important parts of the above drivers are the calls to `play-role`.
82 | The first argument to `play-role` is known as a **role configuration**.
83 | It is a map that specifies which role of the choreography to play and how to communicate with the other roles.
84 | This mechanism allows you to fully customize the meaning of "communication" in your choreography.
85 |
86 | Here we use Klor's `wrap-sockets` utility which produces a role configuration for communicating over standard `java.nio` sockets.
87 | For serializing and deserializing Clojure values we use the [Nippy](https://github.com/taoensso/nippy) serialization library.
88 |
89 | The drivers use a few utilities -- `with-server`, `with-accept` and `with-client`, all part of Klor -- which are just convenience macros that deal with the boilerplate of setting up plain TCP sockets: creating a server socket, accepting connections from clients, and connecting a client to a server.
90 | For a TCP connection to work one of the roles will have to act as a server, so we choose `S` to be the server and `B` to be the client.
91 |
92 | Following the role configuration, `play-role` is provided the choreography and the necessary arguments to pass to the projection.
93 | In general, how many arguments and of what kind the projections accept depends on the signature of the choreography.
94 | The situation here is relatively straightfoward: the seller accepts just the catalog and the buyer just the order.
95 |
96 | Note that the drivers come with some hardcoded data for the purposes of the example.
97 | In particular, the catalog used by `run-seller` defaults to the map `{"To Mock A Mockingbird" 50}`.
98 | Similarly, the order provided to `run-buyer` order is merged with the default map `{:title "To Mock A Mockingbird" :budget 50 :address "Some Address 123"}`.
99 |
100 | Now we can run the `S` on a separate thread with some logging enabled: `(run-seller nil :forever true :log true)`.
101 | This will start the server and run in a loop forever, accepting one `B` at a time.
102 |
103 | From the REPL (even from a different Clojure process) we can now connect individual clients by using `run-buyer`.
104 | A few example runs and their trace logs follow.
105 | Lines with arrows pointing to the right (`-->`) are receives, while those with arrows pointing to the left (`<--`) are sends.
106 |
107 | The default order:
108 |
109 | ```
110 | klor.core> (run-buyer nil)
111 |
112 | Connected to /127.0.0.1:1337
113 | Got client /127.0.0.1:42320
114 | /127.0.0.1:42320 --> "To Mock A Mockingbird"
115 | /127.0.0.1:42320 <-- 50
116 | /127.0.0.1:42320 --> ok
117 | /127.0.0.1:42320 --> "Some Address 123"
118 | /127.0.0.1:42320 <-- "2024-02-20"
119 | I'll get the book on 2024-02-20
120 | ```
121 |
122 | When the budget is too low:
123 |
124 | ```
125 | klor.core> (run-buyer {:budget 49})
126 |
127 | Connected to /127.0.0.1:1337
128 | Got client /127.0.0.1:56662
129 | /127.0.0.1:56662 --> "To Mock A Mockingbird"
130 | /127.0.0.1:56662 <-- 50
131 | /127.0.0.1:56662 --> ko
132 | Buyer changed his mind
133 | ```
134 |
135 | When the book is not found in the catalog:
136 |
137 | ```
138 | klor.core> (run-buyer {:title "Weird"})
139 |
140 | Got client /127.0.0.1:50442
141 | Connected to /127.0.0.1:1337
142 | /127.0.0.1:50442 --> "Weird"
143 | /127.0.0.1:50442 <-- :none
144 | /127.0.0.1:50442 --> ko
145 | Buyer changed his mind
146 | ```
147 |
--------------------------------------------------------------------------------
/klor.svg:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
76 |
--------------------------------------------------------------------------------
/project.clj:
--------------------------------------------------------------------------------
1 | (defproject org.clojars.klor/klor "0.1.0-SNAPSHOT"
2 | :description "Choreographies in Clojure"
3 | :url "https://github.com/lovrosdu/klor"
4 | :license {:name "EPL-2.0 OR GPL-2.0-or-later WITH Classpath-exception-2.0"
5 | :url "https://www.eclipse.org/legal/epl-2.0/"}
6 | :dependencies [[com.taoensso/nippy "3.3.0"]
7 | [org.clojure/clojure "1.11.1"]
8 | [org.clojure/core.async "1.6.681"]
9 | [org.clojure/core.match "1.1.0"]
10 | [org.clojure/tools.analyzer.jvm "1.3.0"]
11 | [potemkin/potemkin "0.4.6"]]
12 | :profiles {:dev {:dependencies [[criterium/criterium "0.4.6"]
13 | [dorothy/dorothy "0.0.7"]]}}
14 |
15 | :repl-options {:init-ns klor.examples}
16 | :jar-exclusions [#"^klor/benchmark\.clj$"
17 | #"^klor/events\.clj$"
18 | #"^klor/examples\.clj$"
19 | #"^klor/fokkink\.clj$"
20 | #"^klor/fokkink_plain\.clj$"])
21 |
--------------------------------------------------------------------------------
/src/klor/core.clj:
--------------------------------------------------------------------------------
1 | (ns klor.core
2 | (:require
3 | klor.defchor
4 | klor.specials
5 | klor.stdlib
6 | potemkin))
7 |
8 | (potemkin/import-vars
9 | [klor.defchor defchor]
10 | [klor.specials narrow lifting agree! copy pack inst]
11 | [klor.stdlib move unpack chor bcast scatter scatter-seq gather])
12 |
--------------------------------------------------------------------------------
/src/klor/defchor.clj:
--------------------------------------------------------------------------------
1 | (ns klor.defchor
2 | (:require
3 | [clojure.set :as set]
4 | [klor.analyzer :refer [adjust-chor-signature]]
5 | [klor.driver :refer [analyze project]]
6 | [klor.emit-form :refer [emit-form]]
7 | [klor.types :refer [parse-type type-roles render-type replace-roles]]
8 | [klor.stdlib :refer [chor]]
9 | [klor.opts :refer [*opts*]]
10 | [klor.util :refer [usym? warn error]]))
11 |
12 | (defn adjust-defchor-signature [roles type]
13 | (-> (update type :aux #(let [main (type-roles (assoc type :aux #{}))]
14 | (set/difference (if (= % :none) (set roles) %)
15 | main)))
16 | ;; NOTE: Set unspecified aux sets of any choreography parameters to the
17 | ;; empty set. This is already done by the analyzer and ideally we would
18 | ;; just inherit the final signature from the type checker, but we need to
19 | ;; be able to install the definition's signature *before* any analysis is
20 | ;; done, due to possibility of recursion and self-reference.
21 | adjust-chor-signature))
22 |
23 | (defn defchor-signature-changed? [roles' signature' roles signature]
24 | (and roles' roles
25 | (or (not= (count roles') (count roles))
26 | (not= (replace-roles signature' (zipmap roles' (range)))
27 | (replace-roles signature (zipmap roles (range)))))))
28 |
29 | (defn render-signature [roles signature]
30 | `(~'forall ~roles ~(render-type signature)))
31 |
32 | (defn make-projs [roles signature [params & body]]
33 | (let [chor `(chor ~(render-type signature) ~params ~@body)
34 | ast (analyze chor {:env {:roles roles} :passes-opts *opts*})]
35 | [ast (map #(project ast {:role %}) roles)]))
36 |
37 | (defn make-expansion [name meta roles signature def]
38 | (let [[ast projs] (when def (make-projs roles signature def))
39 | name (vary-meta name merge `{:klor/chor '~meta})]
40 | ;; NOTE: Reattach the metadata to the var (via the symbol) because `def`
41 | ;; clears it. Also attach the metadata to the vector for convenience.
42 | [ast (cond
43 | (get-in *opts* [:debug :expansion]) `'~(emit-form ast #{:sugar})
44 | def `(def ~name ~(with-meta (vec projs) `{:klor/chor '~meta}))
45 | :else `(declare ~name))]))
46 |
47 | (defmacro defchor
48 | {:arglists '([name roles tspec] [name roles tspec & [params & body]])}
49 | [name roles tspec & def]
50 | (when-not (and (vector? roles) (not-empty roles) (every? usym? roles)
51 | (apply distinct? roles))
52 | (error :klor ["`defchor`'s roles must be given as a vector of distinct "
53 | "unqualified symbols: " roles]))
54 | (let [;; Create or fetch the var and remember its existing metadata
55 | exists? (ns-resolve *ns* name)
56 | var (intern *ns* name)
57 | m (meta var)
58 | {roles' :roles signature' :signature} (:klor/chor m)
59 | ;; Set the aux sets within the new signature, if unspecified
60 | signature (if-let [signature (parse-type tspec)]
61 | (adjust-defchor-signature roles signature)
62 | (error :klor ["Invalid `defchor` signature: " tspec]))
63 | ;; Prepare the new metadata
64 | m' {:roles roles :signature signature}]
65 | (try
66 | ;; Alter the metadata so that the analyzer can see it
67 | (alter-meta! var merge {:klor/chor m'})
68 | ;; Build, analyze and project the chor, and create the expansion
69 | (let [[ast expansion] (make-expansion name m' roles signature def)]
70 | (when-let [mentions (when def (:rmentions (:body ast)))]
71 | (when-let [diff (not-empty (set/difference (set roles) mentions))]
72 | (warn ["Some role parameters are never used: " diff])))
73 | (when (defchor-signature-changed? roles' signature' roles signature)
74 | (warn ["Signature of " var " changed:\n"
75 | " was " (render-signature roles' signature') ",\n"
76 | " is " (render-signature roles signature) ";\n"
77 | "make sure to recompile dependents"]))
78 | expansion)
79 | (finally
80 | ;; NOTE: We don't want to create or modify the var during
81 | ;; macroexpansion, so we unconditionally roll back our changes and leave
82 | ;; the job to the evaluation of the expansion.
83 | (if exists?
84 | (alter-meta! var (constantly m))
85 | (ns-unmap *ns* name))))))
86 |
--------------------------------------------------------------------------------
/src/klor/driver.clj:
--------------------------------------------------------------------------------
1 | (ns klor.driver
2 | (:require
3 | [clojure.tools.analyzer.jvm :as jvm-analyzer]
4 | [clojure.tools.analyzer.passes :refer [schedule]]
5 | [clojure.tools.analyzer.passes.constant-lifter]
6 | [clojure.tools.analyzer.passes.jvm.emit-form]
7 | [klor.analyzer :refer [analyze*]]
8 | [klor.emit-form :refer [emit-form]]
9 | [klor.instrument]
10 | [klor.typecheck]
11 | [klor.projection :as proj]))
12 |
13 | ;;; Main
14 |
15 | (def analyze-passes
16 | #{;; Transfer the source info from the metadata to the local environment.
17 | #_#'clojure.tools.analyzer.passes.source-info/source-info
18 |
19 | ;; Elide metadata given by `clojure.tools.analyzer.passes.elide-meta/elides`
20 | ;; or `*compiler-options*`. `clojure.tools.analyzer.jvm/analyze` provides a
21 | ;; default set of elides for `fn` and `reify` forms.
22 | #_#'clojure.tools.analyzer.passes.elide-meta/elide-meta
23 |
24 | ;; Propagate constness to vectors, maps and sets of constants.
25 | #'clojure.tools.analyzer.passes.constant-lifter/constant-lift
26 |
27 | ;; Rename the `:name` field of all all `:binding` and `:local` nodes to
28 | ;; fresh names.
29 | ;;
30 | ;; Requires `:uniquify/uniquify-env` to be true within the pass options in
31 | ;; order to also apply the same changes to the `:binding` nodes in local
32 | ;; environments (under `[:env :locals]`). However, keys of the local
33 | ;; environment are never touched and remain the original names (stored under
34 | ;; the `:form` field).
35 | #_#'clojure.tools.analyzer.passes.uniquify/uniquify-locals
36 |
37 | ;; Elide superfluous `:do`, `:let` and `:try` nodes when possible.
38 | #_#'clojure.tools.analyzer.passes.trim/trim
39 |
40 | ;; Refine `:host-field`, `:host-call` and `:host-interop` nodes to
41 | ;; `:instance-field`, `:instance-call`, `:static-field` and `:static-call`
42 | ;; when possible. This happens when the class can be determined statically.
43 | ;; In that case, the named field or method must exist otherwise an error is
44 | ;; thrown. If the class cannot be determined statically, the node is
45 | ;; kept as or converted to a `:host-interop` node.
46 | ;;
47 | ;; Also refine `:var` and `:maybe-class` nodes to `:const` when possible.
48 | #_#'clojure.tools.analyzer.passes.jvm.analyze-host-expr/analyze-host-expr
49 |
50 | ;; Refine `:invoke` nodes to `:keyword-invoke`, `:prim-invoke`,
51 | ;; `:protocol-invoke` and `:instance?` nodes when possible.
52 | #_#'clojure.tools.analyzer.passes.jvm.classify-invoke/classify-invoke
53 |
54 | ;; Validate a number of JVM-specific things. Most importantly, throw on
55 | ;; encountering `:maybe-class` or `:maybe-host-form` nodes. Such nodes are
56 | ;; produced for non-namespaced and namespaced symbols (respectively) that do
57 | ;; not resolve to a var or a class.
58 | ;;
59 | ;; This pass depends on
60 | ;; `clojure.tools.analyzer.passes.jvm.analyze-host-expr/analyze-host-expr`
61 | ;; which first performs a number of refinements when possible. Other than
62 | ;; that, `clojure.tools.analyzer.jvm` has no substantial handling for the
63 | ;; above two nodes in any of its passes and always considers them an error.
64 | #_#'clojure.tools.analyzer.passes.jvm.validate/validate
65 |
66 | ;; Throw on invalid role applications.
67 | #_#'klor.validate-roles/validate-roles
68 |
69 | ;; Propagate lifting masks.
70 | #_#'klor.typecheck/propagate-masks
71 |
72 | ;; Type check.
73 | #'klor.typecheck/typecheck
74 |
75 | ;; Assert invariants after type checking.
76 | #'klor.typecheck/sanity-check
77 |
78 | ;; Potentially instrument the code with dynamic checks.
79 | #'klor.instrument/instrument
80 |
81 | ;; Type check again after instrumenting.
82 | #'klor.instrument/typecheck-again
83 |
84 | ;; Emit form.
85 | #_#'klor.emit-form/emit-form})
86 |
87 | (def analyze-passes*
88 | (schedule analyze-passes))
89 |
90 | (defn analyze [form & {:as opts}]
91 | (analyze* form :run-passes analyze-passes* opts))
92 |
93 | (def project-passes
94 | #{#'klor.projection/cleanup
95 | #'clojure.tools.analyzer.passes.jvm.emit-form/emit-form})
96 |
97 | (def project-passes*
98 | (schedule project-passes))
99 |
100 | (defn project [ast & {:keys [cleanup] :as opts}]
101 | (let [cleanup' {:style (or cleanup :aggressive)}
102 | opts' {:bindings {#'jvm-analyzer/run-passes project-passes*}
103 | :passes-opts {:cleanup cleanup'}}]
104 | (jvm-analyzer/analyze (proj/project ast opts) (jvm-analyzer/empty-env)
105 | (merge-with merge opts' opts))))
106 |
107 | ;;; Utility
108 |
109 | (defn analyze+emit [form & {:keys [emit] :as opts}]
110 | (let [emit (cond
111 | (nil? emit) #{:sugar :type-meta}
112 | (set? emit) emit
113 | :else #{emit})
114 | ast (analyze form opts)]
115 | [ast (emit-form ast emit)]))
116 |
117 | (defn analyze+project [form & {:keys [env] :as opts}]
118 | (let [{:keys [roles]} env
119 | ast (analyze form opts)]
120 | [ast (zipmap roles (map #(project ast (merge opts {:role %})) roles))]))
121 |
--------------------------------------------------------------------------------
/src/klor/emit_form.clj:
--------------------------------------------------------------------------------
1 | (ns klor.emit-form
2 | (:require
3 | [clojure.tools.analyzer.env :as env]
4 | [clojure.tools.analyzer.passes.emit-form :as clj-emit]
5 | [clojure.tools.analyzer.passes.jvm.emit-form :as jvm-emit]
6 | [clojure.tools.analyzer.passes.uniquify :refer [uniquify-locals]]
7 | [klor.types :refer [render-type]]
8 | [klor.util :refer [assoc-inv]]))
9 |
10 | (defn make-unpack-binder [bindings]
11 | (reduce (fn [binder {:keys [name form position] :as binding}]
12 | (assoc-inv
13 | binder position
14 | ;; Copied from `clojure.tools.analyzer.passes.emit-form`.
15 | (with-meta name (meta form))
16 | '_))
17 | [] bindings))
18 |
19 | ;;; NOTE: We use `doall` and `mapv` throughout the code to force evaluation to
20 | ;;; occur within the context of our dynamic binding of `clj-emit/-emit-form*`.
21 |
22 | (defmulti -emit-form (fn [{:keys [op] :as ast} opts] op))
23 |
24 | (defmethod -emit-form :narrow [{:keys [roles expr sugar?] :as ast} opts]
25 | ;; NOTE: We expect a child `:copy` node if `:sugar?` is set, but analyzer
26 | ;; passes might rewrite the AST so that that's no longer the case.
27 | (if (and (:sugar opts) sugar? (= (:op expr) :copy))
28 | (let [{expr' :expr :keys [src dst]} expr]
29 | `(~(symbol (str src "->" dst)) ~(clj-emit/-emit-form* expr' opts)))
30 | `(~'narrow ~roles ~(clj-emit/-emit-form* expr opts))))
31 |
32 | (defmethod -emit-form :lifting [{:keys [roles body sugar?] :as ast} opts]
33 | (if (and (:sugar opts) sugar?)
34 | `(~(first roles) ~(clj-emit/-emit-form* body opts))
35 | `(~'lifting ~roles ~(clj-emit/-emit-form* body opts))))
36 |
37 | (defmethod -emit-form :agree [{:keys [exprs] :as ast} opts]
38 | `(~'agree! ~@(doall (map #(clj-emit/-emit-form* % opts) exprs))))
39 |
40 | (defmethod -emit-form :copy [{:keys [src dst expr sugar?] :as ast} opts]
41 | (if (and (:sugar opts) sugar?)
42 | `(~(symbol (str src "=>" dst)) ~(clj-emit/-emit-form* expr opts))
43 | `(~'copy [~src ~dst] ~(clj-emit/-emit-form* expr opts))))
44 |
45 | (defmethod -emit-form :pack [{:keys [exprs] :as ast} opts]
46 | `(~'pack ~@(doall (map #(clj-emit/-emit-form* % opts) exprs))))
47 |
48 | (defmethod -emit-form :unpack [{:keys [binder bindings init body] :as ast} opts]
49 | ;; NOTE: Recreate the binder from the bindings in case we are emitting
50 | ;; hygienically, since the `:binder` field is *not* uniquified.
51 | `(~'unpack*
52 | ~(if (:hygienic opts) (make-unpack-binder bindings) binder)
53 | ~(clj-emit/-emit-form* init opts)
54 | ~(clj-emit/-emit-form* body opts)))
55 |
56 | (defmethod -emit-form :chor [{:keys [local signature params body] :as ast} opts]
57 | `(~'chor*
58 | ~@(when local [(clj-emit/-emit-form* local opts)])
59 | ~(render-type signature)
60 | ~(mapv #(clj-emit/-emit-form* % opts) params)
61 | ~(clj-emit/-emit-form* body opts)))
62 |
63 | (defmethod -emit-form :inst [{:keys [name roles] :as ast} opts]
64 | `(~'inst ~name ~roles))
65 |
66 | (defmethod -emit-form :invoke [{:keys [fn args sugar?] :as ast} opts]
67 | ;; NOTE: We expect a child `:inst` node if `:sugar?` is set, but analyzer
68 | ;; passes might rewrite the AST so that that's no longer the case.
69 | (if (and (:sugar opts) sugar? (= (:op fn) :inst))
70 | (let [{:keys [name roles]} fn]
71 | `(~name ~roles ~@(doall (map #(clj-emit/-emit-form* % opts) args))))
72 | (clj-emit/-emit-form ast opts)))
73 |
74 | ;;; NOTE: We intercept the handling of certain JVM-specific nodes because their
75 | ;;; implementations don't do a good job of recursing through the
76 | ;;; `clj-emit/-emit-form*` dynamic variable and instead hardcode the use of
77 | ;;; `jvm-emit/-emit-form`. This is a problem since it prevents emission of
78 | ;;; choreographic nodes nested within the JVM-specific nodes, as they won't be
79 | ;;; recognized by `tools.analyzer.jvm`'s `-emit-form` and will cause an error.
80 | ;;;
81 | ;;; Our own implementations here are just copy-pasted and have
82 | ;;; `jvm-emit/-emit-form` replaced with `clj-emit/-emit-form*`.
83 |
84 | (defmethod -emit-form :catch
85 | [{:keys [class local body]} opts]
86 | `(catch ~(clj-emit/-emit-form* class opts) ~(clj-emit/-emit-form* local opts)
87 | ~(clj-emit/-emit-form* body opts)))
88 |
89 | (defmethod -emit-form :case
90 | [{:keys [test default tests thens shift mask low high
91 | switch-type test-type skip-check?]}
92 | opts]
93 | `(case* ~(clj-emit/-emit-form* test opts)
94 | ~shift ~mask
95 | ~(clj-emit/-emit-form* default opts)
96 | ~(apply sorted-map
97 | (mapcat (fn [{:keys [hash test]} {:keys [then]}]
98 | [hash [(clj-emit/-emit-form* test opts)
99 | (clj-emit/-emit-form* then opts)]])
100 | tests thens))
101 | ~switch-type ~test-type ~skip-check?))
102 |
103 | (defmethod -emit-form :static-call
104 | [{:keys [class method args]} opts]
105 | `(~(symbol (jvm-emit/class->str class) (name method))
106 | ~@(mapv #(clj-emit/-emit-form* % opts) args)))
107 |
108 | (defmethod -emit-form :instance-field
109 | [{:keys [instance field]} opts]
110 | `(~(symbol (str ".-" (name field))) ~(clj-emit/-emit-form* instance opts)))
111 |
112 | (defmethod -emit-form :instance-call
113 | [{:keys [instance method args]} opts]
114 | `(~(symbol (str "." (name method))) ~(clj-emit/-emit-form* instance opts)
115 | ~@(mapv #(clj-emit/-emit-form* % opts) args)))
116 |
117 | (defmethod -emit-form :default [ast opts]
118 | (jvm-emit/-emit-form ast opts))
119 |
120 | ;;; `-emit-form*` is copied from `clojure.tools.analyzer.passes.jvm.emit-form`,
121 | ;;; which is itself a copy from `clojure.tools.analyzer.passes.emit-form`.
122 |
123 | (defn -emit-form*
124 | [{:keys [form] :as ast} opts]
125 | (let [expr (-emit-form ast opts)
126 | form-meta (meta form)
127 | expr-meta (meta expr)
128 | type-meta (when (:type-meta opts)
129 | (merge {:mask (:mask (:env ast))}
130 | (when-let [t (:rtype ast)]
131 | {:rtype (render-type t)})
132 | (select-keys ast [:rmentions])))]
133 | (if (and (instance? clojure.lang.IObj expr)
134 | (or form-meta expr-meta type-meta))
135 | (with-meta expr (merge form-meta expr-meta type-meta))
136 | expr)))
137 |
138 | (defn emit-form
139 | {:pass-info {:walk :none :depends #{#'uniquify-locals} :compiler true}}
140 | ([ast]
141 | (emit-form ast (:emit-form (:passes-opts (env/deref-env)))))
142 | ([ast opts]
143 | (binding [clj-emit/-emit-form* -emit-form*]
144 | (-emit-form* ast opts))))
145 |
--------------------------------------------------------------------------------
/src/klor/events.clj:
--------------------------------------------------------------------------------
1 | (ns klor.events
2 | (:require
3 | [clojure.set :as set]
4 | [klor.core :refer :all]
5 | [klor.util :refer [usym? error do1]])
6 | (:import java.util.concurrent.LinkedBlockingQueue))
7 |
8 | ;;; Events
9 |
10 | (def ^:dynamic *debug*
11 | false)
12 |
13 | (defn debug [& args]
14 | (when *debug*
15 | (apply println args)))
16 |
17 | (def stop (Object.))
18 |
19 | (defn put! [^LinkedBlockingQueue q e]
20 | ;; NOTE: Wrap `e` in a vector so that we can put nils.
21 | (.put q [e]))
22 |
23 | (defn take! [^LinkedBlockingQueue q]
24 | (first (.take q)))
25 |
26 | (defn send-loop [^LinkedBlockingQueue q send-fn]
27 | (try
28 | (loop []
29 | (let [e (take! q)]
30 | (when-not (= e stop)
31 | (send-fn e)
32 | (recur))))
33 | (catch Throwable t
34 | (debug "Exception:" (.getMessage t)))
35 | (finally
36 | (debug "Send loop exited"))))
37 |
38 | (defn recv-loop [^LinkedBlockingQueue recv-fn]
39 | (try
40 | (while true (recv-fn))
41 | (catch InterruptedException e
42 | (debug "Interrupted"))
43 | (catch Throwable t
44 | (debug "Exception:" (.getMessage t)))
45 | (finally
46 | (debug "Recv loop exited"))))
47 |
48 | (defchor -events [A B] (-> (-> A B) [A A B]) [handler]
49 | (pack (A 'send-queue) (A 'send-loop-thread) (B 'recv-loop-thread)))
50 |
51 | (def events
52 | (with-meta [(fn [send-fn]
53 | (let [q (LinkedBlockingQueue.)]
54 | [q (Thread. (bound-fn [] (send-loop q send-fn)))]))
55 | (fn [recv-fn]
56 | [(Thread. (bound-fn [] (recv-loop recv-fn)))])]
57 | (meta -events)))
58 |
59 | (alter-meta! #'events merge (select-keys (meta #'-events) [:klor/chor]))
60 |
61 | ;;; `with-events`
62 | ;;;
63 | ;;; ::= [*]
64 | ;;; ::= (+)
65 | ;;; ::=
66 | ;;; ::= -> | <- | --
67 |
68 | (defn link-edges [[l kind r :as link]]
69 | (when-not (and (= (count link) 3) (every? usym? [l r]) (not= l r))
70 | (error :klor ["Invalid `with-events` link: " link]))
71 | (case kind
72 | -> [[l r]]
73 | <- [[r l]]
74 | -- [[l r] [r l]]
75 | (error :klor ["Invalid `with-events` link kind: " kind])))
76 |
77 | (defn links-graph [links]
78 | (reduce (fn [acc [src dst]]
79 | (-> (update-in acc [:out src] (fnil conj #{}) dst)
80 | (update-in [:in dst] (fnil conj #{}) src)))
81 | {} (mapcat link-edges links)))
82 |
83 | (defn layout-graph [layout]
84 | (links-graph (mapcat #(partition 3 2 %) layout)))
85 |
86 | (defn graph-roles [{:keys [out in] :as graph}]
87 | (set/union (set (keys out)) (set (keys in))))
88 |
89 | (defn count-of [s]
90 | (get-in @s [:klor/events :count]))
91 |
92 | (defn role-of [s]
93 | (get-in @s [:klor/events :role]))
94 |
95 | (defn out-of [s]
96 | (set (keys (get-in @s [:klor/events :out]))))
97 |
98 | (defn in-of [s]
99 | (set (keys (get-in @s [:klor/events :in]))))
100 |
101 | (defn threads-of [s]
102 | (concat (map :send (vals (get-in @s [:klor/events :out])))
103 | (map :recv (vals (get-in @s [:klor/events :in])))))
104 |
105 | (defn enq! [s dst val]
106 | (if-let [q (get-in @s [:klor/events :out dst :queue])]
107 | (put! q val)
108 | (throw (ex-info (format "No queue for %s" dst) {}))))
109 |
110 | (defn interrupt! [s src]
111 | (if-let [t (get-in @s [:klor/events :in src :recv])]
112 | (.interrupt t)
113 | (throw (ex-info (format "No receiving thread for %s" src) {}))))
114 |
115 | (defn start! [s]
116 | (let [ts (threads-of s)]
117 | (doseq [t ts]
118 | (.start t))
119 | (doseq [t ts]
120 | (.join t))))
121 |
122 | (defn stop! [s]
123 | (doseq [dst (out-of s)]
124 | (enq! s dst stop))
125 | (doseq [src (in-of s)]
126 | (interrupt! s src)))
127 |
128 | (defn data-of [s]
129 | (get @s :data))
130 |
131 | (defn swap-data! [s f & args]
132 | (locking s
133 | (vswap! s (fn [val] (apply update val :data f args)))))
134 |
135 | (defchor link! [A B] (-> #{A B} B A (-> [A B] [B A A] B) #{A B})
136 | [s src dst handler]
137 | (let [sa (narrow [A] s)
138 | sb (narrow [B] s)
139 | handler (chor (-> A B) [msg] (handler (pack sa sb) (pack src dst msg)))]
140 | (unpack [[q ts tr] (events [A B] handler)]
141 | (A (vswap! sa assoc-in [:klor/events :out dst] {:queue q :send ts}))
142 | (B (vswap! sb assoc-in [:klor/events :in src] {:recv tr}))
143 | s)))
144 |
145 | (defmacro with-events [[s {:keys [layout init handler]}] & body]
146 | (let [{:keys [out] :as graph} (layout-graph layout)
147 | roles (graph-roles graph)]
148 | `(lifting [~@roles]
149 | (let [~s (volatile! {:klor/events {:count ~(count roles)}})]
150 | ~@(for [r roles]
151 | `(~r (vswap! ~s assoc-in [:klor/events :role] '~r)))
152 | ~@(for [[src dsts] out
153 | dst dsts]
154 | `(link! [~src ~dst]
155 | (narrow [~src ~dst] ~s) (~dst '~src) (~src '~dst)
156 | (inst ~handler [~src ~dst])))
157 | ~@(for [r roles
158 | :let [e (get init r)]]
159 | `(~r (swap-data! ~s (constantly ~e))))
160 | ~@body))))
161 |
162 | ;;; `with-reacts`
163 |
164 | (defchor event-handler [A B] (-> [A B] [B A A] B) [[_ sb] [src _ msg]]
165 | (B (swap-data! sb (get-in @sb [:klor/actors :swap]) sb src (A->B msg))))
166 |
167 | (defmacro with-reacts [[s {:keys [swap] :as opts}] & body]
168 | `(with-events [~s ~(dissoc (merge opts {:handler `event-handler}) :swap)]
169 | (vswap! ~s assoc-in [:klor/actors :swap] ~swap)
170 | ~@body))
171 |
--------------------------------------------------------------------------------
/src/klor/examples.clj:
--------------------------------------------------------------------------------
1 | (ns klor.examples
2 | (:require
3 | [clojure.core.match :refer [match]]
4 | [clojure.string :as str]
5 | [klor.core :refer :all]
6 | [klor.runtime :refer [play-role]]
7 | [klor.simulator :refer [simulate-chor]])
8 | (:import java.time.LocalDate))
9 |
10 | ;;; Simple
11 |
12 | (defchor simple-1 [A B] (-> A #{A B}) [x]
13 | (A=>B x))
14 |
15 | (defchor simple-2 [A B] (-> A B) [x]
16 | (A->B x))
17 |
18 | (comment
19 | @(simulate-chor simple-1 123)
20 | @(simulate-chor simple-2 123)
21 | )
22 |
23 | ;;; Share
24 |
25 | (defchor share [A B] (-> A B) [x]
26 | (if (A=>B (A (even? x)))
27 | (B (println "It's even!"))
28 | (B (println "It's odd!"))))
29 |
30 | ;;; Remote
31 |
32 | (defchor remote-invoke [A B] (-> B A A) [f x]
33 | (B->A (f (A->B x))))
34 |
35 | (defchor remote-apply [A B] (-> B A A) [f xs]
36 | (B->A (B (apply f (A->B xs)))))
37 |
38 | (defchor remote-map [A B] (-> B A A) [f xs]
39 | (if (A=>B (A (empty? xs)))
40 | (A nil)
41 | (A (cons (remote-invoke [A B] f (first xs))
42 | (remote-map [A B] f (next xs))))))
43 |
44 | ;;; Ping-Pong
45 |
46 | (defchor ping-pong-1 [A B] (-> A [A B]) [n]
47 | (if (A=>B (A (<= n 0)))
48 | ;; NOTE: Some inference could be useful here!
49 | (pack (A :done) (B nil))
50 | (unpack [[x y] (ping-pong-1 [B A] (B (dec (A->B n))))]
51 | (pack y x))))
52 |
53 | (defchor ping-pong-2 [A B] (-> A [A B]) [n]
54 | (let [n (A=>B n)]
55 | (if (<= n 0)
56 | (pack (A :done) (B nil))
57 | (unpack [[x y] (ping-pong-2 [B A] (B (dec n)))]
58 | (pack y x)))))
59 |
60 | (comment
61 | @(simulate-chor ping-pong-1 5)
62 | @(simulate-chor ping-pong-2 5)
63 | )
64 |
65 | ;;; Mutual Recursion
66 |
67 | (defchor mutrec-2 [A B] (-> A [A B]))
68 |
69 | (defchor mutrec-1 [A B] (-> A [A B]) [n]
70 | (A (println 'mutrec-1 n))
71 | (if (A=>B (A (<= n 0)))
72 | (pack (A :done) (B nil))
73 | (mutrec-2 [A B] (A (dec n)))))
74 |
75 | (defchor mutrec-2 [A B] (-> A [A B]) [n]
76 | (A (println 'mutrec-2 n))
77 | (if (A=>B (A (<= n 0)))
78 | (pack (A :done) (B nil))
79 | (mutrec-1 [A B] (A (dec n)))))
80 |
81 | (comment
82 | @(simulate-chor mutrec-1 5)
83 | )
84 |
85 | ;;; Higher-order
86 |
87 | (defchor chain [A B C] (-> (-> B C) (-> A B) A C) [g f x]
88 | (g (f x)))
89 |
90 | (defchor chain-test-1 [A B C] (-> C) []
91 | (chain [A B C]
92 | (chor (-> B C) [x] (B->C (B (+ x 10))))
93 | (chor (-> A B) [x] (A->B (A (* x 10))))
94 | (A 41)))
95 |
96 | (defchor mul [A B] (-> A B) [x]
97 | (A->B (A (* x 10))))
98 |
99 | (defchor add [A B] (-> A B) [x]
100 | (A->B (A (+ x 10))))
101 |
102 | (defchor chain-test-2 [A B C] (-> C) []
103 | (chain [A B C] (inst add [B C]) (inst mul [A B]) (A 41)))
104 |
105 | (defchor compose [A B C] (-> (-> B C) (-> A B) (-> A C | B)) [g f]
106 | (chor (-> A C | B) [x] (g (f x))))
107 |
108 | (defchor compose-test [A B C] (-> C) []
109 | (let [h (compose [A B C] (inst add [B C]) (inst mul [A B]))]
110 | (C (+ (h (A 40)) (h (A 0))))))
111 |
112 | ;;; Buyer--Seller
113 |
114 | (defn ship! [address]
115 | (println "Shipping to" address)
116 | (str (java.time.LocalDate/now)))
117 |
118 | (defchor buy-book-1 [B S] (-> B S B) [order catalog]
119 | (let [price (S->B (S (get catalog (B->S (B (:title order))) :none)))]
120 | (if (B=>S (B (when (int? price) (>= (:budget order) price))))
121 | (let [date (S->B (S (ship! (B->S (B (:address order))))))]
122 | (B (println "I'll get the book on" date))
123 | date)
124 | (do (S (println "Buyer changed his mind"))
125 | (B nil)))))
126 |
127 | (comment
128 | @(simulate-chor buy-book-1
129 | {:title "To Mock A Mockingbird"
130 | :budget 50
131 | :address "Some Address 123"}
132 | {"To Mock A Mockingbird" 50})
133 | )
134 |
135 | ;;; Two-Buyer
136 |
137 | (defchor buy-book-2 [B1 B2 S] (-> B1 S (-> B1 B1 | B2) B1) [order catalog decide]
138 | (let [price (S->B1 (S (get catalog (B1->S (B1 (:title order))) :none)))]
139 | (if (B1=>S (B1 (when (B1=>B2 (int? price)) (decide price))))
140 | (let [date (S->B1 (S (ship! (B1->S (B1 (:address order))))))]
141 | (B1 (println "I'll get the book on" date))
142 | date)
143 | (do (S (println "Buyer changed his mind"))
144 | (B1 nil)))))
145 |
146 | (defchor buy-book-2-main [B1 B2 S] (-> B1 S B1) [order catalog]
147 | (buy-book-2 [B1 B2 S] order catalog
148 | (chor (-> B1 B1) [price]
149 | (let [contrib (B2 (if (rand-nth [true false])
150 | (do (println "I guess I can help") 42)
151 | (do (println "Sorry, I'm broke") 0)))]
152 | (B1 (>= (:budget order) (- price (B2->B1 contrib))))))))
153 |
154 | (comment
155 | @(simulate-chor buy-book-2-main
156 | {:title "To Mock A Mockingbird"
157 | :budget 8
158 | :address "Some Address 123"}
159 | {"To Mock A Mockingbird" 50})
160 | )
161 |
162 | ;;; Auth
163 |
164 | (defn read-creds [prompt]
165 | (print prompt)
166 | {:password (str/trim (read-line))})
167 |
168 | (defchor auth [C A] (-> C #{C A}) [get-creds]
169 | (or (A=>C (A (= (:password (C->A (get-creds))) "secret")))
170 | (and (C=>A (C (rand-nth [true false])))
171 | (auth [C A] get-creds))))
172 |
173 | (defchor get-token [C S A] (-> C C) [get-creds]
174 | (if (A=>S (auth [C A] get-creds))
175 | (S->C (S (random-uuid)))
176 | (C :error)))
177 |
178 | (comment
179 | @(simulate-chor get-token (constantly {:password "secret"}))
180 | @(simulate-chor get-token (constantly {:password "wrong"}))
181 | @(simulate-chor get-token #(hash-map :password (rand-nth ["wrong" "secret"])))
182 | @(simulate-chor get-token #(read-creds "Password: "))
183 | )
184 |
185 | ;;; Diffie--Hellman
186 |
187 | (defn modpow [base exp mod]
188 | (.modPow (biginteger base) (biginteger exp) (biginteger mod)))
189 |
190 | (defchor exchange-key-1 [A B] (-> #{A B} #{A B} A B [A B]) [g p sa sb]
191 | (pack (A (modpow (B->A (B (modpow g sb p))) sa p))
192 | (B (modpow (A->B (A (modpow g sa p))) sb p))))
193 |
194 | (defchor exchange-key-2 [A B] (-> #{A B} #{A B} A B #{A B}) [g p sa sb]
195 | (agree! (A (modpow (B->A (B (modpow g sb p))) sa p))
196 | (B (modpow (A->B (A (modpow g sa p))) sb p))))
197 |
198 | (comment
199 | ;; Example from .
200 | @(simulate-chor exchange-key-1 5 23 4 3)
201 | @(simulate-chor exchange-key-2 5 23 4 3)
202 | )
203 |
204 | (defchor secure-1 [A B] (-> A B) [x]
205 | (unpack [[k1 k2] (exchange-key-1 [A B] 5 23 (A 4) (B 3))]
206 | (B (.xor k2 (A->B (A (.xor k1 (biginteger x))))))))
207 |
208 | (defchor secure-2 [A B] (-> A B) [x]
209 | (let [k (exchange-key-2 [A B] 5 23 (A 4) (B 3))]
210 | (B (.xor k (A->B (A (.xor k (biginteger x))))))))
211 |
212 | (comment
213 | @(simulate-chor secure-1 42)
214 | @(simulate-chor secure-2 42)
215 | )
216 |
217 | ;;; Game
218 |
219 | (defn make-game []
220 | {:moves 0 :black 0 :white 0})
221 |
222 | (defn make-move [player]
223 | {player (inc (rand-int 10))})
224 |
225 | (defn apply-move [game move]
226 | (merge-with + game move {:moves 1}))
227 |
228 | (defn final? [{:keys [moves black white] :as game}]
229 | (and (>= moves 5) (not= black white)))
230 |
231 | (defn winner [game]
232 | (key (apply max-key val game)))
233 |
234 | (defchor play-game [A B] (-> #{A B} A B #{A B}) [game p1 p2]
235 | (let [game (apply-move game (A=>B (A (make-move p1))))]
236 | (if (final? game)
237 | (winner game)
238 | (play-game [B A] game p2 p1))))
239 |
240 | (comment
241 | @(simulate-chor play-game (make-game) :black :white)
242 | )
243 |
244 | ;;; Key-value Store
245 |
246 | (defn handle-req! [req store]
247 | (match req
248 | [:put k v] (do (swap! store assoc k v) v)
249 | [:get k] (get @store k nil)))
250 |
251 | (defchor kvs [C S] (-> C S #{C S}) [req store]
252 | (let [r (S=>C (S (handle-req! (C->S req) store)))]
253 | (agree! (narrow [C] r) (narrow [S] r))))
254 |
255 | (comment
256 | (let [store (atom {})]
257 | @(simulate-chor kvs [:put :secret 42] store)
258 | @(simulate-chor kvs [:get :secret] store))
259 | )
260 |
261 | ;;; Replicated Key-value Store
262 |
263 | (defchor kvs-replicated [C S B] (-> C S B #{C S}) [req primary backup]
264 | (let [req (S=>B (C->S req))]
265 | (B (handle-req! req backup))
266 | (B->S (B :ack))
267 | (S=>C (S (handle-req! req primary)))))
268 |
269 | (comment
270 | (let [primary (atom {})
271 | backup (atom {})]
272 | @(simulate-chor kvs-replicated [:put :secret 42] primary backup)
273 | @(simulate-chor kvs-replicated [:get :secret] primary backup))
274 | )
275 |
276 | ;;; Higher-Order Key-value Store
277 |
278 | (defchor kvs-custom [C S B1 B2] (-> C S B1 B2 (-> S B1 B2 S) #{C S})
279 | [req primary backup1 backup2 backup-chor]
280 | (let [req (C->S req)]
281 | (backup-chor req backup1 backup2)
282 | (S=>C (S (handle-req! req primary)))))
283 |
284 | (defchor kvs-custom-null [C S B1 B2] (-> C S #{C S} | B1 B2) [req primary]
285 | (kvs-custom [C S B1 B2] req primary (B1 nil) (B2 nil)
286 | (chor (-> S B1 B2 S) [_ _ _] (S nil))))
287 |
288 | (comment
289 | (let [primary (atom {})]
290 | @(simulate-chor kvs-custom-null [:put :secret 42] primary)
291 | @(simulate-chor kvs-custom-null [:get :secret] primary))
292 | )
293 |
294 | (defchor kvs-custom-single [C S B1 B2] (-> C S B1 #{C S}) [req primary backup1]
295 | (kvs-custom [C S B1 B2] req primary backup1 (B2 nil)
296 | (chor (-> S B1 B2 S) [req backup1 _]
297 | (let [req (S->B1 req)]
298 | (B1 (handle-req! req backup1))
299 | (B1->S (B1 :ack))))))
300 |
301 | (comment
302 | (let [primary (atom {})
303 | backup (atom {})]
304 | @(simulate-chor kvs-custom-single [:put :secret 42] primary backup)
305 | @(simulate-chor kvs-custom-single [:get :secret] primary backup))
306 | )
307 |
308 | (defchor kvs-custom-double [C S B1 B2] (-> C S B1 B2 #{C S})
309 | [req primary backup1 backup2]
310 | (kvs-custom [C S B1 B2] req primary backup1 backup2
311 | (chor (-> S B1 B2 S) [req backup1 backup2]
312 | (let [req (S=>B2 (S=>B1 req))]
313 | (B1 (handle-req! req backup1))
314 | (B2 (handle-req! req backup2))
315 | (B1->S (B1 :ack))
316 | (B2->S (B2 :ack))))))
317 |
318 | (comment
319 | (let [primary (atom {})
320 | backup1 (atom {})
321 | backup2 (atom {})]
322 | @(simulate-chor kvs-custom-double [:put :secret 42] primary backup1 backup2)
323 | @(simulate-chor kvs-custom-double [:get :secret] primary backup1 backup2))
324 | )
325 |
326 | ;;; Mergesort
327 |
328 | (defchor ms-merge [A B C] (-> B C A) [l r]
329 | (if (B=>C (B=>A (B (not-empty l))))
330 | (if (C=>B (C=>A (C (not-empty r))))
331 | (B (let [[head & tail] l]
332 | (if (B=>C (B=>A (B (< head (C->B (C (first r)))))))
333 | (A (cons (B->A head) (ms-merge [A B C] tail r)))
334 | (A (cons (C->A (C (first r))) (ms-merge [A B C] l (C (next r))))))))
335 | (B->A l))
336 | (C->A r)))
337 |
338 | (defchor mergesort [A B C] (-> A A) [seq]
339 | (A (if (A=>C (A=>B (= (count seq) 1)))
340 | seq
341 | (let [[l r] (split-at (quot (count seq) 2) seq)]
342 | (ms-merge [A B C]
343 | (mergesort [B C A] (A->B l))
344 | (mergesort [C A B] (A->C r)))))))
345 |
346 | (comment
347 | @(simulate-chor mergesort [7 3 4 5 1 0 9 8 6 2])
348 | )
349 |
350 | ;;; Tic-tac-toe
351 |
352 | (def ttt-syms
353 | '[x o])
354 |
355 | (def ttt-none
356 | '_)
357 |
358 | (def ttt-lines
359 | (concat (for [i (range 3)] (for [j (range 3)] [i j]))
360 | (for [i (range 3)] (for [j (range 3)] [j i]))
361 | [(for [i (range 3)] [i i])]
362 | [(for [i (range 3)] [i (- 3 i 1)])]))
363 |
364 | (defn ttt-board []
365 | (vec (repeat 3 (vec (repeat 3 ttt-none)))))
366 |
367 | (defn ttt-place [board loc sym]
368 | (when (= (get-in board loc) ttt-none) (assoc-in board loc sym)))
369 |
370 | (defn ttt-free [board]
371 | (for [i (range 3) j (range 3)
372 | :let [loc [i j]]
373 | :when (= (get-in board loc) ttt-none)]
374 | loc))
375 |
376 | (defn ttt-winner-on [board locs]
377 | (let [syms (distinct (map #(get-in board %) locs))]
378 | (when (= (count syms) 1) (first syms))))
379 |
380 | (defn ttt-winner [board]
381 | (or (some (set ttt-syms) (map #(ttt-winner-on board %) ttt-lines))
382 | (when (empty? (ttt-free board)) :draw)))
383 |
384 | (defn ttt-fmt [board]
385 | (str/join "\n" (map #(str/join " " %) board)))
386 |
387 | (defn ttt-index [board]
388 | (for [i (range 3)]
389 | (for [j (range 3)
390 | :let [loc [i j]
391 | sym (get-in board loc)]]
392 | (if (= sym ttt-none) (+ (* i 3) j 1) sym))))
393 |
394 | (defn ttt-pick [board]
395 | (let [n (do (print (format "Pick a location [1-9]:"))
396 | (flush)
397 | (Long/parseLong (read-line)))
398 | loc [(quot (dec n) 3) (mod (dec n) 3)]]
399 | (if (not= (get-in board loc) ttt-none)
400 | (recur board)
401 | loc)))
402 |
403 | (defchor ttt-play [A B] (-> #{A B} #{A B} #{A B}) [board idx]
404 | (A (println (str "\n" (ttt-fmt (ttt-index board)))))
405 | (if-let [winner (ttt-winner board)]
406 | winner
407 | (let [loc (A=>B (A (ttt-pick board)))
408 | board' (ttt-place board loc (get ttt-syms idx))]
409 | (if board'
410 | (ttt-play [B A] board' (- 1 idx))
411 | (ttt-play [A B] board idx)))))
412 |
413 | (comment
414 | @(simulate-chor ttt-play (ttt-board) 0)
415 | )
416 |
--------------------------------------------------------------------------------
/src/klor/fokkink.clj:
--------------------------------------------------------------------------------
1 | (ns klor.fokkink
2 | (:require
3 | [clojure.set :as set]
4 | [clojure.core.match :refer [match]]
5 | [klor.core :refer :all]
6 | [klor.events :refer
7 | [events with-events count-of out-of in-of data-of swap-data! enq!
8 | start! stop! with-reacts]]
9 | [klor.simulator :refer [simulate-chor]]
10 | [klor.util :refer [usym? error do1]]))
11 |
12 | (def ^:dynamic *debug*
13 | false)
14 |
15 | (defn debug [& args]
16 | (when *debug*
17 | (apply println args)))
18 |
19 | ;;; Util
20 |
21 | (defn max* [& args]
22 | (apply max (remove nil? args)))
23 |
24 | (defn rand-elem [coll]
25 | (rand-nth (seq coll)))
26 |
27 | ;;; Fokkink (2013): Election: Chang--Roberts (Non-faithful)
28 |
29 | (defchor chang-roberts-hop [A B] (-> A A B B) [m da db]
30 | (B (let [m (A->B m)
31 | {:keys [id leader passive?]} db]
32 | (match m
33 | [:ignore]
34 | [m db]
35 |
36 | [:propose {:id id'}]
37 | (cond
38 | (or passive? (> id' id))
39 | (let [leader' (max* leader id')]
40 | [m (assoc db :passive? true :leader leader')])
41 |
42 | (< id' id)
43 | [[:ignore] db]
44 |
45 | (= id' id)
46 | [nil (assoc db :leader id)])))))
47 |
48 | (defchor chang-roberts-round [A B C] (-> A B C [A B C]) [da db dc]
49 | (A (let [m (if (:passive? da) [:ignore] [:propose {:id (:id da)}])]
50 | (B (let [[m db] (chang-roberts-hop [A B] m da db)]
51 | (C (let [[m dc] (chang-roberts-hop [B C] m db dc)]
52 | (A (let [[m da] (chang-roberts-hop [C A] m dc da)]
53 | (pack da db dc))))))))))
54 |
55 | (defchor chang-roberts [A B C] (-> A B C [A B C]) [da db dc]
56 | (unpack [[r1a r1b r1c] (chang-roberts-round [A B C] da db dc)
57 | [r2b r2c r2a] (chang-roberts-round [B C A] r1b r1c r1a)
58 | [r3c r3a r3b] (chang-roberts-round [C A B] r2c r2a r2b)]
59 | (pack r3a r3b r3c)))
60 |
61 | (comment
62 | @(simulate-chor chang-roberts {:id 7} {:id 3} {:id 9})
63 | @(apply simulate-chor chang-roberts
64 | (for [id (take 3 (shuffle (range 10)))] {:id id}))
65 | )
66 |
67 | ;;; Fokkink (2013): Election: Chang--Roberts
68 |
69 | (defn chang-roberts-enq! [s msg]
70 | (enq! s (first (out-of s)) msg))
71 |
72 | (defn chang-roberts-swap [{:keys [id leader passive? leader?] :as data} s _ msg]
73 | (match msg
74 | [:propose {:id id'}]
75 | (cond
76 | ;; Purge the message if we have already become the leader previously.
77 | (or leader?)
78 | data
79 |
80 | ;; Update the last observed leader if we're passive or our ID is smaller
81 | ;; than the received one. Also pass on the message.
82 | (or passive? (> id' id))
83 | (let [leader' (max* leader id')]
84 | (debug "New leader:" leader')
85 | (chang-roberts-enq! s msg)
86 | (assoc data :passive? true :leader leader'))
87 |
88 | ;; Purge the message if our ID is higher than the received one.
89 | (< id' id)
90 | data
91 |
92 | ;; Become the leader if our ID matches the received one, as that means the
93 | ;; message came from us and made a full round trip. Also send an exit
94 | ;; message.
95 | :else
96 | (do (debug "I am the leader:" id)
97 | (chang-roberts-enq! s [:exit {:id id}])
98 | (assoc data :leader id :leader? true)))
99 |
100 | ;; Pass on the `:exit` message and then exit.
101 | [:exit {:id id'}]
102 | (do (debug "Exiting")
103 | (when (not= id id')
104 | (chang-roberts-enq! s msg))
105 | (stop! s)
106 | data)))
107 |
108 | (defmacro chang-roberts [[head & _ :as roles] & args]
109 | (when-not (and (every? usym? roles) (apply distinct? roles))
110 | (error :klor ["Invalid `chang-roberts` roles: " roles]))
111 | (when-not (>= (count roles) 2)
112 | (error :klor ["`chang-roberts` needs at least 2 roles: " roles]))
113 | (let [ring (interpose '-> (concat roles [head]))
114 | s (gensym "s")]
115 | `(with-reacts [~s {:layout [(~@ring)]
116 | :init ~(zipmap roles args)
117 | :swap chang-roberts-swap}]
118 | (let [{id# :id passive?# :passive} (data-of ~s)]
119 | (when (not passive?#)
120 | (chang-roberts-enq! ~s [:propose {:id id#}])))
121 | (start! ~s)
122 | (pack ~@(for [r roles] `(~r (data-of ~s)))))))
123 |
124 | (defchor chang-roberts-test [A B C] (-> A B C [A B C]) [da db dc]
125 | (chang-roberts [A B C] da db dc))
126 |
127 | (comment
128 | @(simulate-chor chang-roberts-test {:id 7} {:id 3} {:id 9})
129 | @(apply simulate-chor chang-roberts-test
130 | (for [id (take 3 (shuffle (range 10)))] {:id id}))
131 | )
132 |
133 | ;;; Fokkink (2013): Waves: Itai--Rodeh
134 |
135 | (defn itai-rodeh-enq! [s msg]
136 | (enq! s (first (out-of s)) msg))
137 |
138 | (defn itai-rodeh-swap [{:keys [id round leader passive? leader?] :as data} s _ msg]
139 | (let [n (count-of s)]
140 | (match msg
141 | [:propose {:id id' :round round' :hops hops :dup? dup?}]
142 | (cond
143 | (or leader?)
144 | data
145 |
146 | (or passive? (> round' round) (and (= round' round) (> id' id)))
147 | (let [leader' (max* leader id')]
148 | (debug "New leader:" leader')
149 | (itai-rodeh-enq! s (update-in msg [1 :hops] inc))
150 | (assoc data :passive? true :leader leader'))
151 |
152 | (or (< round' round) (and (= round' round) (< id' id)))
153 | data
154 |
155 | (and (= round' round) (= id' id) (< hops n))
156 | (do (itai-rodeh-enq! s [:propose {:id id :round round
157 | :hops (inc hops) :dup? true}])
158 | data)
159 |
160 | (and (= round' round) (= id' id) (= hops n) dup?)
161 | (let [id'' (rand-int n)
162 | round' (inc round)]
163 | (debug "New ID:" id'')
164 | (itai-rodeh-enq! s [:propose {:id id'' :round round'
165 | :hops 1 :dup? false}])
166 | (assoc data :id id'' :round round'))
167 |
168 | (and (= round' round) (= id' id) (= hops n) (not dup?))
169 | (do (debug "I am the leader:" id)
170 | (itai-rodeh-enq! s [:exit {:hops 1}])
171 | (assoc data :leader id :leader? true)))
172 |
173 | ;; Pass on the `:exit` message and then exit.
174 | [:exit {:hops hops}]
175 | (do (debug "Exiting")
176 | (when (not= hops n)
177 | (itai-rodeh-enq! s (update-in msg [1 :hops] inc)))
178 | (stop! s)
179 | data))))
180 |
181 | (defmacro itai-rodeh [[head & _ :as roles] & args]
182 | (when-not (and (every? usym? roles) (apply distinct? roles))
183 | (error :klor ["Invalid `itai-rodeh` roles: " roles]))
184 | (when-not (>= (count roles) 2)
185 | (error :klor ["`itai-rodeh` needs at least 2 roles: " roles]))
186 | (let [ring (interpose '-> (concat roles [head]))
187 | s (gensym "s")]
188 | `(with-reacts [~s {:layout [(~@ring)]
189 | :init ~(zipmap roles args)
190 | :swap itai-rodeh-swap}]
191 | (swap-data! ~s #(merge %2 %1) {:round 0 :id (rand-int (count-of ~s))})
192 | (let [{id# :id round# :round passive?# :passive} (data-of ~s)]
193 | (when (not passive?#)
194 | (itai-rodeh-enq! ~s [:propose {:id id# :round round#
195 | :hops 1 :dup? false}])))
196 | (start! ~s)
197 | (pack ~@(for [r roles] `(~r (data-of ~s)))))))
198 |
199 | (defchor itai-rodeh-test [A B C] (-> A B C [A B C]) [da db dc]
200 | (itai-rodeh [A B C] da db dc))
201 |
202 | (comment
203 | @(simulate-chor itai-rodeh-test {:id 1} {:id 0 :passive? true} {:id 1})
204 | @(simulate-chor itai-rodeh-test {} {} {})
205 | )
206 |
207 | ;;; Fokkink (2013): Waves: Tarry's Algorithm
208 |
209 | (defn tarry-swap [{:keys [parent done] :as data} s src msg]
210 | (match msg
211 | [:token {:hops hops}]
212 | (let [;; Set the parent if necessary
213 | parent' (or parent src)
214 | ;; Compute the set of unvisited neighbors
215 | todo (set/difference (disj (out-of s) parent') done)
216 | ;; Choose a random unvisited neighbor to pass the token to
217 | next (or (rand-elem todo) parent')
218 | ;; Update the done set
219 | done' (if (= next :root) done (conj done next))]
220 | ;; Only pass the token if we're not the initiator
221 | (when (not= next :root)
222 | (enq! s next [:token {:hops (inc hops)}]))
223 | ;; Stop if we sent to our parent
224 | (when (= next parent')
225 | (stop! s))
226 | (assoc data :parent parent' :done done'))))
227 |
228 | (defmacro tarry [[initiator & _ :as roles] layout & args]
229 | (let [s (gensym "s")]
230 | `(with-reacts [~s {:layout ~layout
231 | :swap tarry-swap}]
232 | (swap-data! ~s (constantly {:done #{}}))
233 | (~initiator
234 | (let [next# (rand-elem (out-of ~s))]
235 | (swap-data! ~s (constantly {:parent :root :done #{next#}}))
236 | (enq! ~s next# [:token {:hops 1}])))
237 | (start! ~s)
238 | (pack ~@(for [r roles] `(~r (data-of ~s)))))))
239 |
240 | (defchor tarry-test [A B C D E] (-> [A B C D E]) []
241 | (tarry [A B C D E] [(C -- B -- A -- D -- E -- B) (A -- E)]))
242 |
243 | (comment
244 | @(simulate-chor tarry-test)
245 | )
246 |
247 | ;;; Fokkink (2013): Waves: Depth-first Search
248 |
249 | (defn dfs-swap [{:keys [parent done] :as data} s src msg]
250 | (match msg
251 | [:token {:hops hops}]
252 | (let [;; Set the parent if necessary
253 | parent' (or parent src)
254 | ;; Compute the set of unvisited neighbors
255 | todo (set/difference (disj (out-of s) parent') done)
256 | ;; Choose a random unvisited neighbor to pass the token to, but
257 | ;; prioritize the source if possible
258 | next (if (contains? todo src) src (or (rand-elem todo) parent'))
259 | ;; Update the done set
260 | done' (if (= next :root) done (conj done next))]
261 | ;; Only pass the token if we're not the initiator
262 | (when (not= next :root)
263 | (enq! s next [:token {:hops (inc hops)}]))
264 | ;; Stop if we sent to our parent
265 | (when (= next parent')
266 | (debug "Stopping!")
267 | (stop! s))
268 | (assoc data :parent parent' :done done'))))
269 |
270 | (defmacro dfs [[initiator & _ :as roles] layout]
271 | (let [s (gensym "s")]
272 | `(with-reacts [~s {:layout ~layout
273 | :swap dfs-swap}]
274 | (swap-data! ~s (constantly {:done #{}}))
275 | (~initiator
276 | (let [next# (rand-elem (out-of ~s))]
277 | (swap-data! ~s (constantly {:parent :root :done #{next#}}))
278 | (enq! ~s next# [:token {:hops 1}])))
279 | (start! ~s)
280 | (pack ~@(for [r roles] `(~r (data-of ~s)))))))
281 |
282 | (defchor dfs-test [A B C D E] (-> [A B C D E]) []
283 | (dfs [A B C D E] [(C -- B -- A -- D -- E -- B) (A -- E)]))
284 |
285 | (comment
286 | @(simulate-chor dfs-test)
287 | )
288 |
289 | ;;; Fokkink (2013): Waves: Echo
290 |
291 | (defn echo-swap [{:keys [parent todo] :as data} s src msg]
292 | (match msg
293 | [:token {:hops hops}]
294 | (let [;; Set the parent if necessary
295 | parent' (or parent src)
296 | ;; Update the todo set
297 | todo' (disj todo src)
298 | ;; Compute who to send to
299 | next (set/union
300 | ;; Send to non-parent neighbors on the first receive
301 | (when (not parent)
302 | (disj (in-of s) src))
303 | ;; Send to the parent once we have received all replies
304 | (when (and (empty? todo') (not= parent :root))
305 | #{parent'}))]
306 | (doseq [n next]
307 | (enq! s n [:token {:hops (inc hops)}]))
308 | ;; Stop if we've received all replies
309 | (when (empty? todo')
310 | (stop! s))
311 | (assoc data :parent parent' :todo todo'))))
312 |
313 | (defn echo! [s msg]
314 | (doseq [dst (out-of s)]
315 | (enq! s dst msg)))
316 |
317 | (defmacro echo [[initiator & _ :as roles] layout]
318 | (let [s (gensym "s")]
319 | `(with-reacts [~s {:layout ~layout
320 | :swap echo-swap}]
321 | (swap-data! ~s (constantly {:todo (in-of ~s)}))
322 | (~initiator (swap-data! ~s merge {:parent :root})
323 | (echo! ~s [:token {:hops 1}]))
324 | (start! ~s)
325 | (pack ~@(for [r roles] `(~r (data-of ~s)))))))
326 |
327 | (defchor echo-test [A B C D E] (-> [A B C D E]) []
328 | (echo [A B C D E] [(C -- B -- A -- D -- E -- B -- D) (A -- E)]))
329 |
330 | (comment
331 | @(simulate-chor echo-test)
332 | )
333 |
334 | ;;; Fokkink (2013): Waves: Echo with Extinction
335 |
336 | (defn echoex-reset [{:keys [itodo] :as data} & kvs]
337 | (apply assoc data :parent nil :todo itodo kvs))
338 |
339 | (defn echoex-wave [{:keys [id wave parent todo exit] :as data} s src msg]
340 | (let [;; Set the parent if necessary
341 | parent' (or parent src)
342 | ;; Update the todo set
343 | todo' (disj todo src)]
344 | (do1 (if (and (not= msg [:exit]) (empty? todo') (= wave id))
345 | (do (echo! s [:exit])
346 | (echoex-reset data :parent :root :exit true))
347 | (let [next (set/union
348 | ;; Send to non-parent neighbors on the first receive
349 | (when (not parent)
350 | (disj (in-of s) src))
351 | ;; Send to the parent once we have received all replies
352 | (when (and (empty? todo') (not= parent :root) (not= wave id))
353 | #{parent'}))]
354 | (doseq [n next]
355 | (enq! s n msg))
356 | (assoc data :parent parent' :todo todo')))
357 | ;; Stop if we've received all `:exit` messages
358 | (when (and (empty? todo') exit)
359 | (stop! s)))))
360 |
361 | (defn echoex-swap [{:keys [wave itodo exit] :as data} s src msg]
362 | (match msg
363 | [:exit]
364 | (echoex-wave (if exit data (echoex-reset data :exit true)) s src msg)
365 |
366 | [:token {:id id}]
367 | (cond
368 | (or exit (and wave (< id wave)))
369 | data
370 |
371 | (or (not wave) (> id wave))
372 | (echoex-wave (echoex-reset data :wave id) s src msg)
373 |
374 | :else
375 | (echoex-wave data s src msg))))
376 |
377 | (defmacro echoex [roles layout & args]
378 | (let [s (gensym "s")]
379 | `(with-reacts [~s {:layout ~layout
380 | :init ~(zipmap roles args)
381 | :swap echoex-swap}]
382 | (swap-data! ~s merge {:itodo (in-of ~s) :parent :root})
383 | (echo! ~s [:token {:id (:id (data-of ~s))}])
384 | (start! ~s)
385 | (pack ~@(for [r roles] `(~r (data-of ~s)))))))
386 |
387 | (defchor echoex-test [A B C D E] (-> A B C D E [A B C D E]) [da db dc dd de]
388 | (echoex [A B C D E] [(C -- B -- A -- D -- E -- B -- D) (A -- E)]
389 | da db dc dd de))
390 |
391 | (comment
392 | @(simulate-chor echoex-test {:id 3} {:id 11} {:id 1} {:id 7} {:id 15})
393 | @(apply simulate-chor echoex-test
394 | (for [id (take 5 (shuffle (range 20)))] {:id id}))
395 | )
396 |
--------------------------------------------------------------------------------
/src/klor/fokkink_plain.clj:
--------------------------------------------------------------------------------
1 | (ns klor.fokkink-plain
2 | (:require
3 | [clojure.set :as set]
4 | [clojure.core.async :as a]
5 | [clojure.core.match :refer [match]]
6 | [klor.events :as events]
7 | [klor.util :refer [do1]]))
8 |
9 | (def ^:dynamic *debug*
10 | false)
11 |
12 | (defn debug [& args]
13 | (when *debug*
14 | (locking *out*
15 | (apply println args))))
16 |
17 | ;;; Util
18 |
19 | (defn max* [& args]
20 | (apply max (remove nil? args)))
21 |
22 | (defn rand-elem [coll]
23 | (rand-nth (seq coll)))
24 |
25 | ;;; Transport
26 |
27 | (defn ensure-channel [channels src dst]
28 | (if (get channels [src dst])
29 | channels
30 | (conj channels [[src dst] (a/chan 100)])))
31 |
32 | (defn get-channel [channels src dst]
33 | (let [channels (swap! channels ensure-channel src dst)]
34 | (get channels [src dst])))
35 |
36 | (defn send! [s dst val]
37 | (let [{:keys [chans me]} s]
38 | ;; NOTE: Wrap `val` in a vector so that we can communicate nils.
39 | (do1 val
40 | (a/>!! (get-channel chans me dst) [val]))))
41 |
42 | (defn recv! [s src]
43 | (let [{:keys [chans me]} s
44 | [val] (a/" (str me ": " (pr-str val))))))
47 |
48 | (defn send-first! [s val]
49 | (send! s (first (:outs s)) val))
50 |
51 | (defn send-all! [s val]
52 | (doseq [o (:outs s)]
53 | (send! s o val)))
54 |
55 | (defn recv-any! [s]
56 | (let [{:keys [chans me ins]} s
57 | [[val] chan] (a/alts!! (map #(get-channel chans % me) ins))
58 | src (some (fn [[[src _] chan']] (when (= chan chan') src)) @chans)]
59 | (do1 [val src]
60 | (debug src "-->" (str me ": " (pr-str val))))))
61 |
62 | ;;; Fokkink (2013): Election: Chang--Roberts
63 |
64 | (defn chang-roberts-loop [s]
65 | (loop [{:keys [id leader passive? leader?] :as data} (:data s)]
66 | (let [[msg _] (recv-any! s)]
67 | (match msg
68 | [:propose {:id id'}]
69 | (cond
70 | ;; Purge the message if we have already become the leader previously.
71 | (or leader?)
72 | (recur data)
73 |
74 | ;; Update the last observed leader if we're passive or our ID is
75 | ;; smaller than the received one. Also pass on the message.
76 | (or passive? (> id' id))
77 | (let [leader' (max* leader id')]
78 | (debug "New leader:" leader')
79 | (send-first! s msg)
80 | (recur (assoc data :passive? true :leader leader')))
81 |
82 | ;; Purge the message if our ID is higher than the received one.
83 | (< id' id)
84 | (recur data)
85 |
86 | ;; Become the leader if our ID matches the received one, as that means
87 | ;; the message came from us and made a full round trip. Also send an
88 | ;; exit message.
89 | :else
90 | (do (debug "I am the leader:" id)
91 | (send-first! s [:exit {:id id}])
92 | (recur (assoc data :leader id :leader? true))))
93 |
94 | ;; Pass on the `:exit` message and then exit.
95 | [:exit {:id id'}]
96 | (do (debug "Exiting")
97 | (when (not= id id')
98 | (send-first! s msg))
99 | data)))))
100 |
101 | (defn chang-roberts-1 [chans me ins outs data]
102 | (let [s {:chans chans :me me :ins ins :outs outs :data data}
103 | {:keys [id passive?]} data]
104 | (when (not passive?)
105 | (send-first! s [:propose {:id id}]))
106 | (chang-roberts-loop s)))
107 |
108 | (defn chang-roberts [[head & _ :as roles] & args]
109 | (let [ring (interpose '-> (concat roles [head]))
110 | {:keys [in out] :as graph} (events/layout-graph [ring])
111 | chans (atom {})
112 | ps (for [[role arg] (map vector roles args)]
113 | (future
114 | (chang-roberts-1 chans role (in role) (out role) arg)))]
115 | (mapv deref (doall ps))))
116 |
117 | (comment
118 | (chang-roberts '[A B C] {:id 3} {:id 7} {:id 5})
119 | )
120 |
121 | ;;; Fokkink (2013): Waves: Itai--Rodeh
122 |
123 | (defn itai-rodeh-loop [s]
124 | (loop [{:keys [n id round leader passive? leader?] :as data} (:data s)]
125 | (let [[msg _] (recv-any! s)]
126 | (match msg
127 | [:propose {:id id' :round round' :hops hops :dup? dup?}]
128 | (cond
129 | (or leader?)
130 | (recur data)
131 |
132 | (or passive? (> round' round) (and (= round' round) (> id' id)))
133 | (let [leader' (max* leader id')]
134 | (debug "New leader:" leader')
135 | (send-first! s (update-in msg [1 :hops] inc))
136 | (recur (assoc data :passive? true :leader leader')))
137 |
138 | (or (< round' round) (and (= round' round) (< id' id)))
139 | (recur data)
140 |
141 | (and (= round' round) (= id' id) (< hops n))
142 | (do (send-first! s [:propose {:id id :round round
143 | :hops (inc hops) :dup? true}])
144 | (recur data))
145 |
146 | (and (= round' round) (= id' id) (= hops n) dup?)
147 | (let [id'' (rand-int n)
148 | round' (inc round)]
149 | (debug "New ID:" id'')
150 | (send-first! s [:propose {:id id'' :round round'
151 | :hops 1 :dup? false}])
152 | (recur (assoc data :id id'' :round round')))
153 |
154 | (and (= round' round) (= id' id) (= hops n) (not dup?))
155 | (do (debug "I am the leader:" id)
156 | (send-first! s [:exit {:hops 1}])
157 | (recur (assoc data :leader id :leader? true))))
158 |
159 | ;; Pass on the `:exit` message and then exit.
160 | [:exit {:hops hops}]
161 | (do (debug "Exiting")
162 | (when (not= hops n)
163 | (send-first! s (update-in msg [1 :hops] inc)))
164 | data)))))
165 |
166 | (defn itai-rodeh-1 [chans me ins outs {:keys [n] :as data}]
167 | (let [{:keys [data] :as s} {:chans chans :me me :ins ins :outs outs
168 | :data (merge data {:round 0 :id (rand-int n)})}
169 | {:keys [id round passive?]} data]
170 | (when (not passive?)
171 | (send-first! s [:propose {:id id :round round :hops 1 :dup? false}]))
172 | (itai-rodeh-loop s)))
173 |
174 | (defn itai-rodeh [[head & _ :as roles] & args]
175 | (let [ring (interpose '-> (concat roles [head]))
176 | {:keys [in out] :as graph} (events/layout-graph [ring])
177 | chans (atom {})
178 | ps (for [[role arg] (map vector roles args)]
179 | (future
180 | (itai-rodeh-1 chans role (in role) (out role) arg)))]
181 | (mapv deref (doall ps))))
182 |
183 | (comment
184 | (itai-rodeh '[A B C] {:n 3} {:n 3} {:n 3})
185 | )
186 |
187 | ;;; Fokkink (2013): Waves: Tarry's Algorithm
188 |
189 | (defn tarry-loop [{:keys [outs] :as s}]
190 | (loop [{:keys [parent done] :as data} (:data s)]
191 | (let [[msg src] (recv-any! s)]
192 | (match msg
193 | [:token {:hops hops}]
194 | (let [ ;; Set the parent if necessary
195 | parent' (or parent src)
196 | ;; Compute the set of unvisited neighbors
197 | todo (set/difference (disj outs parent') done)
198 | ;; Choose a random unvisited neighbor to pass the token to
199 | next (or (rand-elem todo) parent')
200 | ;; Update the done set
201 | done' (if (= next :root) done (conj done next))]
202 | ;; Only pass the token if we're not the initiator
203 | (when (not= next :root)
204 | (send! s next [:token {:hops (inc hops)}]))
205 | ;; Stop if we sent to our parent
206 | (let [data' (assoc data :parent parent' :done done')]
207 | (if (= next parent') data' (recur data'))))))))
208 |
209 | (defn tarry-1 [chans me ins outs {:keys [init?] :as data}]
210 | (let [s {:chans chans :me me :ins ins :outs outs
211 | :data (merge data {:done #{}})}
212 | s (if init?
213 | (let [next (rand-elem outs)]
214 | (send! s next [:token {:hops 1}])
215 | (update s :data merge {:parent :root :done #{next}}))
216 | s)]
217 | (tarry-loop s)))
218 |
219 | (defn tarry [roles layout]
220 | (let [{:keys [in out] :as graph} (events/layout-graph layout)
221 | chans (atom {})
222 | ps (for [[role arg] (map vector roles (cons {:init? true} (repeat {})))]
223 | (future (tarry-1 chans role (in role) (out role) arg)))]
224 | (mapv deref (doall ps))))
225 |
226 | (comment
227 | (tarry '[A B C D E] '[(C -- B -- A -- D -- E -- B) (A -- E)])
228 | )
229 |
230 | ;;; Fokkink (2013): Waves: Depth-first Search
231 |
232 | (defn dfs-loop [{:keys [outs] :as s}]
233 | (loop [{:keys [parent done] :as data} (:data s)]
234 | (let [[msg src] (recv-any! s)]
235 | (match msg
236 | [:token {:hops hops}]
237 | (let [;; Set the parent if necessary
238 | parent' (or parent src)
239 | ;; Compute the set of unvisited neighbors
240 | todo (set/difference (disj outs parent') done)
241 | ;; Choose a random unvisited neighbor to pass the token to, but
242 | ;; prioritize the source if possible
243 | next (if (contains? todo src) src (or (rand-elem todo) parent'))
244 | ;; Update the done set
245 | done' (if (= next :root) done (conj done next))]
246 | ;; Only pass the token if we're not the initiator
247 | (when (not= next :root)
248 | (send! s next [:token {:hops (inc hops)}]))
249 | ;; Stop if we sent to our parent
250 | (let [data' (assoc data :parent parent' :done done')]
251 | (if (= next parent') data' (recur data'))))))))
252 |
253 | (defn dfs-1 [chans me ins outs {:keys [init?] :as data}]
254 | (let [s {:chans chans :me me :ins ins :outs outs
255 | :data (merge data {:done #{}})}
256 | s (if init?
257 | (let [next (rand-elem outs)]
258 | (send! s next [:token {:hops 1}])
259 | (update s :data merge {:parent :root :done #{next}}))
260 | s)]
261 | (dfs-loop s)))
262 |
263 | (defn dfs [roles layout]
264 | (let [{:keys [in out] :as graph} (events/layout-graph layout)
265 | chans (atom {})
266 | ps (for [[role arg] (map vector roles (cons {:init? true} (repeat {})))]
267 | (future (dfs-1 chans role (in role) (out role) arg)))]
268 | (mapv deref (doall ps))))
269 |
270 | (comment
271 | (dfs '[A B C D E] '[(C -- B -- A -- D -- E -- B) (A -- E)])
272 | )
273 |
274 | ;;; Fokkink (2013): Waves: Echo
275 |
276 | (defn echo-loop [{:keys [ins] :as s}]
277 | (loop [{:keys [parent todo] :as data} (:data s)]
278 | (let [[msg src] (recv-any! s)]
279 | (match msg
280 | [:token {:hops hops}]
281 | (let [;; Set the parent if necessary
282 | parent' (or parent src)
283 | ;; Update the todo set
284 | todo' (disj todo src)
285 | ;; Compute who to send to
286 | next (set/union
287 | ;; Send to non-parent neighbors on the first receive
288 | (when (not parent)
289 | (disj ins src))
290 | ;; Send to the parent once we have received all replies
291 | (when (and (empty? todo') (not= parent :root))
292 | #{parent'}))]
293 | (doseq [n next]
294 | (send! s n [:token {:hops (inc hops)}]))
295 | ;; Stop if we've received all replies
296 | (let [data' (assoc data :parent parent' :todo todo')]
297 | (if (empty? todo') data' (recur data'))))))))
298 |
299 | (defn echo-1 [chans me ins outs {:keys [init?] :as data}]
300 | (let [s {:chans chans :me me :ins ins :outs outs
301 | :data (merge data {:todo ins})}
302 | s (if init?
303 | (do
304 | (send-all! s [:token {:hops 1}])
305 | (update s :data merge {:parent :root}))
306 | s)]
307 | (echo-loop s)))
308 |
309 | (defn echo [roles layout]
310 | (let [{:keys [in out] :as graph} (events/layout-graph layout)
311 | chans (atom {})
312 | ps (for [[role arg] (map vector roles (cons {:init? true} (repeat {})))]
313 | (future (echo-1 chans role (in role) (out role) arg)))]
314 | (mapv deref (doall ps))))
315 |
316 | (comment
317 | (echo '[A B C D E] '[(C -- B -- A -- D -- E -- B -- D) (A -- E)])
318 | )
319 |
320 | ;;; Fokkink (2013): Waves: Echo with Extinction
321 |
322 | (defn echoex-reset [{:keys [itodo] :as data} & kvs]
323 | (apply assoc data :parent nil :todo itodo kvs))
324 |
325 | (defn echoex-wave [{:keys [id wave parent todo exit] :as data}
326 | {:keys [ins] :as s} src msg]
327 | (let [;; Set the parent if necessary
328 | parent' (or parent src)
329 | ;; Update the todo set
330 | todo' (disj todo src)]
331 | (if (and (not= msg [:exit]) (empty? todo') (= wave id))
332 | (do (send-all! s [:exit])
333 | [true (echoex-reset data :parent :root :exit true)])
334 | (let [next (set/union
335 | ;; Send to non-parent neighbors on the first receive
336 | (when (not parent)
337 | (disj ins src))
338 | ;; Send to the parent once we have received all replies
339 | (when (and (empty? todo') (not= parent :root) (not= wave id))
340 | #{parent'}))]
341 | (doseq [n next]
342 | (send! s n msg))
343 | [(not (and (empty? todo') exit))
344 | (assoc data :parent parent' :todo todo')]))))
345 |
346 | (defn echoex-loop [s]
347 | (loop [{:keys [wave itodo exit] :as data} (:data s)]
348 | (let [[msg src] (recv-any! s)]
349 | (match msg
350 | [:exit]
351 | (let [[c d] (echoex-wave (if exit data (echoex-reset data :exit true)) s
352 | src msg)]
353 | (if c (recur d) d))
354 |
355 | [:token {:id id}]
356 | (cond
357 | (or exit (and wave (< id wave)))
358 | (recur data)
359 |
360 | (or (not wave) (> id wave))
361 | (let [[c d] (echoex-wave (echoex-reset data :wave id) s src msg)]
362 | (if c (recur d) d))
363 |
364 | :else
365 | (let [[c d] (echoex-wave data s src msg)]
366 | (if c (recur d) d)))))))
367 |
368 | (defn echoex-1 [chans me ins outs {:keys [id] :as data}]
369 | (let [s {:chans chans :me me :ins ins :outs outs
370 | :data (merge data {:itodo ins :parent :root})}]
371 | (send-all! s [:token {:id id}])
372 | (echoex-loop s)))
373 |
374 | (defn echoex [roles layout & args]
375 | (let [{:keys [in out] :as graph} (events/layout-graph layout)
376 | chans (atom {})
377 | ps (for [[role arg] (map vector roles args)]
378 | (future (echoex-1 chans role (in role) (out role) arg)))]
379 | (mapv deref (doall ps))))
380 |
381 | (comment
382 | (echoex '[A B C D E] '[(C -- B -- A -- D -- E -- B -- D) (A -- E)]
383 | {:id 3} {:id 11} {:id 1} {:id 7} {:id 15})
384 | )
385 |
--------------------------------------------------------------------------------
/src/klor/instrument.clj:
--------------------------------------------------------------------------------
1 | (ns klor.instrument
2 | (:require
3 | [clojure.tools.analyzer.env :as env]
4 | [clojure.tools.analyzer.passes :refer [schedule]]
5 | [klor.analyzer :refer [analyze*]]
6 | [klor.emit-form :refer [emit-form]]
7 | [klor.specials :refer [narrow lifting inst]]
8 | [klor.stdlib :refer [bcast gather]]
9 | [klor.types :refer [render-type replace-roles]]
10 | [klor.typecheck :refer [typecheck sanity-check]]
11 | [klor.util :refer [usym? error warn]]))
12 |
13 | ;;; NOTE: For ease of development and convenience, agreement and signature
14 | ;;; verification are implemented at the choreographic level via macros, which
15 | ;;; are then injected into the code. However, macros work at the lower
16 | ;;; S-expression level while the instrumentation pass has to work with an AST.
17 | ;;; For that reason, we construct the macro form on the fly and invoke the
18 | ;;; analyzer (again) to produce an AST.
19 | ;;;
20 | ;;; The AST also has to be type checked again because the macro can expand to
21 | ;;; arbitrary code. This goes not just for the AST produced on the fly but for
22 | ;;; the whole AST, because both the type and/or the mentions can change and have
23 | ;;; to be propagated upward. This is especially important for the verification
24 | ;;; of agreement parameters, since the checks injected into the body can
25 | ;;; technically widen the set of its mentioned roles if not all roles are
26 | ;;; mentioned (although generally it is silly for a top-level choreography's
27 | ;;; body not to already mention all of its roles).
28 |
29 | ;;; Agreement Verification
30 |
31 | (defn agree? [vals]
32 | (if (every? fn? vals)
33 | (do (warn ["Cannot check for agreement when values are functions"])
34 | true)
35 | (apply = vals)))
36 |
37 | (defn agreement-error [expr vals]
38 | (error :klor ["Values of an agreement differ: " expr ", " vals]))
39 |
40 | (defmacro verify-agreement-centralized [[role & others :as roles] expr]
41 | (let [sym (gensym "expr")
42 | make-narrow (fn [role] `(narrow [~role] ~sym))]
43 | `(let [~sym ~expr
44 | vals# (~role (apply vector ~sym
45 | (gather [~@roles] ~@(map make-narrow others))))]
46 | (lifting [~@roles]
47 | (when-not (bcast [~@roles] (~role (agree? vals#)))
48 | (agreement-error '~expr (bcast [~@roles] vals#))))
49 | ~sym)))
50 |
51 | (defmacro verify-agreement-decentralized [roles expr]
52 | (let [sym (gensym "expr")
53 | make-bcast (fn [role] `(bcast [~role ~@(remove #{role} roles)]
54 | (narrow [~role] ~sym)))]
55 | `(let [~sym ~expr]
56 | (lifting [~@roles]
57 | (let [vals# ~(mapv make-bcast roles)]
58 | (when-not (agree? vals#)
59 | (agreement-error '~expr vals#))))
60 | ~sym)))
61 |
62 | ;;; Signature Verification
63 |
64 | (defn defchor-signature-changed? [roles signature roles' signature']
65 | (and roles roles'
66 | (or (not= (count roles) (count roles'))
67 | (not= (replace-roles signature (zipmap roles (range)))
68 | (replace-roles signature' (zipmap roles' (range)))))))
69 |
70 | (defn render-signature [roles signature]
71 | `(~'forall ~roles ~(render-type signature)))
72 |
73 | (defn signature-error [var roles signature roles' signature']
74 | (error :klor ["Signature of " var " differs from the recorded one:\n"
75 | " was " (render-signature roles signature) ",\n"
76 | " is " (render-signature roles' signature') ";\n"
77 | "make sure to recompile"]))
78 |
79 | (defmacro verify-inst [name inst-roles roles signature]
80 | `(do
81 | (lifting [~@inst-roles]
82 | (let [{roles'# :roles signature'# :signature} (:klor/chor (meta #'~name))]
83 | (when (defchor-signature-changed? '~roles '~signature roles'# signature'#)
84 | (signature-error #'~name '~roles '~signature roles'# signature'#))))
85 | (inst ~name [~@inst-roles])))
86 |
87 | ;;; Instrumentation
88 |
89 | (defmulti -instrument (fn [{:keys [op] :as ast} opts] op))
90 |
91 | (defn instrument
92 | {:pass-info {:walk :post :depends #{#'typecheck} :after #{#'sanity-check}}}
93 | ([ast]
94 | (instrument ast (get-in (env/deref-env) [:passes-opts :instrument])))
95 | ([{:keys [env] :as ast} {:keys [agreement] :as opts}]
96 | (assert (or (contains? #{true false nil} agreement) (usym? agreement))
97 | "Invalid `:agreement` value")
98 | (assert (or (not (usym? agreement)) (some #{agreement} (:roles env)))
99 | (str "Role " agreement " is not part of the choreography"))
100 | (if opts (-instrument ast opts) ast)))
101 |
102 | (defn verify-agreement [env agreement {:keys [rtype] :as ast}]
103 | (let [{:keys [ctor roles]} rtype
104 | form (emit-form ast #{})]
105 | (assert (= ctor :agree) "Expected an agreement type")
106 | (analyze* (if (true? agreement)
107 | `(verify-agreement-decentralized [~@roles] ~form)
108 | `(verify-agreement-centralized
109 | [~agreement ~@(remove #{agreement} roles)] ~form))
110 | :env env :run-passes identity)))
111 |
112 | (defmethod -instrument :chor
113 | [{:keys [top-level params body] :as ast} {:keys [agreement] :as opts}]
114 | (if (and top-level agreement)
115 | (let [params' (filter #(let [{:keys [ctor roles]} (:rtype %)]
116 | (and (= ctor :agree) (>= (count roles) 2)))
117 | params)
118 | ;; NOTE: Use `doall` to force `verify-agreement` to run within the
119 | ;; context of the currently bound analyzer environment, since it
120 | ;; invokes the analyzer to produce an AST.
121 | exprs (doall (map #(verify-agreement (:env body) agreement %)
122 | params'))]
123 | (assert (= (:op body) :do) "Expected a do node")
124 | (assoc ast :body (update body :statements #(vec (concat exprs %)))))
125 | ast))
126 |
127 | (defmethod -instrument :agree
128 | [{:keys [env] :as ast} {:keys [agreement] :as opts}]
129 | (if agreement (verify-agreement env agreement ast) ast))
130 |
131 | (defmethod -instrument :inst
132 | [{inst-roles :roles :keys [env name var] :as ast}
133 | {:keys [instantiation] :as opts}]
134 | (if instantiation
135 | (let [{:keys [roles signature]} (:klor/chor (meta var))]
136 | (analyze* `(verify-inst ~name ~inst-roles ~roles ~signature)
137 | :env env :run-passes identity))
138 | ast))
139 |
140 | (defmethod -instrument :default [ast opts]
141 | ast)
142 |
143 | ;;; Type Check Again
144 |
145 | (def typecheck-again*
146 | ;; NOTE: Schedule a completely new instance of type checking.
147 | (schedule #{#'typecheck}))
148 |
149 | (defn typecheck-again
150 | {:pass-info {:walk :none :after #{#'instrument}}}
151 | [ast]
152 | (if (get-in (env/deref-env) [:passes-opts :instrument])
153 | (typecheck-again* ast)
154 | ast))
155 |
--------------------------------------------------------------------------------
/src/klor/opts.clj:
--------------------------------------------------------------------------------
1 | (ns klor.opts
2 | (:require
3 | [clojure.tools.analyzer.jvm :refer [empty-env macroexpand-all]]))
4 |
5 | (def ^:dynamic *opts*
6 | {:debug {:expansion false}
7 | :instrument {:agreement false :instantiation false}})
8 |
9 | (defmacro with-opts [map & body]
10 | (binding [*opts* (eval map)]
11 | ;; NOTE: We use `clojure.tools.analyzer.jvm`'s `macroexpand-all` because
12 | ;; `clojure.walk`'s is very primitive and walks the form blindly without
13 | ;; actually understanding which parts are code, which are literals, etc.
14 | (macroexpand-all `(do ~@body) (empty-env) {:passes-opts {}})))
15 |
16 | (defn alter-opts! [f & args]
17 | (apply alter-var-root #'*opts* f args))
18 |
--------------------------------------------------------------------------------
/src/klor/projection.clj:
--------------------------------------------------------------------------------
1 | (ns klor.projection
2 | (:refer-clojure :exclude [send])
3 | (:require
4 | [clojure.tools.analyzer.env :as env]
5 | [clojure.tools.analyzer.ast :refer [children]]
6 | [clojure.tools.analyzer.passes.jvm.emit-form :as jvm-emit]
7 | [klor.runtime :refer [noop send recv make-proj]]
8 | [klor.types :refer [type-roles]]
9 | [klor.typecheck :refer [typecheck sanity-check]]
10 | [klor.util :refer [usym? ast-error]]))
11 |
12 | ;;; Util
13 |
14 | (defn projection-error [msg ast & {:as kvs}]
15 | (ast-error :klor/projection msg ast kvs))
16 |
17 | ;;; Role Checks
18 |
19 | (defn mentions? [{:keys [role] :as ctx} {:keys [rmentions] :as ast}]
20 | (contains? rmentions role))
21 |
22 | (defn has-result-for-type? [{:keys [role] :as ctx} type]
23 | (contains? (type-roles type) role))
24 |
25 | (defn has-result-for-node? [ctx {:keys [rtype] :as ast}]
26 | (has-result-for-type? ctx rtype))
27 |
28 | (defn role= [{:keys [role] :as ctx} r]
29 | (= role r))
30 |
31 | ;;; Emission
32 |
33 | (defn emit-tag [expr]
34 | (with-meta expr {:klor/proj true}))
35 |
36 | (defn emit-do [body]
37 | (if (empty? body) `noop (emit-tag `(do ~@body))))
38 |
39 | (defn emit-effects [body]
40 | (emit-do (concat body [`noop])))
41 |
42 | (defn emit-let [bindings body]
43 | (emit-tag `(let [~@(apply concat bindings)] ~(emit-do body))))
44 |
45 | ;;; Projection
46 |
47 | (defmulti -project (fn [ctx {:keys [op] :as ast}] op))
48 |
49 | (defn -project* [ctx {:keys [form] :as ast}]
50 | ;; NOTE: Similarly to `clojure.tools.analyzer.passes.emit-form/-emit-form*`,
51 | ;; we reattach any source metadata to the projected forms.
52 | (let [proj (if (mentions? ctx ast) (-project ctx ast) `noop)
53 | form-meta (meta form)
54 | proj-meta (meta proj)]
55 | (if (and (instance? clojure.lang.IObj proj) (or form-meta proj-meta))
56 | (with-meta proj (merge form-meta proj-meta))
57 | proj)))
58 |
59 | (defn project
60 | {:pass-info {:walk :none
61 | :depends #{#'typecheck}
62 | :after #{#'sanity-check}
63 | :compiler true}}
64 | ([ast]
65 | (project ast (:project (:passes-opts (env/deref-env)))))
66 | ([ast & {:keys [role] :as ctx}]
67 | (assert (usym? role) "Role must be an unqualified symbol")
68 | (assert (:rtype ast) "AST is missing type information")
69 | (-project* ctx ast)))
70 |
71 | ;;; Utilities
72 |
73 | (defn project-with-names
74 | ([ctx exprs]
75 | (project-with-names ctx (repeatedly gensym) exprs))
76 | ([ctx names exprs]
77 | (keep (fn [[name expr]]
78 | (cond
79 | (not (mentions? ctx expr)) nil
80 | (has-result-for-node? ctx expr) [name (-project* ctx expr)]
81 | :else ['_ (-project* ctx expr)]))
82 | (map vector names exprs))))
83 |
84 | (defn project-vals [ctx exprs emit-fn]
85 | (let [projs (project-with-names ctx exprs)
86 | effects? (some #{'_} (map first projs))
87 | bindings (remove (comp #{'_} first) projs)]
88 | (cond
89 | (not effects?) (emit-fn (map second projs))
90 | (empty? bindings) (emit-effects (concat (map second projs)))
91 | :else (emit-let projs [(emit-fn (map first bindings))]))))
92 |
93 | ;;; Choreographic
94 |
95 | (defmethod -project :narrow [ctx {:keys [expr] :as ast}]
96 | ;; NOTE: If we have a result for the `narrow`, then we also have a result for
97 | ;; `expr`. The converse is not true: we might not have a result for `narrow`,
98 | ;; *even* if we have a result for `expr`, because the point of `narrow` is to
99 | ;; restrict the location of `expr`'s result.
100 | (if (has-result-for-node? ctx ast)
101 | (-project* ctx expr)
102 | (emit-effects [(-project* ctx expr)])))
103 |
104 | (defmethod -project :lifting [ctx {:keys [body] :as ast}]
105 | (-project* ctx body))
106 |
107 | (defmethod -project :agree [ctx {:keys [exprs] :as ast}]
108 | ;; NOTE: There is at most one expression in `exprs` for which we have a
109 | ;; result, and its result is also the result of the `agree!`.
110 | (project-vals ctx exprs first))
111 |
112 | (defmethod -project :copy [ctx {:keys [src dst expr env] :as ast}]
113 | (cond
114 | (role= ctx src) (let [idx (.indexOf (:roles env) dst)]
115 | `(send ~idx ~(-project* ctx expr)))
116 | (role= ctx dst) (let [idx (.indexOf (:roles env) src)]
117 | (emit-do [(-project* ctx expr) `(recv ~idx)]))
118 | :else (-project* ctx expr)))
119 |
120 | (defmethod -project :pack [ctx {:keys [exprs] :as ast}]
121 | (project-vals ctx exprs vec))
122 |
123 | (defn project-unpack-binder [ctx binder {:keys [rtype] :as init}]
124 | ((fn rec [[binder {:keys [elems] :as type}]]
125 | (cond
126 | (not (has-result-for-type? ctx type)) nil
127 | (symbol? binder) binder
128 | :else (vec (keep rec (map vector binder elems)))))
129 | [binder rtype]))
130 |
131 | (defmethod -project :unpack [ctx {:keys [binder init body] :as ast}]
132 | (if-let [binder' (project-unpack-binder ctx binder init)]
133 | (emit-let [[binder' (-project* ctx init)]] [(-project* ctx body)])
134 | (emit-let [] [(-project* ctx init) (-project* ctx body)])))
135 |
136 | (defmethod -project :chor [ctx {:keys [top-level local params body] :as ast}]
137 | (let [params' (filter (partial has-result-for-node? ctx) params)
138 | f `(fn ~@(when local [(:form local)]) [~@(map :form params')]
139 | ~(-project* ctx body))]
140 | (if top-level f `(make-proj ~f))))
141 |
142 | (defmethod -project :inst
143 | [{:keys [role] :as ctx} {:keys [name roles env] :as ast}]
144 | (let [idx (.indexOf roles role)
145 | idxs (mapv #(.indexOf (:roles env) %) roles)]
146 | `(make-proj ~name ~idx ~idxs)))
147 |
148 | ;;; Binding & Control Flow
149 |
150 | (defmethod -project :let [ctx {:keys [bindings body] :as ast}]
151 | (emit-let (project-with-names ctx (map :form bindings) (map :init bindings))
152 | [(-project* ctx body)]))
153 |
154 | (defmethod -project :do [ctx {:keys [statements ret body?] :as ast}]
155 | (let [exprs (map (partial -project* ctx) (concat statements [ret]))]
156 | (if body? (emit-do exprs) `(do ~@exprs))))
157 |
158 | (defmethod -project :if [ctx {:keys [test then else] :as ast}]
159 | (if (and (has-result-for-node? ctx test)
160 | (some (partial mentions? ctx) [then else]))
161 | `(if ~@(map (partial -project* ctx) [test then else]))
162 | (emit-effects [(-project* ctx test)])))
163 |
164 | (defmethod -project :case
165 | [ctx {:keys [test default tests thens shift mask
166 | switch-type test-type skip-check?]
167 | :as ast}]
168 | (if (and (has-result-for-node? ctx test)
169 | (some (partial mentions? ctx) (concat thens [default])))
170 | ;; Taken and adjusted from `clojure.tools.analyzer.passes.jvm.emit-form`.
171 | `(case* ~(-project* ctx test)
172 | ~shift ~mask
173 | ~(-project* ctx default)
174 | ~(apply sorted-map
175 | (mapcat (fn [{:keys [hash test]} {:keys [then]}]
176 | [hash (mapv (partial -project* ctx) [test then])])
177 | tests thens))
178 | ~switch-type ~test-type ~skip-check?)
179 | (emit-effects [(-project* ctx test)])))
180 |
181 | (defmethod -project :try [ctx ast]
182 | (jvm-emit/emit-form ast))
183 |
184 | (defmethod -project :catch [ctx ast]
185 | (jvm-emit/emit-form ast))
186 |
187 | (defmethod -project :throw [ctx {:keys [exception] :as ast}]
188 | (project-vals ctx [exception] (fn [projs] `(throw ~@projs))))
189 |
190 | ;;; Functions & Invocation
191 |
192 | (defmethod -project :fn [ctx ast]
193 | ;; NOTE: We let `emit-form` recursively emit the whole `fn`, i.e. all of its
194 | ;; methods, including their parameters and bodies, because `fn` is type
195 | ;; checked as homogeneous code that has to be the same at all mentioned roles!
196 | (jvm-emit/emit-form ast))
197 |
198 | (defmethod -project :invoke [ctx {fn' :fn :keys [args] :as ast}]
199 | (project-vals ctx (cons fn' args) list*))
200 |
201 | (defmethod -project :recur [ctx {:keys [exprs] :as ast}]
202 | (project-vals ctx exprs (fn [projs] `(recur ~@projs))))
203 |
204 | ;;; References
205 |
206 | (defmethod -project :local [ctx ast]
207 | (jvm-emit/emit-form ast))
208 |
209 | (defmethod -project :var [ctx ast]
210 | (jvm-emit/emit-form ast))
211 |
212 | (defmethod -project :the-var [ctx ast]
213 | (jvm-emit/emit-form ast))
214 |
215 | ;;; Collections
216 |
217 | (defmethod -project :vector [ctx {:keys [items] :as ast}]
218 | (project-vals ctx items vec))
219 |
220 | (defn ensure-distinct [projs]
221 | (if (not (apply distinct? projs))
222 | (map (fn [proj] `((fn ~(gensym) [] ~proj))) projs)
223 | projs))
224 |
225 | (defmethod -project :map [ctx {:keys [keys vals] :as ast}]
226 | (project-vals ctx (concat keys vals)
227 | (fn [projs]
228 | (let [[keys vals] (split-at (count keys) projs)]
229 | (zipmap (ensure-distinct keys) vals)))))
230 |
231 | (defmethod -project :set [ctx {:keys [items] :as ast}]
232 | (project-vals ctx items (comp set ensure-distinct)))
233 |
234 | ;;; Constants
235 |
236 | (defmethod -project :const [ctx ast]
237 | (jvm-emit/emit-form ast))
238 |
239 | (defmethod -project :quote [ctx ast]
240 | (jvm-emit/emit-form ast))
241 |
242 | (defmethod -project :with-meta [ctx {:keys [expr meta] :as ast}]
243 | ;; NOTE: The expression is evaluated before its metadata.
244 | (project-vals ctx [expr meta] #(apply with-meta %1)))
245 |
246 | ;;; Host Interop
247 |
248 | (defmethod -project :new [ctx {:keys [class args] :as ast}]
249 | (project-vals ctx (cons class args) (fn [projs] `(new ~@projs))))
250 |
251 | (defmethod -project :host-interop [ctx {:keys [target m-or-f] :as ast}]
252 | (project-vals ctx [target] (fn [projs] `(. ~@projs ~m-or-f))))
253 |
254 | (defmethod -project :instance-field [ctx {:keys [instance field] :as ast}]
255 | (project-vals ctx [instance]
256 | (fn [projs] `(~(symbol (str ".-" (name field))) ~@projs))))
257 |
258 | (defmethod -project :instance-call [ctx {:keys [instance method args] :as ast}]
259 | (project-vals ctx (cons instance args)
260 | (fn [projs] `(~(symbol (str "." (name method))) ~@projs))))
261 |
262 | (defmethod -project :static-field [ctx ast]
263 | (jvm-emit/emit-form ast))
264 |
265 | (defmethod -project :static-call [ctx {:keys [class method args] :as ast}]
266 | (project-vals ctx args (fn [projs]
267 | `(~(symbol (.getName ^Class class) (name method))
268 | ~@projs))))
269 |
270 | (defmethod -project :default [ctx {:keys [op] :as ast}]
271 | (projection-error ["Don't know how to project " op ", yet!"] ast))
272 |
273 | ;;; Cleanup
274 |
275 | (defmulti -cleanup (fn [opts {:keys [op] :as ast}] op))
276 |
277 | (defn cleanup
278 | {:pass-info {:walk :post}}
279 | ([ast]
280 | (-cleanup (:cleanup (:passes-opts (env/deref-env))) ast))
281 | ([ast & {:as opts}]
282 | (-cleanup opts ast)))
283 |
284 | (defn cleanup? [{:keys [style] :as opts} {:keys [form] :as ast}]
285 | (case style
286 | :aggressive true
287 | :normal (:klor/proj (meta form))
288 | false))
289 |
290 | (defn inline-immediate-dos [opts ast]
291 | (letfn [(inline [{:keys [op] :as ast}]
292 | (if (and (= op :do) (cleanup? opts ast))
293 | (children ast)
294 | [ast]))]
295 | (let [exprs (mapcat inline (children ast))]
296 | (assoc ast :statements (vec (butlast exprs)) :ret (last exprs)))))
297 |
298 | (defn pure? [{:keys [style] :as opts} {:keys [op] :as ast}]
299 | (or (and (= style :aggressive)
300 | (contains? #{:const :fn :local :var :the-var :quote} op))
301 | (and (contains? #{:aggressive :normal} style)
302 | (case op
303 | :do (every? (partial pure? opts) (children ast))
304 | :var (= (:var ast) #'noop)
305 | false))))
306 |
307 | (defmethod -cleanup :let [opts {:keys [bindings body] :as ast}]
308 | (if (and (cleanup? opts ast) (empty? bindings)) body ast))
309 |
310 | (defmethod -cleanup :do [opts ast]
311 | (let [{:keys [statements ret] :as ast'} (inline-immediate-dos opts ast)
312 | statements' (remove (partial pure? opts) statements)]
313 | (if (and (empty? statements') (cleanup? opts ast))
314 | ret
315 | (assoc ast' :statements (vec statements')))))
316 |
317 | (defmethod -cleanup :default [opts ast]
318 | ast)
319 |
--------------------------------------------------------------------------------
/src/klor/runtime.clj:
--------------------------------------------------------------------------------
1 | (ns klor.runtime
2 | (:refer-clojure :exclude [send])
3 | (:require
4 | [klor.types :refer [type-roles render-type]]
5 | [klor.util :refer [error]]))
6 |
7 | (def ^:dynamic *config*
8 | {})
9 |
10 | (defn noop [& _]
11 | noop)
12 |
13 | (defn send [dst-idx val]
14 | (if-let [f (:send *config*)]
15 | (f (get-in *config* [:locators dst-idx]) val)
16 | (error :klor ["Send function unspecified: " (str *config*)]))
17 | ;; NOTE: `send` always returns the value sent.
18 | val)
19 |
20 | (defn recv [src-idx]
21 | (if-let [f (:recv *config*)]
22 | (f (get-in *config* [:locators src-idx]))
23 | (error :klor ["Receive function unspecified: " (str *config*)])))
24 |
25 | (defn config-fn [config f]
26 | ;; NOTE: Capture `config` and install it as the value of `*config*` once the
27 | ;; function is called. This is necessary because a choreography might be
28 | ;; passed outside of the context in which it was created.
29 | (fn [& args]
30 | (binding [*config* config]
31 | (apply f args))))
32 |
33 | (defn make-proj
34 | ([f]
35 | (config-fn *config* f))
36 | ([chor role-idx locator-idxs]
37 | (let [locators (:locators *config*)]
38 | (config-fn (merge *config*
39 | {:locators (mapv #(get locators %) locator-idxs)})
40 | (get chor role-idx)))))
41 |
42 | (defn play-role [{:keys [role locators] :as config} chor & args]
43 | (let [{:keys [roles signature]} (:klor/chor (meta chor))
44 | role-idx (.indexOf roles role)
45 | locators (update-keys
46 | locators
47 | #(let [idx (.indexOf roles %)]
48 | (if (= idx -1)
49 | (error :klor ["Role " role " is not part of "
50 | "the choreography"])
51 | idx)))
52 | {:keys [params]} signature]
53 | (when (= role-idx -1)
54 | (error :klor ["Role " role " is not part of the choreography"]))
55 | (when (some #(not= (:ctor %) :agree) params)
56 | (error :klor ["Cannot invoke the projection of a choreography that has "
57 | "parameters of non-agreement type: "
58 | (render-type signature)]))
59 | (let [params' (keep #(when (contains? (type-roles %) role) %) params)
60 | c1 (count args)
61 | c2 (count params')]
62 | (when-not (= c1 c2)
63 | (error :klor ["Wrong number of arguments to the projection for " role
64 | ": got " c1 ", expected " c2])))
65 | (binding [*config* (assoc config :locators locators)]
66 | (apply (get chor role-idx) args))))
67 |
--------------------------------------------------------------------------------
/src/klor/simulator.clj:
--------------------------------------------------------------------------------
1 | (ns klor.simulator
2 | (:require
3 | [clojure.core.async :as a]
4 | [klor.runtime :refer [play-role]]
5 | [klor.types :refer [type-roles render-type]]
6 | [klor.util :refer [error do1]])
7 | (:import java.io.CharArrayWriter))
8 |
9 | ;;; Logging
10 |
11 | (def ^:dynamic *log*
12 | true)
13 |
14 | (defn log* [& args]
15 | (when *log*
16 | (binding [*out* *log*]
17 | ;; NOTE: Lock `*out*` to prevent interleaved printing of the individual
18 | ;; arguments of multiple `print` calls. `Writer` objects are thread-safe,
19 | ;; but Clojure's `print` & co. write out each argument separately.
20 | (locking *out*
21 | (apply print args)))))
22 |
23 | (defn log [& args]
24 | (apply log* (concat args ["\n"])))
25 |
26 | (defn redirect [role]
27 | (proxy [CharArrayWriter] []
28 | (flush []
29 | (log* (str role ":") (.toString ^CharArrayWriter this))
30 | (.reset ^CharArrayWriter this))))
31 |
32 | ;;; `core.async` Transport
33 |
34 | (defn ensure-channel [channels src dst]
35 | (if (get channels [src dst])
36 | channels
37 | (conj channels [[src dst] (a/chan)])))
38 |
39 | (defn get-channel [channels src dst]
40 | (let [channels (swap! channels ensure-channel src dst)]
41 | (get channels [src dst])))
42 |
43 | (defn channel-send [channels src]
44 | (fn [dst value]
45 | ;; NOTE: Wrap `value` in a vector so that we can communicate nils.
46 | (a/>!! (get-channel channels src dst) [value])
47 | value))
48 |
49 | (defn channel-recv [channels dst]
50 | (fn [src]
51 | (let [[value] (a/" (str dst ": " (pr-str value)))
53 | value)))
54 |
55 | (defn wrap-channels [{:keys [role] :as config} roles channels]
56 | (merge config {:send (channel-send channels role)
57 | :recv (channel-recv channels role)
58 | :locators (zipmap roles roles)}))
59 |
60 | ;;; Simulator
61 |
62 | (defn project-args [role args params]
63 | (keep (fn [[a p]] (when (contains? (type-roles p) role) a))
64 | (map vector args params)))
65 |
66 | (defn spawn-role [{:keys [role] :as config} chor args]
67 | (let [log-writer (if (true? *log*) *out* *log*)
68 | redirect-writer (if *log* (redirect role) *out*)]
69 | (future
70 | (binding [*log* log-writer]
71 | (log role "spawned")
72 | (try
73 | (do1 (binding [*out* redirect-writer]
74 | (apply play-role config chor args))
75 | (log role "exited normally"))
76 | (catch Throwable t
77 | (log role "exited abruptly:" (.getMessage t))
78 | t))))))
79 |
80 | (defn simulate-chor [chor & args]
81 | (let [channels (atom {})
82 | {:keys [roles signature]} (:klor/chor (meta chor))
83 | {:keys [params]} signature]
84 | (when (some #(not= (:ctor %) :agree) params)
85 | (error :klor ["Cannot invoke a choreography that has parameters of "
86 | "non-agreement type: " (render-type signature)]))
87 | (let [c1 (count args)
88 | c2 (count params)]
89 | (when-not (= c1 c2)
90 | (error :klor ["Wrong number of arguments to the choreography: got " c1
91 | ", expected " c2])))
92 | (let [ps (->> roles
93 | (map #(spawn-role (wrap-channels {:role %} roles channels)
94 | chor (project-args % args params)))
95 | ;; NOTE: Ensure all roles have been spawned before waiting.
96 | doall)]
97 | (delay (zipmap roles (map deref ps))))))
98 |
--------------------------------------------------------------------------------
/src/klor/sockets.clj:
--------------------------------------------------------------------------------
1 | (ns klor.sockets
2 | (:require
3 | [klor.runtime :refer [play-role]]
4 | [taoensso.nippy :as nippy])
5 | (:import
6 | java.nio.ByteBuffer
7 | java.net.InetSocketAddress
8 | java.net.StandardSocketOptions
9 | java.nio.channels.ReadableByteChannel
10 | java.nio.channels.SocketChannel
11 | java.nio.channels.WritableByteChannel
12 | java.nio.channels.ServerSocketChannel))
13 |
14 | (set! *warn-on-reflection* true)
15 |
16 | (def ^:dynamic *log*
17 | false)
18 |
19 | (defn read-bc! ^ByteBuffer [^ReadableByteChannel bc ^ByteBuffer bb]
20 | (while (not (zero? (.remaining bb)))
21 | (.read bc bb))
22 | bb)
23 |
24 | (defn write-bc! ^ByteBuffer [^WritableByteChannel bc ^ByteBuffer bb]
25 | (while (not (zero? (.remaining bb)))
26 | (.write bc bb))
27 | bb)
28 |
29 | (defn socket-send [^SocketChannel sc value]
30 | (let [bs (nippy/freeze value)]
31 | (write-bc! sc (doto (ByteBuffer/allocate Long/BYTES)
32 | (.putLong (count bs))
33 | (.flip)))
34 | (write-bc! sc (ByteBuffer/wrap bs)))
35 | (when *log* (println (str (.getRemoteAddress sc)) "<--" (pr-str value))))
36 |
37 | (defn socket-recv [^SocketChannel sc]
38 | (let [bb1 (ByteBuffer/allocate Long/BYTES)
39 | n (.getLong (.flip (read-bc! sc bb1)))
40 | bb2 (ByteBuffer/allocate n)
41 | bs (.array (read-bc! sc bb2))
42 | value (nippy/thaw bs)]
43 | (when *log* (println (str (.getRemoteAddress sc)) "-->" (pr-str value)))
44 | value))
45 |
46 | (defn wrap-sockets [config sockets & {:keys [log] :or {log :dynamic}}]
47 | (letfn [(wrap-log [f]
48 | (if (= log :dynamic)
49 | f
50 | (fn [& args]
51 | (binding [*log* log]
52 | (apply f args)))))]
53 | (merge {:locators sockets
54 | :send (wrap-log socket-send)
55 | :recv (wrap-log socket-recv)}
56 | config)))
57 |
58 | (defn with-server-socket [& {:keys [host port] :or {host "0.0.0.0"}}]
59 | (doto (ServerSocketChannel/open)
60 | (.configureBlocking true)
61 | (.setOption StandardSocketOptions/SO_REUSEADDR true)
62 | (.bind (InetSocketAddress. (str host) (long port)))))
63 |
64 | (defn with-server* [expr [sym opts]]
65 | `(let [~sym (with-server-socket ~opts)]
66 | (try ~expr (finally (.close ~sym)))))
67 |
68 | (defmacro with-server [specs & body]
69 | (reduce with-server* `(do ~@body) (reverse (partition-all 2 specs))))
70 |
71 | (defn with-accept* [expr [ssc syms]]
72 | (let [ssc# (gensym)
73 | syms (if (symbol? syms) [syms] syms)]
74 | `(let [~ssc# ~ssc
75 | ~@(mapcat identity (for [sym syms] [sym `(.accept ~ssc#)]))]
76 | (try ~expr (finally ~@(for [sym syms] `(.close ~sym)))))))
77 |
78 | (defmacro with-accept [specs & body]
79 | (reduce with-accept* `(do ~@body) (reverse (partition-all 2 specs))))
80 |
81 | (defn with-client-socket [& {:keys [host port] :or {host "127.0.0.1"}}]
82 | (doto (SocketChannel/open
83 | (InetSocketAddress. (str host) (long port)))
84 | (.configureBlocking true)))
85 |
86 | (defn with-client* [expr [sym opts]]
87 | `(let [~sym (with-client-socket ~opts)]
88 | (try ~expr (finally (.close ~sym)))))
89 |
90 | (defmacro with-client [specs & body]
91 | (reduce with-client* `(do ~@body) (reverse (partition-all 2 specs))))
92 |
--------------------------------------------------------------------------------
/src/klor/specials.clj:
--------------------------------------------------------------------------------
1 | (ns klor.specials
2 | (:require
3 | [klor.util :refer [warn]]))
4 |
5 | (defmacro lifting [[role+] & body]
6 | {:style/indent 1}
7 | (warn "`lifting` used outside of a choreographic context")
8 | &form)
9 |
10 | (defmacro copy [[src dst] expr]
11 | (warn "`copy` used outside of a choreographic context")
12 | &form)
13 |
14 | (defmacro narrow [[role+] expr]
15 | (warn "`narrow` used outside of a choreographic context")
16 | &form)
17 |
18 | (defmacro chor*
19 | {:style/indent :defn
20 | :arglists '([signature [params*] & body] [name signature [params*] & body])}
21 | [& _]
22 | (warn "`chor*` used outside of a choreographic context")
23 | &form)
24 |
25 | (defmacro inst [name [role+]]
26 | (warn "`inst` used outside of a choreographic context")
27 | &form)
28 |
29 | (defmacro pack [expr+]
30 | (warn "`pack` used outside of a choreographic context")
31 | &form)
32 |
33 | (defmacro unpack*
34 | {:style/indent 2}
35 | [[binder+] init & body]
36 | (warn "`unpack*` used outside of a choreographic context")
37 | &form)
38 |
39 | (defmacro agree! [[role+] expr+]
40 | (warn "`agree!` used outside of a choreographic context")
41 | &form)
42 |
--------------------------------------------------------------------------------
/src/klor/stdlib.clj:
--------------------------------------------------------------------------------
1 | (ns klor.stdlib
2 | (:require
3 | [klor.specials :refer [narrow copy pack unpack* chor*]]
4 | [klor.util :refer [usym? unpack-binder? make-copy make-move error]]))
5 |
6 | (defmacro move [roles expr]
7 | (when-not (and (vector? roles) (= (count roles) 2))
8 | (error :klor ["`move` needs a vector of exactly 2 roles: " roles]))
9 | (let [[src dst] roles]
10 | `(narrow [~dst] (copy [~src ~dst] ~expr))))
11 |
12 | (defmacro unpack
13 | {:style/indent 1
14 | :arglists '([[(binder init) *] & body])}
15 | [bindings & body]
16 | (when-not (and (vector? bindings) (even? (count bindings)))
17 | (error :klor ["`unpack` needs a vector with an even number of bindings: "
18 | bindings]))
19 | (if (empty? bindings)
20 | `(do ~@body)
21 | (first (reduce (fn [body [binder init]]
22 | `((unpack* ~binder ~init ~@body)))
23 | body (reverse (partition 2 bindings))))))
24 |
25 | (defn process-chor-param [param]
26 | (cond
27 | (usym? param) [nil param]
28 | (unpack-binder? param) [param (gensym "p")]
29 | :else (error :klor ["Invalid `chor` param: " param])))
30 |
31 | (defmacro chor
32 | {:style/indent :defn
33 | :arglists '([tspec [params*] & body] [name tspec [params*] & body])}
34 | [& [name & _ :as args]]
35 | (let [[name tspec params & body] (if (symbol? name) args (cons nil args))]
36 | (when-not (vector? params)
37 | (error :klor ["`chor` needs a vector of parameters: " params]))
38 | (let [params (map process-chor-param params)
39 | unpacks (filter first params)
40 | names (mapv second params)]
41 | `(chor* ~@(when name [name]) ~tspec ~names
42 | ~@(if (empty? unpacks)
43 | body
44 | `((unpack ~(into [] (apply concat unpacks))
45 | ~@body)))))))
46 |
47 | (defmacro bcast [[src & dsts] expr]
48 | (reduce (fn [res dst] `(~(make-copy src dst) ~res)) expr dsts))
49 |
50 | (defmacro scatter [[src & dsts] & exprs]
51 | (let [c1 (count dsts)
52 | c2 (count exprs)]
53 | (when-not (= (count dsts) (count exprs))
54 | (error :klor ["`scatter` needs an equal number of destinations and "
55 | " expressions: " c1 " vs. " c2])))
56 | `(pack ~@(for [[dst expr] (map vector dsts exprs)]
57 | `(~(make-move src dst) ~expr))))
58 |
59 | (defmacro scatter-seq [[src & dsts :as roles] expr]
60 | (let [seq (gensym "seq")
61 | n (count dsts)]
62 | `(~src
63 | (let [val# ~expr]
64 | (when-not (seqable? val#)
65 | (error :klor ["`scatter-seq`'s expression must be a seqable: " val#]))
66 | (let [~seq (seq val#)
67 | n# (count ~seq)]
68 | (when-not (= n# ~n)
69 | (error :klor ["`scatter-seq`'s sequence has the wrong number of "
70 | " elements: expected " ~n ", got " n# ": " ~seq]))
71 | (scatter [~@roles] ~@(for [i (range n)] `(nth ~seq ~i))))))))
72 |
73 | (defmacro gather [[dst & srcs] & exprs]
74 | (let [c1 (count srcs)
75 | c2 (count exprs)]
76 | (when-not (= (count srcs) (count exprs))
77 | (error :klor ["`gather` needs an equal number of sources and "
78 | "expressions: " c1 " vs. " c2])))
79 | `(~dst ~(mapv (fn [src expr] `(~(make-move src dst) ~expr)) srcs exprs)))
80 |
--------------------------------------------------------------------------------
/src/klor/types.clj:
--------------------------------------------------------------------------------
1 | (ns klor.types
2 | (:require
3 | [clojure.set :as set]
4 | [klor.util :refer [usym? error]]))
5 |
6 | ;;; Types
7 | ;;;
8 | ;;; Roles are represented as unqualified symbols. Types are represented as
9 | ;;; Clojure maps.
10 | ;;;
11 | ;;; The only map key common to all types is `:ctor`, which is a keyword
12 | ;;; describing the type constructor that determines the rest of the structure.
13 | ;;; The constructors are:
14 | ;;;
15 | ;;; - `:agree`
16 | ;;;
17 | ;;; An agreement type. Its `:roles` key is a set of roles.
18 | ;;;
19 | ;;; - `:tuple`
20 | ;;;
21 | ;;; A tuple type. Its `:elems` key is a vector of types of the elements.
22 | ;;;
23 | ;;; - `:chor`
24 | ;;;
25 | ;;; A choreography type. Its `:params` key is a vector of types of the input
26 | ;;; parameters. Its `:ret` key is the type of the return value. Its `:aux` key
27 | ;;; is the (possibly empty) set of auxiliary roles, or `:none` if it has been
28 | ;;; omitted.
29 | ;;;
30 | ;;; The representation, in EBNF (parentheses are used for grouping):
31 | ;;;
32 | ;;; R ::=
33 | ;;; T ::= {:ctor :agree :roles #{R*}}
34 | ;;; | {:ctor :tuple :elems [T+]}
35 | ;;; | {:ctor :chor :params [T*] :ret T :aux (:none | #{R*})}
36 | ;;;
37 | ;;; A type's surface syntax is called its "typespec", which is also given in
38 | ;;; terms of Clojure collections. In EBNF (parentheses are used for lists):
39 | ;;;
40 | ;;; R ::=
41 | ;;; T ::= R ; shorthand for a singleton agreement type
42 | ;;; | #{R+} ; an agreement type
43 | ;;; | [T+] ; a tuple type
44 | ;;; | (-> T* T) ; a choreography type with omitted auxiliary roles
45 | ;;; | (-> T* T | 0) ; a choreography type with empty auxiliary roles
46 | ;;; | (-> T* T | R+) ; a choreography type with explicit auxiliary roles
47 |
48 | (defn parse-error [msg tspec]
49 | (error :klor msg :tspec tspec))
50 |
51 | (declare parse-type*)
52 |
53 | (defn parse-type-agreement [tspec]
54 | (when-not (set? tspec)
55 | (parse-error ["An agreement type must be a set: " tspec] tspec))
56 | (when (empty? tspec)
57 | (parse-error ["An agreement type cannot be empty: " tspec] tspec))
58 | (when-not (every? usym? tspec)
59 | (parse-error ["An agreement type can only contain roles: " tspec] tspec))
60 | {:ctor :agree :roles tspec})
61 |
62 | (defn parse-type-tuple [tspec]
63 | (when-not (vector? tspec)
64 | (parse-error ["A tuple type must be a vector: " tspec] tspec))
65 | (when (empty? tspec)
66 | (parse-error ["A tuple type cannot be empty: " tspec] tspec))
67 | {:ctor :tuple :elems (mapv parse-type* tspec)})
68 |
69 | (defn parse-type-chor [tspec]
70 | (when-not (seq? tspec)
71 | (parse-error ["A choreography type must be a seq: " tspec] tspec))
72 | (let [[op & tspecs] tspec]
73 | (when-not (= op '->)
74 | (parse-error ["A choreography type must start with `->`: " tspec] tspec))
75 | (let [pipe (and tspecs (.indexOf tspecs '|))
76 | pipe (and (not= pipe -1) pipe)
77 | pos (or pipe (inc (count tspecs)))
78 | main (take pos tspecs)
79 | aux (drop (inc pos) tspecs)
80 | params (butlast main)
81 | ret (last main)]
82 | (when (nil? ret)
83 | (parse-error ["A choreography type must have an output: " tspec] tspec))
84 | (when pipe
85 | (when (empty? aux)
86 | (parse-error ["A choreography type's auxiliary part cannot be "
87 | "empty: " tspec]
88 | tspec))
89 | (when-not (every? (some-fn usym? #{0}) aux)
90 | (parse-error ["A choreography type's auxiliary part can only contain "
91 | "roles or 0: " tspec]
92 | tspec))
93 | (when (and (some #{0} aux) (not (= (count aux) 1)))
94 | (parse-error ["A choreography type's auxiliary part cannot contain "
95 | "roles when it contains 0: " tspec]
96 | tspec))
97 | (when-not (apply distinct? aux)
98 | (parse-error ["A choreography type's auxiliary roles must be "
99 | "distinct: " tspec] tspec)))
100 | (merge {:ctor :chor
101 | :params (mapv parse-type* params)
102 | :ret (parse-type* ret)
103 | :aux (if pipe (disj (set aux) 0) :none)}))))
104 |
105 | (defn parse-type [tspec]
106 | (cond
107 | (usym? tspec) (parse-type-agreement #{tspec})
108 | (set? tspec) (parse-type-agreement tspec)
109 | (vector? tspec) (parse-type-tuple tspec)
110 | (and (seq? tspec) (= (first tspec) '->)) (parse-type-chor tspec)
111 | :else nil))
112 |
113 | (defn parse-type* [tspec]
114 | (or (parse-type tspec)
115 | (parse-error ["Unrecognized type: " tspec] tspec)))
116 |
117 | (defn postwalk-type [f {:keys [ctor] :as type}]
118 | (case ctor
119 | :agree (f type)
120 | :tuple (f (update type :elems #(mapv (partial postwalk-type f) %)))
121 | :chor (-> (update type :params #(mapv (partial postwalk-type f) %))
122 | (update :ret (partial postwalk-type f))
123 | f)))
124 |
125 | (defn type-roles [type]
126 | (-> (fn [{:keys [ctor] :as type}]
127 | (case ctor
128 | :agree (:roles type)
129 | :tuple (apply set/union (:elems type))
130 | :chor (let [{:keys [params ret aux]} type]
131 | (apply set/union (if (= aux :none) #{} aux) ret params))))
132 | (postwalk-type type)))
133 |
134 | (defn normalize-type [type]
135 | (-> (fn [{:keys [ctor] :as type}]
136 | (case ctor
137 | (:agree :tuple) type
138 | :chor (if (not= (:aux type) :none)
139 | (let [main (type-roles (assoc type :aux #{}))]
140 | (update type :aux #(set/difference % main)))
141 | type)))
142 | (postwalk-type type)))
143 |
144 | (defn render-type [type]
145 | (-> (fn [{:keys [ctor] :as type}]
146 | (case ctor
147 | :agree (let [{:keys [roles]} type]
148 | (if (= (count roles) 1) (first roles) roles))
149 | :tuple (:elems type)
150 | :chor (let [{:keys [params ret aux]} type]
151 | `(~'-> ~@params ~ret
152 | ~@(cond (= aux :none) nil
153 | (empty? aux) `(~'| 0)
154 | :else `(~'| ~@aux))))))
155 | (postwalk-type type)))
156 |
157 | (defn replace-roles [type subs]
158 | (let [sub #(get subs % %)]
159 | (-> (fn [{:keys [ctor] :as type}]
160 | (case ctor
161 | :agree (update type :roles #(set (map sub %)))
162 | :tuple type
163 | :chor (if (not= (:aux type) :none)
164 | (update type :aux #(set (replace subs %)))
165 | type)))
166 | (postwalk-type type))))
167 |
--------------------------------------------------------------------------------
/src/klor/util.clj:
--------------------------------------------------------------------------------
1 | (ns klor.util
2 | (:require
3 | [clojure.tools.analyzer.ast :refer [update-children]]
4 | [clojure.tools.analyzer.utils :refer [-source-info]]))
5 |
6 | ;;; Clojure
7 |
8 | (defn assoc-inv [vec [k & _ :as ks] val init]
9 | (if (empty? ks)
10 | val
11 | (let [c (count vec)
12 | vec (if (< k c) vec (into (or vec []) (repeat (inc (- k c)) init)))
13 | cur (get vec k)]
14 | (assoc vec k (assoc-inv (if (= cur init) [] cur) (next ks) val init)))))
15 |
16 | (defn usym? [x]
17 | (and (symbol? x) (not (namespace x))))
18 |
19 | (defn -str [& xs]
20 | ;; NOTE: Clojure's `str` returns the empty string for nil, while `print-str`
21 | ;; unconditionally adds spaces between arguments.
22 | (apply str (replace {nil "nil"} xs)))
23 |
24 | (defmacro do1 [expr & exprs]
25 | `(let [val# ~expr]
26 | ~@exprs
27 | val#))
28 |
29 | ;;; Klor
30 |
31 | (defn unpack-binder? [x]
32 | (and (vector? x)
33 | (not-empty x)
34 | (every? (some-fn usym? unpack-binder?) x)))
35 |
36 | (defn make-copy [src dst]
37 | (symbol (str src '=> dst)))
38 |
39 | (defn make-move [src dst]
40 | (symbol (str src '-> dst)))
41 |
42 | ;;; AST
43 |
44 | (defn update-children* [ast children f]
45 | (-> ast
46 | (assoc :children children)
47 | (update-children f)
48 | (assoc :children (:children ast))))
49 |
50 | (defn replace-children [ast smap]
51 | (update-children ast #(get smap % %)))
52 |
53 | ;;; Errors
54 |
55 | (defn make-message [message]
56 | (if (string? message) message (apply -str message)))
57 |
58 | (defn error [tag message & {:as options}]
59 | (throw (ex-info (make-message message) (merge {:tag tag} options))))
60 |
61 | (defn warn [message]
62 | (binding [*out* *err*]
63 | (println (str "WARNING: " (make-message message)))))
64 |
65 | (defn form-error [tag msg form env & {:as kvs}]
66 | (error tag [form ": " (make-message msg)]
67 | (merge {:form form} (-source-info form env) kvs)))
68 |
69 | (defn ast-error [tag msg {:keys [raw-forms form env] :as ast} & {:as kvs}]
70 | (form-error tag msg (or (first raw-forms) form) env kvs))
71 |
--------------------------------------------------------------------------------
/src/klor/validate_roles.clj:
--------------------------------------------------------------------------------
1 | (ns klor.validate-roles
2 | (:require
3 | [clojure.set :as set]
4 | [clojure.tools.analyzer.utils :refer [-source-info]]
5 | [klor.types :refer [type-roles]]
6 | [klor.util :refer [usym? ast-error]]))
7 |
8 | (defn validate-error [msg ast & {:as kvs}]
9 | (ast-error :klor/parse msg ast kvs))
10 |
11 | (defn -validate-roles [{:keys [env] :as ast} roles]
12 | (when-not (every? usym? roles)
13 | (validate-error ["Roles must be unqualified symbols: " roles] ast))
14 | (when-not (apply distinct? roles)
15 | (validate-error (str "Duplicate roles: " roles) ast))
16 | (let [diff (set/difference (set roles) (set (:roles env)))]
17 | (when-not (empty? diff)
18 | (validate-error (str "Unknown roles: " diff) ast))))
19 |
20 | (defmulti validate-roles
21 | {:pass-info {:walk :post}}
22 | :op)
23 |
24 | (defmethod validate-roles :narrow [{:keys [roles] :as ast}]
25 | (-validate-roles ast roles)
26 | ast)
27 |
28 | (defmethod validate-roles :lifting [{:keys [roles] :as ast}]
29 | (-validate-roles ast roles)
30 | ast)
31 |
32 | (defmethod validate-roles :copy [{:keys [src dst] :as ast}]
33 | (-validate-roles ast [src dst])
34 | ast)
35 |
36 | (defmethod validate-roles :chor [{:keys [signature] :as ast}]
37 | (-validate-roles ast (type-roles signature))
38 | ast)
39 |
40 | (defmethod validate-roles :inst [{:keys [roles] :as ast}]
41 | (-validate-roles ast roles)
42 | ast)
43 |
44 | (defmethod validate-roles :default [ast]
45 | ast)
46 |
--------------------------------------------------------------------------------
5 | 
25 | 
](https://nlnet.nl)
40 |
41 | [
](https://nlnet.nl/assure)
42 |
--------------------------------------------------------------------------------
/doc/distributed-algorithms.md:
--------------------------------------------------------------------------------
1 | # Distributed Algorithms
2 |
3 | ## Chang--Roberts algorithm
4 |
5 | The Chang--Roberts algorithm is a *leader election algorithm* for *ring networks*.
6 | It assumes that each role has a *unique identifier*.
7 |
8 | It is implemented by the Klor choreography `(chang-roberts [
| 
|
16 | | 4 | 
| 
|
17 | | 5 | 
| 
|
18 | | 6 | 
| 
|
19 | | 7 | 
| 
|
20 |
21 | To make measurements consistent and statistically meaningful, we made use of the [Criterium](https://github.com/hugoduncan/criterium) library to aggregate the data from a series of executions and account for the peculiarities of the JVM's just-in-time compiler and garbage collector.
22 | All of the measurements were made on a Linux x86-64 system with an Intel i5-6500 3.20 GHz CPU and 40 GiB of RAM.
23 |
24 | ## Compile-time Performance
25 |
26 | The compile-time phase of Klor consists of parsing the Klor code into an AST, analyzing the AST (type checking, etc.) and compiling (projecting) it to separate pieces of Clojure code for each role.
27 | Evaluating the performance of this phase gives us an idea of how fast Klor is at processing code, which indirectly affects the compilation of any Clojure project using Klor and the experience of developers using Klor interactively at a Clojure REPL.
28 |
29 | We measured the compile-time performance by timing the expansion of Klor's `defchor` macro, which implements all of the above.
30 | The tables below report the means and the standard deviations of the measurements for the manually chosen and the fully connected layouts, respectively:
31 |
32 | | Algorithm | n = 3 | n = 4 | n = 5 | n = 6 | n = 7 |
33 | |--------------------|------------:|-------------:|------------:|-------------:|-------------:|
34 | | Chang--Roberts | (44 ± 1) ms | (58 ± 3) ms | (72 ± 2) ms | (91 ± 6) ms | (101 ± 3) ms |
35 | | Itai--Rodeh | (50 ± 2) ms | (76 ± 18) ms | (78 ± 5) ms | (93 ± 3) ms | (113 ± 6) ms |
36 | | Tarry's algorithm | (41 ± 2) ms | (58 ± 3) ms | (71 ± 2) ms | (91 ± 3) ms | (105 ± 4) ms |
37 | | Depth-first search | (41 ± 2) ms | (58 ± 3) ms | (70 ± 1) ms | (93 ± 3) ms | (105 ± 4) ms |
38 | | Echo algorithm | (40 ± 2) ms | (56 ± 3) ms | (69 ± 2) ms | (91 ± 3) ms | (101 ± 3) ms |
39 | | Echo w/ extinction | (43 ± 2) ms | (62 ± 3) ms | (77 ± 2) ms | (106 ± 6) ms | (120 ± 6) ms |
40 |
41 | | Algorithm | n = 3 | n = 4 | n = 5 | n = 6 | n = 7 |
42 | |--------------------|------------:|------------:|------------:|-------------:|-------------:|
43 | | Chang--Roberts | (44 ± 2) ms | (58 ± 4) ms | (71 ± 3) ms | (87 ± 3) ms | (104 ± 3) ms |
44 | | Itai--Rodeh | (50 ± 2) ms | (65 ± 3) ms | (77 ± 2) ms | (93 ± 3) ms | (110 ± 6) ms |
45 | | Tarry's algorithm | (42 ± 2) ms | (59 ± 4) ms | (71 ± 2) ms | (93 ± 3) ms | (104 ± 4) ms |
46 | | Depth-first search | (42 ± 2) ms | (58 ± 3) ms | (70 ± 2) ms | (92 ± 3) ms | (104 ± 4) ms |
47 | | Echo algorithm | (40 ± 2) ms | (56 ± 3) ms | (69 ± 2) ms | (90 ± 3) ms | (101 ± 4) ms |
48 | | Echo w/ extinction | (44 ± 2) ms | (62 ± 3) ms | (78 ± 2) ms | (107 ± 6) ms | (119 ± 6) ms |
49 |
50 | The above data shows that it takes Klor only a fraction of a second to analyze and compile various instances of the distributed algorithms.
51 | Compilation also scales well with the number of roles (roughly linearly), though in general this will depend on the particular choreography and the way it is implemented (due to Klor's support for macros which can generate arbitrary amounts of code).
52 |
53 | We find that Klor is already quite fast and perfectly suitable for the REPL-centric style of development that Clojurians (and other Lispers) find indispensable.
54 | This also matches our own personal experience of working with Klor while implementing the mentioned distributed algorithms.
55 | In general, having a tight feedback loop significantly increases developer productivity.
56 |
57 | ## Run-time Performance
58 |
59 | Klor's run-time phase corresponds to the execution of the projected code.
60 | Since Klor freely interoperates with and compiles down to Clojure, it naturally inherits all of its performance characteristics.
61 | However, for run-time performance we are mainly interested in measuring the overhead introduced by Klor compared to plain Clojure.
62 |
63 | For this reason, in addition to the Klor implementations of the algorithms, we also implemented [plain Clojure variants](../src/klor/fokkink_plain.clj) of each algorithm.
64 | We measured the run-time performance by timing the execution of each variant of the algorithm (`K` for Klor vs. `P` for plain Clojure).
65 | In both cases we've used the shared memory `core.async` channels as the underlying transport mechanism, which allows us to avoid highly variable transport latencies as much as possible and measure the overhead.
66 |
67 | The tables below report the means and the standard deviations of the measurements for the manually chosen and the fully connected layouts, respectively:
68 |
69 | | Algorithm | n = 3 | n = 4 | n = 5 | n = 6 | n = 7 |
70 | |------------------------|----------------:|----------------:|----------------:|----------------:|----------------:|
71 | | Chang--Roberts (K) | (867 ± 115) μs | (1076 ± 128) μs | (1319 ± 140) μs | (1556 ± 157) μs | (1766 ± 188) μs |
72 | | Chang--Roberts (P) | (367 ± 11) μs | (471 ± 60) μs | (568 ± 13) μs | (759 ± 114) μs | (785 ± 34) μs |
73 | | Itai--Rodeh (K) | (1058 ± 88) μs | (1267 ± 161) μs | (1751 ± 365) μs | (1832 ± 200) μs | (2137 ± 263) μs |
74 | | Itai--Rodeh (P) | (519 ± 35) μs | (677 ± 25) μs | (803 ± 49) μs | (1056 ± 310) μs | (1093 ± 51) μs |
75 | | Tarry's algorithm (K) | (1053 ± 161) μs | (1580 ± 200) μs | (1886 ± 229) μs | (2772 ± 360) μs | (2666 ± 313) μs |
76 | | Tarry's algorithm (P) | (410 ± 13) μs | (590 ± 42) μs | (755 ± 30) μs | (1106 ± 157) μs | (1050 ± 79) μs |
77 | | Depth-first search (K) | (1061 ± 149) μs | (1610 ± 198) μs | (1865 ± 182) μs | (2744 ± 353) μs | (2706 ± 259) μs |
78 | | Depth-first search (P) | (365 ± 34) μs | (626 ± 17) μs | (737 ± 21) μs | (1049 ± 48) μs | (969 ± 86) μs |
79 | | Echo algorithm (K) | (766 ± 154) μs | (1037 ± 204) μs | (1225 ± 172) μs | (1659 ± 263) μs | (1793 ± 317) μs |
80 | | Echo algorithm (P) | (293 ± 37) μs | (411 ± 40) μs | (472 ± 69) μs | (623 ± 53) μs | (701 ± 72) μs |
81 | | Echo w/ extinction (K) | (1413 ± 303) μs | (1651 ± 270) μs | (1916 ± 290) μs | (2576 ± 396) μs | (3000 ± 413) μs |
82 | | Echo w/ extinction (P) | (540 ± 13) μs | (847 ± 96) μs | (1224 ± 145) μs | (1205 ± 113) μs | (1577 ± 90) μs |
83 |
84 | | Algorithm | n = 3 | n = 4 | n = 5 | n = 6 | n = 7 |
85 | |------------------------|----------------:|----------------:|----------------:|----------------:|----------------:|
86 | | Chang--Roberts (K) | (883 ± 121) μs | (1078 ± 104) μs | (1285 ± 137) μs | (1531 ± 144) μs | (1751 ± 167) μs |
87 | | Chang--Roberts (P) | (379 ± 25) μs | (468 ± 46) μs | (547 ± 29) μs | (682 ± 80) μs | (758 ± 25) μs |
88 | | Itai--Rodeh (K) | (993 ± 129) μs | (1270 ± 146) μs | (1537 ± 142) μs | (1787 ± 206) μs | (2070 ± 169) μs |
89 | | Itai--Rodeh (P) | (451 ± 67) μs | (654 ± 42) μs | (824 ± 30) μs | (951 ± 60) μs | (1077 ± 62) μs |
90 | | Tarry's algorithm (K) | (1065 ± 143) μs | (1590 ± 212) μs | (1903 ± 225) μs | (2760 ± 325) μs | (2688 ± 308) μs |
91 | | Tarry's algorithm (P) | (351 ± 17) μs | (616 ± 43) μs | (729 ± 36) μs | (1020 ± 50) μs | (1068 ± 82) μs |
92 | | Depth-first search (K) | (1064 ± 143) μs | (1584 ± 204) μs | (1899 ± 218) μs | (2786 ± 312) μs | (2712 ± 331) μs |
93 | | Depth-first search (P) | (377 ± 36) μs | (602 ± 52) μs | (668 ± 57) μs | (1136 ± 76) μs | (1036 ± 68) μs |
94 | | Echo algorithm (K) | (781 ± 135) μs | (1057 ± 209) μs | (1813 ± 318) μs | (1669 ± 280) μs | (1763 ± 339) μs |
95 | | Echo algorithm (P) | (328 ± 14) μs | (404 ± 32) μs | (447 ± 43) μs | (617 ± 87) μs | (694 ± 47) μs |
96 | | Echo w/ extinction (K) | (1153 ± 150) μs | (1676 ± 241) μs | (1916 ± 264) μs | (2741 ± 500) μs | (2995 ± 375) μs |
97 | | Echo w/ extinction (P) | (538 ± 20) μs | (778 ± 54) μs | (990 ± 100) μs | (1188 ± 92) μs | (1566 ± 104) μs |
98 |
99 | From the above data we can see that Klor does introduce some overhead compared to the plain Clojure variants of the algorithms, roughly 2-3x depending on the scenario.
100 | In absolute terms however, the overhead is in the order of a few hundred microseconds or a single millisecond in all cases, which is negligible compared to the latencies of transport mechanisms (i.e. IO) normally used by real-world distributed systems, such as those backed by a network rather than shared memory.
101 |
102 | Overall, we think Klor's current performance is satisfactory, especially given the fact that additional optimizations could be implemented in the future.
103 |
--------------------------------------------------------------------------------
/doc/pldi-2024.pdf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/lovrosdu/klor/991c9ad5867ef85c1d09e50b2f0090fb30257603/doc/pldi-2024.pdf
--------------------------------------------------------------------------------
/doc/reference-02-runtime.md:
--------------------------------------------------------------------------------
1 | # Reference: Runtime
2 |
3 | ## Execution Model
4 |
5 | Choreographic programming assumes the **concurrent execution** of all roles in a choreography.
6 | Abstractly, all subexpressions of a choreography are evaluated **out-of-order up to role dependency**.
7 | This means that their evaluation can be arbitrarily interleaved, except that sequentiality is maintained between all expressions located at the same role, including any **communication actions** initiated by the role (sends and receives to/from other roles).
8 | Receives are assumed to be **blocking (synchronous)** while sends can be either blocking or non-blocking.
9 |
10 | ## Projection
11 |
12 | The execution model is implemented by **projecting** a choreography to a separate Clojure function for each role and executing all of them concurrently via some concurrency mechanism -- multiple threads, processes, nodes, any combination thereof, etc.
13 | Each projection retains only the subexpressions relevant to the particular role and incorporates the necessary communication actions to interact with other roles as specified by the choreography.
14 |
15 | A full treatment of the theory of projection with all of its details and properties is out of the scope of this document, but we try to give a working summary here.
16 | For more details the [Introduction to Choreographies](https://doi.org/10.1017/9781108981491) book is a good starting point.
17 |
18 | In general, the projection of a Klor expression for a role depends on the expression's choreographic type and the roles it **mentions**.
19 | An expression is projected differently for a role `r` depending on whether it **has a result** for `r` (involves `r` in its type), **only mentions** `r` (only involves `r` in its subexpressions), or **doesn't mention** `r` at all.
20 | Projection works **recursively** through the subexpressions of a Klor expression and applies these considerations at every step in order to generate code that contains all of the necessary expressions and communication actions described by the choreography.
21 | The rough idea is:
22 |
23 | - If the expression **has a result** for `r`, the projection generates code to yield that result, including any necessary communication actions between the roles. All appropriate subexpressions are projected recursively.
24 | - Otherwise, if the expression **only mentions** `r` (in its subexpressions), it is projected to code that ultimately evaluates to the special `klor.runtime/noop` value representing the absence of a choreographic value, but first carries out all of the necessary computation required by the recursive projection of its subexpressions.
25 | - Otherwise, if the expression **doesn't mention** `r` at all, the projection is just the `klor.runtime/noop` value.
26 |
27 | Special operators are the base cases of the recursive procedure.
28 | A few of the more important ones are described briefly:
29 |
30 | - `copy` projects to corresponding send and receive actions at the source and destination, respectively.
31 | - `chor` projects to Clojure anonymous functions, each representing a projection of the anonymous choreography.
32 | - `do` projects to a Clojure `do` with each expression in its body projected recursively. The `do` is effectively "pulled apart" and its pieces are distributed among the roles. This means that it does **not** maintain sequential execution of its subexpressions across roles but only within each role. We call this **choreographic sequencing**.
33 | - `if` projects to a Clojure `if` for all of the roles that have a result for the guard expression. If a role does not have a result for the guard, it cannot participate in either of the branches.
34 |
35 | ## Invoking Projections
36 |
37 | The `(klor.runtime/play-role