New upstream version 0.3.443
Apollon Oikonomopoulos
6 years ago
0 | *.iml | |
1 | *init.clj | |
2 | .idea | |
3 | out-simp | |
4 | out-simp-node | |
5 | out-adv | |
6 | out-adv-node | |
7 | /target | |
8 | /lib | |
9 | /classes | |
10 | /checkouts | |
11 | *.jar | |
12 | *.class | |
13 | .lein-deps-sum | |
14 | .lein-failures | |
15 | .lein-plugins | |
16 | .lein-repl-history | |
17 | tests.js | |
18 | tests.js.map | |
19 | pom.xml.versionsBackup |
0 | If you'd like to submit a patch, please follow the [contributing guidelines](http://clojure.org/contributing). |
0 | # core.async | |
1 | ||
2 | A Clojure library providing facilities for async programming and communication. | |
3 | ||
4 | ||
5 | ## Releases and Dependency Information | |
6 | ||
7 | Latest release: 0.3.442 | |
8 | ||
9 | * [All Released Versions](http://search.maven.org/#search%7Cgav%7C1%7Cg%3A%22org.clojure%22%20AND%20a%3A%22core.async%22) | |
10 | ||
11 | [Leiningen](https://github.com/technomancy/leiningen) dependency information: | |
12 | ||
13 | ```clj | |
14 | [org.clojure/clojure "1.6.0"] | |
15 | [org.clojure/core.async "0.3.442"] | |
16 | ``` | |
17 | ||
18 | [Maven](http://maven.apache.org/) dependency information: | |
19 | ||
20 | ```xml | |
21 | <dependency> | |
22 | <groupId>org.clojure</groupId> | |
23 | <artifactId>core.async</artifactId> | |
24 | <version>0.3.442</version> | |
25 | </dependency> | |
26 | ``` | |
27 | ||
28 | ## Documentation | |
29 | ||
30 | * [Rationale](http://clojure.com/blog/2013/06/28/clojure-core-async-channels.html) | |
31 | * [API docs](http://clojure.github.io/core.async/) | |
32 | * [Code walkthrough](https://github.com/clojure/core.async/blob/master/examples/walkthrough.clj) | |
33 | ||
34 | ## Presentations | |
35 | ||
36 | * [Rich Hickey on core.async](http://www.infoq.com/presentations/clojure-core-async) | |
37 | * [Tim Baldridge on core.async](http://www.youtube.com/watch?v=enwIIGzhahw) from Clojure/conj 2013 ([code](https://github.com/halgari/clojure-conj-2013-core.async-examples)). | |
38 | * Tim Baldridge on go macro internals - [part 1](https://www.youtube.com/watch?v=R3PZMIwXN_g) [part 2](https://www.youtube.com/watch?v=SI7qtuuahhU) | |
39 | * David Nolen [core.async webinar](http://go.cognitect.com/core_async_webinar_recording) | |
40 | ||
41 | ## Contributing | |
42 | ||
43 | [Contributing to Clojure projects](http://clojure.org/contributing) requires a signed Contributor Agreement. Pull requests and GitHub issues are not accepted; please use the [core.async JIRA project](http://dev.clojure.org/jira/browse/ASYNC) to report problems or enhancements. | |
44 | ||
45 | To run the ClojureScript tests: | |
46 | ||
47 | * lein cljsbuild once | |
48 | * open script/runtests.html | |
49 | * View JavaScript console for test results | |
50 | ||
51 | ## License | |
52 | ||
53 | Copyright © 2017 Rich Hickey and contributors | |
54 | ||
55 | Distributed under the Eclipse Public License, the same as Clojure. | |
56 | ||
57 | ## Changelog | |
58 | ||
59 | * Release 0.3.xxx on 2017.05.26 | |
60 | * | |
61 | * Release 0.3.442 on 2017.03.14 | |
62 | * Fix bad `:refer-clojure` clause that violates new spec in Clojure 1.9.0-alpha15 | |
63 | * Release 0.3.441 on 2017.02.23 | |
64 | * [ASYNC-187](http://dev.clojure.org/jira/browse/ASYNC-187) - Tag metadata is lost in local closed over by a loop | |
65 | * Related: [ASYNC-188](http://dev.clojure.org/jira/browse/ASYNC-188) | |
66 | * [ASYNC-185](http://dev.clojure.org/jira/browse/ASYNC-185) - `thread` prevents clearing of body locals | |
67 | * [ASYNC-186](http://dev.clojure.org/jira/browse/ASYNC-186) - NPE when `go` closes over a local variable bound to nil | |
68 | * Release 0.3.426 on 2017.02.22 | |
69 | * [ASYNC-169](http://dev.clojure.org/jira/browse/ASYNC-169) - handling of catch and finally inside go blocks was broken, causing a number of issues. Related: [ASYNC-100](http://dev.clojure.org/jira/browse/ASYNC-100), [ASYNC-173](http://dev.clojure.org/jira/browse/ASYNC-173), [ASYNC-180](http://dev.clojure.org/jira/browse/ASYNC-180), [ASYNC-179](http://dev.clojure.org/jira/browse/ASYNC-179), [ASYNC-122](http://dev.clojure.org/jira/browse/ASYNC-122), [ASYNC-78](http://dev.clojure.org/jira/browse/ASYNC-78), [ASYNC-168](http://dev.clojure.org/jira/browse/ASYNC-168) | |
70 | * [ASYNC-138](http://dev.clojure.org/jira/browse/ASYNC-138) - go blocks do not allow closed over locals to be cleared which can lead to a memory leak. Related: [ASYNC-32](http://dev.clojure.org/jira/browse/ASYNC-32) | |
71 | * [ASYNC-155](http://dev.clojure.org/jira/browse/ASYNC-155) - preserve loop binding metadata when inside a go block | |
72 | * [ASYNC-54](http://dev.clojure.org/jira/browse/ASYNC-54) - fix bad type hint on MAX-QUEUE-SIZE | |
73 | * [ASYNC-177](http://dev.clojure.org/jira/browse/ASYNC-177) - fix typo in Buffer protocol full? method | |
74 | * [ASYNC-70](http://dev.clojure.org/jira/browse/ASYNC-70) - docstring change in thread, thread-call | |
75 | * [ASYNC-143](http://dev.clojure.org/jira/browse/ASYNC-143) - assert that fixed buffers must have size > 0 | |
76 | * Update tools.analyzer.jvm dependency | |
77 | * Release 0.2.395 on 2016.10.12 | |
78 | * Add async version of transduce | |
79 | * Release 0.2.391 on 2016.09.09 | |
80 | * Fix redefinition warning for bounded-count (added in Clojure 1.9) | |
81 | * Add :deprecated meta to the deprecated functions | |
82 | * Release 0.2.385 on 2016.06.17 | |
83 | * Updated tools.analyzer.jvm version | |
84 | * Release 0.2.382 on 2016.06.13 | |
85 | * Important: Change default dispatch thread pool size to 8. | |
86 | * Add Java system property `clojure.core.async.pool-size` to set the dispatch thread pool size | |
87 | * [ASYNC-152](http://dev.clojure.org/jira/browse/ASYNC-152) - disable t.a.jvm's warn-on-reflection pass | |
88 | * Release 0.2.374 on 2015.11.11 | |
89 | * [ASYNC-149](http://dev.clojure.org/jira/browse/ASYNC-149) - fix error compiling recur inside case in a go block | |
90 | * Updated tools.analyzer.jvm version (and other upstream deps) | |
91 | * Updated to latest clojurescript and cljsbuild versions | |
92 | * Release 0.2.371 on 2015.10.28 | |
93 | * [ASYNC-124](http://dev.clojure.org/jira/browse/ASYNC-124) - dispatch multiple pending takers from expanding transducer | |
94 | * [ASYNC-103](http://dev.clojure.org/jira/browse/ASYNC-103) - NEW promise-chan | |
95 | * [ASYNC-104](http://dev.clojure.org/jira/browse/ASYNC-104) - NEW non-blocking offer!, poll! | |
96 | * [ASYNC-101](http://dev.clojure.org/jira/browse/ASYNC-101) - async/reduce now respects reduced | |
97 | * [ASYNC-112](http://dev.clojure.org/jira/browse/ASYNC-112) - replace "transformer" with "transducer" in deprecation messages | |
98 | * [ASYNC-6](http://dev.clojure.org/jira/browse/ASYNC-6) - alts! docs updated to explicitly state ports is a vector | |
99 | * Support (try (catch :default)) in CLJS exception handling | |
100 | * Use cljs.test | |
101 | * Updated tools.analyzer.jvm version (and other upstream deps) | |
102 | * Release 0.1.346.0-17112a-alpha on 2014.09.22 | |
103 | * cljs nextTick relies on goog.async.nextTick | |
104 | * Updated docstring for put! re result on closed channel | |
105 | * Release 0.1.338.0-5c5012-alpha on 2014.08.19 | |
106 | * Add cljs transducers support | |
107 | * Release 0.1.319.0-6b1aca-alpha on 2014.08.06 | |
108 | * Add transducers support | |
109 | * NEW pipeline | |
110 | * Release 0.1.303.0-886421-alpha on 2014.05.08 | |
111 | * Release 0.1.301.0-deb34a-alpha on 2014.04.29 | |
112 | * Release 0.1.298.0-2a82a1-alpha on 2014.04.25 | |
113 | * Release 0.1.278.0-76b25b-alpha on 2014.02.07 | |
114 | * Release 0.1.267.0-0d7780-alpha on 2013.12.11 | |
115 | * Release 0.1.262.0-151b23-alpha on 2013.12.10 | |
116 | * Release 0.1.256.0-1bf8cf-alpha on 2013.11.07 | |
117 | * Release 0.1.242.0-44b1e3-alpha on 2013.09.27 | |
118 | * Release 0.1.222.0-83d0c2-alpha on 2013.09.12 |
0 | 0.3.GENERATED_VERSION |
0 | <?xml version="1.0" encoding="ISO-8859-1" ?> | |
1 | <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> | |
2 | <html xmlns="http://www.w3.org/1999/xhtml"> | |
3 | ||
4 | <head> | |
5 | <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" /> | |
6 | <title>Eclipse Public License - Version 1.0</title> | |
7 | <style type="text/css"> | |
8 | body { | |
9 | size: 8.5in 11.0in; | |
10 | margin: 0.25in 0.5in 0.25in 0.5in; | |
11 | tab-interval: 0.5in; | |
12 | } | |
13 | p { | |
14 | margin-left: auto; | |
15 | margin-top: 0.5em; | |
16 | margin-bottom: 0.5em; | |
17 | } | |
18 | p.list { | |
19 | margin-left: 0.5in; | |
20 | margin-top: 0.05em; | |
21 | margin-bottom: 0.05em; | |
22 | } | |
23 | </style> | |
24 | ||
25 | </head> | |
26 | ||
27 | <body lang="EN-US"> | |
28 | ||
29 | <h2>Eclipse Public License - v 1.0</h2> | |
30 | ||
31 | <p>THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE | |
32 | PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR | |
33 | DISTRIBUTION OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS | |
34 | AGREEMENT.</p> | |
35 | ||
36 | <p><b>1. DEFINITIONS</b></p> | |
37 | ||
38 | <p>"Contribution" means:</p> | |
39 | ||
40 | <p class="list">a) in the case of the initial Contributor, the initial | |
41 | code and documentation distributed under this Agreement, and</p> | |
42 | <p class="list">b) in the case of each subsequent Contributor:</p> | |
43 | <p class="list">i) changes to the Program, and</p> | |
44 | <p class="list">ii) additions to the Program;</p> | |
45 | <p class="list">where such changes and/or additions to the Program | |
46 | originate from and are distributed by that particular Contributor. A | |
47 | Contribution 'originates' from a Contributor if it was added to the | |
48 | Program by such Contributor itself or anyone acting on such | |
49 | Contributor's behalf. Contributions do not include additions to the | |
50 | Program which: (i) are separate modules of software distributed in | |
51 | conjunction with the Program under their own license agreement, and (ii) | |
52 | are not derivative works of the Program.</p> | |
53 | ||
54 | <p>"Contributor" means any person or entity that distributes | |
55 | the Program.</p> | |
56 | ||
57 | <p>"Licensed Patents" mean patent claims licensable by a | |
58 | Contributor which are necessarily infringed by the use or sale of its | |
59 | Contribution alone or when combined with the Program.</p> | |
60 | ||
61 | <p>"Program" means the Contributions distributed in accordance | |
62 | with this Agreement.</p> | |
63 | ||
64 | <p>"Recipient" means anyone who receives the Program under | |
65 | this Agreement, including all Contributors.</p> | |
66 | ||
67 | <p><b>2. GRANT OF RIGHTS</b></p> | |
68 | ||
69 | <p class="list">a) Subject to the terms of this Agreement, each | |
70 | Contributor hereby grants Recipient a non-exclusive, worldwide, | |
71 | royalty-free copyright license to reproduce, prepare derivative works | |
72 | of, publicly display, publicly perform, distribute and sublicense the | |
73 | Contribution of such Contributor, if any, and such derivative works, in | |
74 | source code and object code form.</p> | |
75 | ||
76 | <p class="list">b) Subject to the terms of this Agreement, each | |
77 | Contributor hereby grants Recipient a non-exclusive, worldwide, | |
78 | royalty-free patent license under Licensed Patents to make, use, sell, | |
79 | offer to sell, import and otherwise transfer the Contribution of such | |
80 | Contributor, if any, in source code and object code form. This patent | |
81 | license shall apply to the combination of the Contribution and the | |
82 | Program if, at the time the Contribution is added by the Contributor, | |
83 | such addition of the Contribution causes such combination to be covered | |
84 | by the Licensed Patents. The patent license shall not apply to any other | |
85 | combinations which include the Contribution. No hardware per se is | |
86 | licensed hereunder.</p> | |
87 | ||
88 | <p class="list">c) Recipient understands that although each Contributor | |
89 | grants the licenses to its Contributions set forth herein, no assurances | |
90 | are provided by any Contributor that the Program does not infringe the | |
91 | patent or other intellectual property rights of any other entity. Each | |
92 | Contributor disclaims any liability to Recipient for claims brought by | |
93 | any other entity based on infringement of intellectual property rights | |
94 | or otherwise. As a condition to exercising the rights and licenses | |
95 | granted hereunder, each Recipient hereby assumes sole responsibility to | |
96 | secure any other intellectual property rights needed, if any. For | |
97 | example, if a third party patent license is required to allow Recipient | |
98 | to distribute the Program, it is Recipient's responsibility to acquire | |
99 | that license before distributing the Program.</p> | |
100 | ||
101 | <p class="list">d) Each Contributor represents that to its knowledge it | |
102 | has sufficient copyright rights in its Contribution, if any, to grant | |
103 | the copyright license set forth in this Agreement.</p> | |
104 | ||
105 | <p><b>3. REQUIREMENTS</b></p> | |
106 | ||
107 | <p>A Contributor may choose to distribute the Program in object code | |
108 | form under its own license agreement, provided that:</p> | |
109 | ||
110 | <p class="list">a) it complies with the terms and conditions of this | |
111 | Agreement; and</p> | |
112 | ||
113 | <p class="list">b) its license agreement:</p> | |
114 | ||
115 | <p class="list">i) effectively disclaims on behalf of all Contributors | |
116 | all warranties and conditions, express and implied, including warranties | |
117 | or conditions of title and non-infringement, and implied warranties or | |
118 | conditions of merchantability and fitness for a particular purpose;</p> | |
119 | ||
120 | <p class="list">ii) effectively excludes on behalf of all Contributors | |
121 | all liability for damages, including direct, indirect, special, | |
122 | incidental and consequential damages, such as lost profits;</p> | |
123 | ||
124 | <p class="list">iii) states that any provisions which differ from this | |
125 | Agreement are offered by that Contributor alone and not by any other | |
126 | party; and</p> | |
127 | ||
128 | <p class="list">iv) states that source code for the Program is available | |
129 | from such Contributor, and informs licensees how to obtain it in a | |
130 | reasonable manner on or through a medium customarily used for software | |
131 | exchange.</p> | |
132 | ||
133 | <p>When the Program is made available in source code form:</p> | |
134 | ||
135 | <p class="list">a) it must be made available under this Agreement; and</p> | |
136 | ||
137 | <p class="list">b) a copy of this Agreement must be included with each | |
138 | copy of the Program.</p> | |
139 | ||
140 | <p>Contributors may not remove or alter any copyright notices contained | |
141 | within the Program.</p> | |
142 | ||
143 | <p>Each Contributor must identify itself as the originator of its | |
144 | Contribution, if any, in a manner that reasonably allows subsequent | |
145 | Recipients to identify the originator of the Contribution.</p> | |
146 | ||
147 | <p><b>4. COMMERCIAL DISTRIBUTION</b></p> | |
148 | ||
149 | <p>Commercial distributors of software may accept certain | |
150 | responsibilities with respect to end users, business partners and the | |
151 | like. While this license is intended to facilitate the commercial use of | |
152 | the Program, the Contributor who includes the Program in a commercial | |
153 | product offering should do so in a manner which does not create | |
154 | potential liability for other Contributors. Therefore, if a Contributor | |
155 | includes the Program in a commercial product offering, such Contributor | |
156 | ("Commercial Contributor") hereby agrees to defend and | |
157 | indemnify every other Contributor ("Indemnified Contributor") | |
158 | against any losses, damages and costs (collectively "Losses") | |
159 | arising from claims, lawsuits and other legal actions brought by a third | |
160 | party against the Indemnified Contributor to the extent caused by the | |
161 | acts or omissions of such Commercial Contributor in connection with its | |
162 | distribution of the Program in a commercial product offering. The | |
163 | obligations in this section do not apply to any claims or Losses | |
164 | relating to any actual or alleged intellectual property infringement. In | |
165 | order to qualify, an Indemnified Contributor must: a) promptly notify | |
166 | the Commercial Contributor in writing of such claim, and b) allow the | |
167 | Commercial Contributor to control, and cooperate with the Commercial | |
168 | Contributor in, the defense and any related settlement negotiations. The | |
169 | Indemnified Contributor may participate in any such claim at its own | |
170 | expense.</p> | |
171 | ||
172 | <p>For example, a Contributor might include the Program in a commercial | |
173 | product offering, Product X. That Contributor is then a Commercial | |
174 | Contributor. If that Commercial Contributor then makes performance | |
175 | claims, or offers warranties related to Product X, those performance | |
176 | claims and warranties are such Commercial Contributor's responsibility | |
177 | alone. Under this section, the Commercial Contributor would have to | |
178 | defend claims against the other Contributors related to those | |
179 | performance claims and warranties, and if a court requires any other | |
180 | Contributor to pay any damages as a result, the Commercial Contributor | |
181 | must pay those damages.</p> | |
182 | ||
183 | <p><b>5. NO WARRANTY</b></p> | |
184 | ||
185 | <p>EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS | |
186 | PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS | |
187 | OF ANY KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, | |
188 | ANY WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY | |
189 | OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely | |
190 | responsible for determining the appropriateness of using and | |
191 | distributing the Program and assumes all risks associated with its | |
192 | exercise of rights under this Agreement , including but not limited to | |
193 | the risks and costs of program errors, compliance with applicable laws, | |
194 | damage to or loss of data, programs or equipment, and unavailability or | |
195 | interruption of operations.</p> | |
196 | ||
197 | <p><b>6. DISCLAIMER OF LIABILITY</b></p> | |
198 | ||
199 | <p>EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT | |
200 | NOR ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, | |
201 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING | |
202 | WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF | |
203 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING | |
204 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR | |
205 | DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED | |
206 | HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.</p> | |
207 | ||
208 | <p><b>7. GENERAL</b></p> | |
209 | ||
210 | <p>If any provision of this Agreement is invalid or unenforceable under | |
211 | applicable law, it shall not affect the validity or enforceability of | |
212 | the remainder of the terms of this Agreement, and without further action | |
213 | by the parties hereto, such provision shall be reformed to the minimum | |
214 | extent necessary to make such provision valid and enforceable.</p> | |
215 | ||
216 | <p>If Recipient institutes patent litigation against any entity | |
217 | (including a cross-claim or counterclaim in a lawsuit) alleging that the | |
218 | Program itself (excluding combinations of the Program with other | |
219 | software or hardware) infringes such Recipient's patent(s), then such | |
220 | Recipient's rights granted under Section 2(b) shall terminate as of the | |
221 | date such litigation is filed.</p> | |
222 | ||
223 | <p>All Recipient's rights under this Agreement shall terminate if it | |
224 | fails to comply with any of the material terms or conditions of this | |
225 | Agreement and does not cure such failure in a reasonable period of time | |
226 | after becoming aware of such noncompliance. If all Recipient's rights | |
227 | under this Agreement terminate, Recipient agrees to cease use and | |
228 | distribution of the Program as soon as reasonably practicable. However, | |
229 | Recipient's obligations under this Agreement and any licenses granted by | |
230 | Recipient relating to the Program shall continue and survive.</p> | |
231 | ||
232 | <p>Everyone is permitted to copy and distribute copies of this | |
233 | Agreement, but in order to avoid inconsistency the Agreement is | |
234 | copyrighted and may only be modified in the following manner. The | |
235 | Agreement Steward reserves the right to publish new versions (including | |
236 | revisions) of this Agreement from time to time. No one other than the | |
237 | Agreement Steward has the right to modify this Agreement. The Eclipse | |
238 | Foundation is the initial Agreement Steward. The Eclipse Foundation may | |
239 | assign the responsibility to serve as the Agreement Steward to a | |
240 | suitable separate entity. Each new version of the Agreement will be | |
241 | given a distinguishing version number. The Program (including | |
242 | Contributions) may always be distributed subject to the version of the | |
243 | Agreement under which it was received. In addition, after a new version | |
244 | of the Agreement is published, Contributor may elect to distribute the | |
245 | Program (including its Contributions) under the new version. Except as | |
246 | expressly stated in Sections 2(a) and 2(b) above, Recipient receives no | |
247 | rights or licenses to the intellectual property of any Contributor under | |
248 | this Agreement, whether expressly, by implication, estoppel or | |
249 | otherwise. All rights in the Program not expressly granted under this | |
250 | Agreement are reserved.</p> | |
251 | ||
252 | <p>This Agreement is governed by the laws of the State of New York and | |
253 | the intellectual property laws of the United States of America. No party | |
254 | to this Agreement will bring a legal action under this Agreement more | |
255 | than one year after the cause of action arose. Each party waives its | |
256 | rights to a jury trial in any resulting litigation.</p> | |
257 | ||
258 | </body> | |
259 | ||
260 | </html> |
0 | (require '[clojure.core.async :as async :refer [<! >! <!! >!! timeout chan alt! alts!! go]]) | |
1 | ||
2 | (defn fan-in [ins] | |
3 | (let [c (chan)] | |
4 | (future (while true | |
5 | (let [[x] (alts!! ins)] | |
6 | (>!! c x)))) | |
7 | c)) | |
8 | ||
9 | (defn fan-out [in cs-or-n] | |
10 | (let [cs (if (number? cs-or-n) | |
11 | (repeatedly cs-or-n chan) | |
12 | cs-or-n)] | |
13 | (future (while true | |
14 | (let [x (<!! in) | |
15 | outs (map #(vector % x) cs)] | |
16 | (alts!! outs)))) | |
17 | cs)) | |
18 | ||
19 | (let [cout (chan) | |
20 | cin (fan-in (fan-out cout (repeatedly 3 chan)))] | |
21 | (dotimes [n 10] | |
22 | (>!! cout n) | |
23 | (prn (<!! cin)))) |
0 | (require '[clojure.core.async :as async :refer [<! >! timeout chan alt! alts! go]]) | |
1 | ||
2 | (defn fan-in [ins] | |
3 | (let [c (chan)] | |
4 | (go (while true | |
5 | (let [[x] (alts! ins)] | |
6 | (>! c x)))) | |
7 | c)) | |
8 | ||
9 | (defn fan-out [in cs-or-n] | |
10 | (let [cs (if (number? cs-or-n) | |
11 | (repeatedly cs-or-n chan) | |
12 | cs-or-n)] | |
13 | (go (while true | |
14 | (let [x (<! in) | |
15 | outs (map #(vector % x) cs)] | |
16 | (alts! outs)))) | |
17 | cs)) | |
18 | ||
19 | (let [cout (chan) | |
20 | cin (fan-in (fan-out cout (repeatedly 3 chan)))] | |
21 | (go (dotimes [n 10] | |
22 | (>! cout n) | |
23 | (prn (<! cin)))) | |
24 | nil) |
0 | (require '[clojure.core.async :as async :refer [<!! >!! timeout chan alt!!]]) | |
1 | ||
2 | (defn fake-search [kind] | |
3 | (fn [c query] | |
4 | (future | |
5 | (<!! (timeout (rand-int 100))) | |
6 | (>!! c [kind query])))) | |
7 | ||
8 | (def web1 (fake-search :web1)) | |
9 | (def web2 (fake-search :web2)) | |
10 | (def image1 (fake-search :image1)) | |
11 | (def image2 (fake-search :image2)) | |
12 | (def video1 (fake-search :video1)) | |
13 | (def video2 (fake-search :video2)) | |
14 | ||
15 | (defn fastest [query & replicas] | |
16 | (let [c (chan)] | |
17 | (doseq [replica replicas] | |
18 | (replica c query)) | |
19 | c)) | |
20 | ||
21 | (defn google [query] | |
22 | (let [c (chan) | |
23 | t (timeout 80)] | |
24 | (future (>!! c (<!! (fastest query web1 web2)))) | |
25 | (future (>!! c (<!! (fastest query image1 image2)))) | |
26 | (future (>!! c (<!! (fastest query video1 video2)))) | |
27 | (loop [i 0 ret []] | |
28 | (if (= i 3) | |
29 | ret | |
30 | (recur (inc i) (conj ret (alt!! [c t] ([v] v)))))))) | |
31 | ||
32 | (google "clojure") |
0 | (require '[clojure.core.async :as async :refer [<! >! <!! timeout chan alt! go]]) | |
1 | ||
2 | (defn fake-search [kind] | |
3 | (fn [c query] | |
4 | (go | |
5 | (<! (timeout (rand-int 100))) | |
6 | (>! c [kind query])))) | |
7 | ||
8 | (def web1 (fake-search :web1)) | |
9 | (def web2 (fake-search :web2)) | |
10 | (def image1 (fake-search :image1)) | |
11 | (def image2 (fake-search :image2)) | |
12 | (def video1 (fake-search :video1)) | |
13 | (def video2 (fake-search :video2)) | |
14 | ||
15 | (defn fastest [query & replicas] | |
16 | (let [c (chan)] | |
17 | (doseq [replica replicas] | |
18 | (replica c query)) | |
19 | c)) | |
20 | ||
21 | (defn google [query] | |
22 | (let [c (chan) | |
23 | t (timeout 80)] | |
24 | (go (>! c (<! (fastest query web1 web2)))) | |
25 | (go (>! c (<! (fastest query image1 image2)))) | |
26 | (go (>! c (<! (fastest query video1 video2)))) | |
27 | (go (loop [i 0 ret []] | |
28 | (if (= i 3) | |
29 | ret | |
30 | (recur (inc i) (conj ret (alt! [c t] ([v] v))))))))) | |
31 | ||
32 | (<!! (google "clojure")) | |
33 |
0 | ;; This walkthrough introduces the core concepts of core.async. | |
1 | ||
2 | ;; The clojure.core.async namespace contains the public API. | |
3 | (require '[clojure.core.async :as async :refer :all]) | |
4 | ||
5 | ;;;; CHANNELS | |
6 | ||
7 | ;; Data is transmitted on queue-like channels. By default channels | |
8 | ;; are unbuffered (0-length) - they require producer and consumer to | |
9 | ;; rendezvous for the transfer of a value through the channel. | |
10 | ||
11 | ;; Use `chan` to make an unbuffered channel: | |
12 | (chan) | |
13 | ||
14 | ;; Pass a number to create a channel with a fixed buffer: | |
15 | (chan 10) | |
16 | ||
17 | ;; `close!` a channel to stop accepting puts. Remaining values are still | |
18 | ;; available to take. Drained channels return nil on take. Nils may | |
19 | ;; not be sent over a channel explicitly! | |
20 | ||
21 | (let [c (chan)] | |
22 | (close! c)) | |
23 | ||
24 | ;;;; ORDINARY THREADS | |
25 | ||
26 | ;; In ordinary threads, we use `>!!` (blocking put) and `<!!` | |
27 | ;; (blocking take) to communicate via channels. | |
28 | ||
29 | (let [c (chan 10)] | |
30 | (>!! c "hello") | |
31 | (assert (= "hello" (<!! c))) | |
32 | (close! c)) | |
33 | ||
34 | ;; Because these are blocking calls, if we try to put on an | |
35 | ;; unbuffered channel, we will block the main thread. We can use | |
36 | ;; `thread` (like `future`) to execute a body in a pool thread and | |
37 | ;; return a channel with the result. Here we launch a background task | |
38 | ;; to put "hello" on a channel, then read that value in the current thread. | |
39 | ||
40 | (let [c (chan)] | |
41 | (thread (>!! c "hello")) | |
42 | (assert (= "hello" (<!! c))) | |
43 | (close! c)) | |
44 | ||
45 | ;;;; GO BLOCKS AND IOC THREADS | |
46 | ||
47 | ;; The `go` macro asynchronously executes its body in a special pool | |
48 | ;; of threads. Channel operations that would block will pause | |
49 | ;; execution instead, blocking no threads. This mechanism encapsulates | |
50 | ;; the inversion of control that is external in event/callback | |
51 | ;; systems. Inside `go` blocks, we use `>!` (put) and `<!` (take). | |
52 | ||
53 | ;; Here we convert our prior channel example to use go blocks: | |
54 | (let [c (chan)] | |
55 | (go (>! c "hello")) | |
56 | (assert (= "hello" (<!! (go (<! c))))) | |
57 | (close! c)) | |
58 | ||
59 | ;; Instead of the explicit thread and blocking call, we use a go block | |
60 | ;; for the producer. The consumer uses a go block to take, then | |
61 | ;; returns a result channel, from which we do a blocking take. | |
62 | ||
63 | ;;;; ALTS | |
64 | ||
65 | ;; One killer feature for channels over queues is the ability to wait | |
66 | ;; on many channels at the same time (like a socket select). This is | |
67 | ;; done with `alts!!` (ordinary threads) or `alts!` in go blocks. | |
68 | ||
69 | ;; We can create a background thread with alts that combines inputs on | |
70 | ;; either of two channels. `alts!!` takes a set of operations | |
71 | ;; to perform - either a channel to take from or a [channel value] to put | |
72 | ;; and returns the value (nil for put) and channel that succeeded: | |
73 | ||
74 | (let [c1 (chan) | |
75 | c2 (chan)] | |
76 | (thread (while true | |
77 | (let [[v ch] (alts!! [c1 c2])] | |
78 | (println "Read" v "from" ch)))) | |
79 | (>!! c1 "hi") | |
80 | (>!! c2 "there")) | |
81 | ||
82 | ;; Prints (on stdout, possibly not visible at your repl): | |
83 | ;; Read hi from #<ManyToManyChannel ...> | |
84 | ;; Read there from #<ManyToManyChannel ...> | |
85 | ||
86 | ;; We can use alts! to do the same thing with go blocks: | |
87 | ||
88 | (let [c1 (chan) | |
89 | c2 (chan)] | |
90 | (go (while true | |
91 | (let [[v ch] (alts! [c1 c2])] | |
92 | (println "Read" v "from" ch)))) | |
93 | (go (>! c1 "hi")) | |
94 | (go (>! c2 "there"))) | |
95 | ||
96 | ;; Since go blocks are lightweight processes not bound to threads, we | |
97 | ;; can have LOTS of them! Here we create 1000 go blocks that say hi on | |
98 | ;; 1000 channels. We use alts!! to read them as they're ready. | |
99 | ||
100 | (let [n 1000 | |
101 | cs (repeatedly n chan) | |
102 | begin (System/currentTimeMillis)] | |
103 | (doseq [c cs] (go (>! c "hi"))) | |
104 | (dotimes [i n] | |
105 | (let [[v c] (alts!! cs)] | |
106 | (assert (= "hi" v)))) | |
107 | (println "Read" n "msgs in" (- (System/currentTimeMillis) begin) "ms")) | |
108 | ||
109 | ;; `timeout` creates a channel that waits for a specified ms, then closes: | |
110 | ||
111 | (let [t (timeout 100) | |
112 | begin (System/currentTimeMillis)] | |
113 | (<!! t) | |
114 | (println "Waited" (- (System/currentTimeMillis) begin))) | |
115 | ||
116 | ;; We can combine timeout with `alts!` to do timed channel waits. | |
117 | ;; Here we wait for 100 ms for a value to arrive on the channel, then | |
118 | ;; give up: | |
119 | ||
120 | (let [c (chan) | |
121 | begin (System/currentTimeMillis)] | |
122 | (alts!! [c (timeout 100)]) | |
123 | (println "Gave up after" (- (System/currentTimeMillis) begin))) | |
124 | ||
125 | ;; ALT | |
126 | ||
127 | ;; todo | |
128 | ||
129 | ;;;; OTHER BUFFERS | |
130 | ||
131 | ;; Channels can also use custom buffers that have different policies | |
132 | ;; for the "full" case. Two useful examples are provided in the API. | |
133 | ||
134 | ;; Use `dropping-buffer` to drop newest values when the buffer is full: | |
135 | (chan (dropping-buffer 10)) | |
136 | ||
137 | ;; Use `sliding-buffer` to drop oldest values when the buffer is full: | |
138 | (chan (sliding-buffer 10)) |
0 | <project xmlns="http://maven.apache.org/POM/4.0.0" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="http://maven.apache.org/POM/4.0.0 http://maven.apache.org/xsd/maven-4.0.0.xsd"> | |
1 | <modelVersion>4.0.0</modelVersion> | |
2 | <groupId>org.clojure</groupId> | |
3 | <artifactId>core.async</artifactId> | |
4 | <!-- Don't set this manually! Call script/build/update_version --> | |
5 | <version>0.3.443</version> | |
6 | <packaging>jar</packaging> | |
7 | <name>core.async</name> | |
8 | <description>Facilities for async programming and communication in Clojure</description> | |
9 | <url>https://github.com/clojure/core.async</url> | |
10 | ||
11 | <developers> | |
12 | <developer> | |
13 | <id>richhickey</id> | |
14 | <name>Rich Hickey</name> | |
15 | <url>http://clojure.org</url> | |
16 | </developer> | |
17 | </developers> | |
18 | ||
19 | <parent> | |
20 | <groupId>org.clojure</groupId> | |
21 | <artifactId>pom.contrib</artifactId> | |
22 | <version>0.2.2</version> | |
23 | </parent> | |
24 | ||
25 | <scm> | |
26 | <connection>scm:git:git://github.com/clojure/core.async.git</connection> | |
27 | <developerConnection>scm:git:git@github.com:clojure/core.async.git</developerConnection> | |
28 | <url>https://github.com/clojure/core.async</url> | |
29 | <tag>core.async-0.3.443</tag> | |
30 | </scm> | |
31 | ||
32 | <properties> | |
33 | <clojure.version>1.7.0</clojure.version> | |
34 | </properties> | |
35 | ||
36 | <dependencies> | |
37 | <dependency> | |
38 | <groupId>org.clojure</groupId> | |
39 | <artifactId>clojurescript</artifactId> | |
40 | <version>0.0-2311</version> | |
41 | <scope>provided</scope> | |
42 | </dependency> | |
43 | <dependency> | |
44 | <groupId>org.clojure</groupId> | |
45 | <artifactId>tools.analyzer.jvm</artifactId> | |
46 | <version>0.7.0</version> | |
47 | </dependency> | |
48 | </dependencies> | |
49 | ||
50 | <build> | |
51 | <plugins> | |
52 | <plugin> | |
53 | <groupId>org.codehaus.mojo</groupId> | |
54 | <artifactId>versions-maven-plugin</artifactId> | |
55 | <version>2.3</version> | |
56 | </plugin> | |
57 | </plugins> | |
58 | </build> | |
59 | </project> |
0 | (defproject org.clojure/core.async "0.1.0-SNAPSHOT" | |
1 | :description "Facilities for async programming and communication in Clojure" | |
2 | :url "https://github.com/clojure/core.async" | |
3 | :license {:name "Eclipse Public License" | |
4 | :url "http://www.eclipse.org/legal/epl-v10.html"} | |
5 | :parent [org.clojure/pom.contrib "0.1.2"] | |
6 | :dependencies [[org.clojure/clojure "1.7.0"] | |
7 | [org.clojure/tools.analyzer.jvm "0.7.0"] | |
8 | [org.clojure/clojurescript "1.7.170" :scope "provided"]] | |
9 | :global-vars {*warn-on-reflection* true} | |
10 | :source-paths ["src/main/clojure"] | |
11 | :test-paths ["src/test/clojure"] | |
12 | :jvm-opts ^:replace ["-Xmx1g" "-server"] | |
13 | :java-source-paths ["src/main/java"] | |
14 | :profiles {:dev {:source-paths ["examples"]}} | |
15 | ||
16 | :plugins [[lein-cljsbuild "1.1.2"]] | |
17 | ||
18 | :clean-targets ["tests.js" "tests.js.map" | |
19 | "out" "out-simp" "out-simp-node" | |
20 | "out-adv" "out-adv-node"] | |
21 | ||
22 | :cljsbuild | |
23 | {:builds | |
24 | [{:id "dev" | |
25 | :source-paths ["src/test/cljs" "src/main/clojure/cljs"] | |
26 | :compiler {:main cljs.core.async.test-runner | |
27 | :asset-path "../out" | |
28 | :optimizations :none | |
29 | :output-to "tests.js" | |
30 | :output-dir "out"}} | |
31 | {:id "simple" | |
32 | :source-paths ["src/test/cljs" "src/main/clojure/cljs"] | |
33 | :compiler {:optimizations :simple | |
34 | :pretty-print true | |
35 | :static-fns true | |
36 | :output-to "tests.js" | |
37 | :output-dir "out-simp"}} | |
38 | {:id "simple-node" | |
39 | :source-paths ["src/test/cljs" "src/main/clojure/cljs"] | |
40 | :notify-command ["node" "tests.js"] | |
41 | :compiler {:optimizations :simple | |
42 | :target :nodejs | |
43 | :pretty-print true | |
44 | :static-fns true | |
45 | :output-to "tests.js" | |
46 | :output-dir "out-simp-node"}} | |
47 | {:id "adv" | |
48 | :source-paths ["src/test/cljs" "src/main/clojure/cljs"] | |
49 | :compiler {:optimizations :advanced | |
50 | :pretty-print false | |
51 | :output-dir "out-adv" | |
52 | :output-to "tests.js" | |
53 | :source-map "tests.js.map"}} | |
54 | {:id "adv-node" | |
55 | :source-paths ["src/test/cljs" "src/main/clojure/cljs"] | |
56 | :compiler {:optimizations :advanced | |
57 | :target :nodejs | |
58 | :pretty-print false | |
59 | :output-dir "out-adv-node" | |
60 | :output-to "tests.js" | |
61 | :source-map "tests.js.map"}}]}) |
0 | #!/usr/bin/env bash | |
1 | ||
2 | # If on a branch other than master, returns the number of commits made off of master | |
3 | # If on master, returns 0 | |
4 | ||
5 | set -e | |
6 | ||
7 | master_tag=`git rev-parse --abbrev-ref HEAD` | |
8 | ||
9 | if [ "$master_tag" == "master" ]; then | |
10 | echo "0" | |
11 | else | |
12 | last_commit=`git rev-parse HEAD` | |
13 | revision=`git rev-list master..$last_commit | wc -l` | |
14 | echo $revision | |
15 | fi |
0 | #!/usr/bin/env bash | |
1 | ||
2 | # Return the portion of the version number generated from git | |
3 | # <trunk-basis> | |
4 | ||
5 | set -e | |
6 | ||
7 | trunk_basis=`script/build/trunk_revision` | |
8 | sha=`git rev-parse HEAD` | |
9 | ||
10 | sha=${sha:0:${#sha}-34} # drop the last 34 characters, keep 6 | |
11 | ||
12 | echo $trunk_basis |
0 | #!/usr/bin/env bash | |
1 | ||
2 | # Return the complete revision number | |
3 | # <major>.<minor>.<trunk-basis>.<patch-or-0>-<sha>[-qualifier] | |
4 | ||
5 | set -e | |
6 | ||
7 | version_template=`cat VERSION_TEMPLATE` | |
8 | ||
9 | if [[ "$version_template" =~ ^[0-9]+\.[0-9]+\.GENERATED_VERSION(-[a-zA-Z0-9]+)?$ ]]; then | |
10 | ||
11 | git_revision=`script/build/git_revision` | |
12 | echo ${version_template/GENERATED_VERSION/$git_revision} | |
13 | ||
14 | else | |
15 | echo "Invalid version template string: $version_template" >&2 | |
16 | exit -1 | |
17 | fi | |
18 |
0 | #!/usr/bin/env bash | |
1 | ||
2 | # Returns the number of commits made since the v0.0 tag | |
3 | ||
4 | set -e | |
5 | ||
6 | REVISION=`git --no-replace-objects describe --match v0.0` | |
7 | ||
8 | # Extract the version number from the string. Do this in two steps so | |
9 | # it is a little easier to understand. | |
10 | REVISION=${REVISION:5} # drop the first 5 characters | |
11 | REVISION=${REVISION:0:${#REVISION}-9} # drop the last 9 characters | |
12 | ||
13 | echo $REVISION |
0 | <html> | |
1 | <head> | |
2 | </head> | |
3 | <body> | |
4 | <script src="../tests.js" language="javascript"></script> | |
5 | ||
6 | <h2>Open JavaScript Console to see the test results</h2> | |
7 | </body> | |
8 | </html> |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns cljs.core.async.impl.buffers | |
9 | (:require [cljs.core.async.impl.protocols :as impl])) | |
10 | ||
11 | ;; ----------------------------------------------------------------------------- | |
12 | ;; DO NOT USE, this is internal buffer representation | |
13 | ||
14 | (defn acopy [src src-start dest dest-start len] | |
15 | (loop [cnt 0] | |
16 | (when (< cnt len) | |
17 | (aset dest | |
18 | (+ dest-start cnt) | |
19 | (aget src (+ src-start cnt))) | |
20 | (recur (inc cnt))))) | |
21 | ||
22 | (deftype RingBuffer [^:mutable head ^:mutable tail ^:mutable length ^:mutable arr] | |
23 | Object | |
24 | (pop [_] | |
25 | (when-not (zero? length) | |
26 | (let [x (aget arr tail)] | |
27 | (aset arr tail nil) | |
28 | (set! tail (js-mod (inc tail) (alength arr))) | |
29 | (set! length (dec length)) | |
30 | x))) | |
31 | ||
32 | (unshift [_ x] | |
33 | (aset arr head x) | |
34 | (set! head (js-mod (inc head) (alength arr))) | |
35 | (set! length (inc length)) | |
36 | nil) | |
37 | ||
38 | (unbounded-unshift [this x] | |
39 | (if (== (inc length) (alength arr)) | |
40 | (.resize this)) | |
41 | (.unshift this x)) | |
42 | ||
43 | ;; Doubles the size of the buffer while retaining all the existing values | |
44 | (resize | |
45 | [_] | |
46 | (let [new-arr-size (* (alength arr) 2) | |
47 | new-arr (make-array new-arr-size)] | |
48 | (cond | |
49 | (< tail head) | |
50 | (do (acopy arr tail new-arr 0 length) | |
51 | (set! tail 0) | |
52 | (set! head length) | |
53 | (set! arr new-arr)) | |
54 | ||
55 | (> tail head) | |
56 | (do (acopy arr tail new-arr 0 (- (alength arr) tail)) | |
57 | (acopy arr 0 new-arr (- (alength arr) tail) head) | |
58 | (set! tail 0) | |
59 | (set! head length) | |
60 | (set! arr new-arr)) | |
61 | ||
62 | (== tail head) | |
63 | (do (set! tail 0) | |
64 | (set! head 0) | |
65 | (set! arr new-arr))))) | |
66 | ||
67 | (cleanup [this keep?] | |
68 | (dotimes [x length] | |
69 | (let [v (.pop this)] | |
70 | (when ^boolean (keep? v) | |
71 | (.unshift this v)))))) | |
72 | ||
73 | (defn ring-buffer [n] | |
74 | (assert (> n 0) "Can't create a ring buffer of size 0") | |
75 | (RingBuffer. 0 0 0 (make-array n))) | |
76 | ||
77 | ;; ----------------------------------------------------------------------------- | |
78 | ||
79 | (deftype FixedBuffer [buf n] | |
80 | impl/Buffer | |
81 | (full? [this] | |
82 | (== (.-length buf) n)) | |
83 | (remove! [this] | |
84 | (.pop buf)) | |
85 | (add!* [this itm] | |
86 | (.unbounded-unshift buf itm) | |
87 | this) | |
88 | (close-buf! [this]) | |
89 | cljs.core/ICounted | |
90 | (-count [this] | |
91 | (.-length buf))) | |
92 | ||
93 | (defn fixed-buffer [n] | |
94 | (FixedBuffer. (ring-buffer n) n)) | |
95 | ||
96 | (deftype DroppingBuffer [buf n] | |
97 | impl/UnblockingBuffer | |
98 | impl/Buffer | |
99 | (full? [this] | |
100 | false) | |
101 | (remove! [this] | |
102 | (.pop buf)) | |
103 | (add!* [this itm] | |
104 | (when-not (== (.-length buf) n) | |
105 | (.unshift buf itm)) | |
106 | this) | |
107 | (close-buf! [this]) | |
108 | cljs.core/ICounted | |
109 | (-count [this] | |
110 | (.-length buf))) | |
111 | ||
112 | (defn dropping-buffer [n] | |
113 | (DroppingBuffer. (ring-buffer n) n)) | |
114 | ||
115 | (deftype SlidingBuffer [buf n] | |
116 | impl/UnblockingBuffer | |
117 | impl/Buffer | |
118 | (full? [this] | |
119 | false) | |
120 | (remove! [this] | |
121 | (.pop buf)) | |
122 | (add!* [this itm] | |
123 | (when (== (.-length buf) n) | |
124 | (impl/remove! this)) | |
125 | (.unshift buf itm) | |
126 | this) | |
127 | (close-buf! [this]) | |
128 | cljs.core/ICounted | |
129 | (-count [this] | |
130 | (.-length buf))) | |
131 | ||
132 | (defn sliding-buffer [n] | |
133 | (SlidingBuffer. (ring-buffer n) n)) | |
134 | ||
135 | (defonce ^:private NO-VAL (js/Object.)) | |
136 | (defn- undelivered? [val] | |
137 | (identical? NO-VAL val)) | |
138 | ||
139 | (deftype PromiseBuffer [^:mutable val] | |
140 | impl/UnblockingBuffer | |
141 | impl/Buffer | |
142 | (full? [_] | |
143 | false) | |
144 | (remove! [_] | |
145 | val) | |
146 | (add!* [this itm] | |
147 | (when (undelivered? val) | |
148 | (set! val itm)) | |
149 | this) | |
150 | (close-buf! [_] | |
151 | (when (undelivered? val) | |
152 | (set! val nil))) | |
153 | cljs.core/ICounted | |
154 | (-count [_] | |
155 | (if (undelivered? val) 0 1))) | |
156 | ||
157 | (defn promise-buffer [] | |
158 | (PromiseBuffer. NO-VAL)) |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns cljs.core.async.impl.channels | |
9 | (:require [cljs.core.async.impl.protocols :as impl] | |
10 | [cljs.core.async.impl.dispatch :as dispatch] | |
11 | [cljs.core.async.impl.buffers :as buffers])) | |
12 | ||
13 | ||
14 | ||
15 | (defn box [val] | |
16 | (reify cljs.core/IDeref | |
17 | (-deref [_] val))) | |
18 | ||
19 | (deftype PutBox [handler val]) | |
20 | ||
21 | (defn put-active? [box] | |
22 | (impl/active? (.-handler box))) | |
23 | ||
24 | (def ^:const MAX_DIRTY 64) | |
25 | ||
26 | (defprotocol MMC | |
27 | (abort [this])) | |
28 | ||
29 | (deftype ManyToManyChannel [takes ^:mutable dirty-takes puts ^:mutable dirty-puts ^not-native buf ^:mutable closed add!] | |
30 | MMC | |
31 | (abort [this] | |
32 | (loop [] | |
33 | (let [putter (.pop puts)] | |
34 | (when-not (nil? putter) | |
35 | (let [^not-native put-handler (.-handler putter) | |
36 | val (.-val putter)] | |
37 | (if ^boolean (impl/active? put-handler) | |
38 | (let [put-cb (impl/commit put-handler)] | |
39 | (dispatch/run #(put-cb true))) | |
40 | (recur)))))) | |
41 | (.cleanup puts (constantly false)) | |
42 | (impl/close! this)) | |
43 | impl/WritePort | |
44 | (put! [this val ^not-native handler] | |
45 | (assert (not (nil? val)) "Can't put nil in on a channel") | |
46 | ;; bug in CLJS compiler boolean inference - David | |
47 | (let [^boolean closed closed] | |
48 | (if (or closed (not ^boolean (impl/active? handler))) | |
49 | (box (not closed)) | |
50 | (if (and buf (not (impl/full? buf))) | |
51 | (do | |
52 | (impl/commit handler) | |
53 | (let [done? (reduced? (add! buf val)) | |
54 | take-cbs (loop [takers []] | |
55 | (if (and (pos? (.-length takes)) (pos? (count buf))) | |
56 | (let [^not-native taker (.pop takes)] | |
57 | (if ^boolean (impl/active? taker) | |
58 | (let [ret (impl/commit taker) | |
59 | val (impl/remove! buf)] | |
60 | (recur (conj takers (fn [] (ret val))))) | |
61 | (recur takers))) | |
62 | takers))] | |
63 | (when done? (abort this)) | |
64 | (when (seq take-cbs) | |
65 | (doseq [f take-cbs] | |
66 | (dispatch/run f))) | |
67 | (box true))) | |
68 | (let [taker (loop [] | |
69 | (let [^not-native taker (.pop takes)] | |
70 | (when taker | |
71 | (if (impl/active? taker) | |
72 | taker | |
73 | (recur)))))] | |
74 | (if taker | |
75 | (let [take-cb (impl/commit taker)] | |
76 | (impl/commit handler) | |
77 | (dispatch/run (fn [] (take-cb val))) | |
78 | (box true)) | |
79 | (do | |
80 | (if (> dirty-puts MAX_DIRTY) | |
81 | (do (set! dirty-puts 0) | |
82 | (.cleanup puts put-active?)) | |
83 | (set! dirty-puts (inc dirty-puts))) | |
84 | (when (impl/blockable? handler) | |
85 | (assert (< (.-length puts) impl/MAX-QUEUE-SIZE) | |
86 | (str "No more than " impl/MAX-QUEUE-SIZE | |
87 | " pending puts are allowed on a single channel." | |
88 | " Consider using a windowed buffer.")) | |
89 | (.unbounded-unshift puts (PutBox. handler val))) | |
90 | nil))))))) | |
91 | impl/ReadPort | |
92 | (take! [this ^not-native handler] | |
93 | (if (not ^boolean (impl/active? handler)) | |
94 | nil | |
95 | (if (and (not (nil? buf)) (pos? (count buf))) | |
96 | (do | |
97 | (if-let [take-cb (impl/commit handler)] | |
98 | (let [val (impl/remove! buf) | |
99 | [done? cbs] (when (pos? (.-length puts)) | |
100 | (loop [cbs []] | |
101 | (let [putter (.pop puts) | |
102 | ^not-native put-handler (.-handler putter) | |
103 | val (.-val putter) | |
104 | cb (and ^boolean (impl/active? put-handler) (impl/commit put-handler)) | |
105 | cbs (if cb (conj cbs cb) cbs) | |
106 | done? (when cb (reduced? (add! buf val)))] | |
107 | (if (and (not done?) (not (impl/full? buf)) (pos? (.-length puts))) | |
108 | (recur cbs) | |
109 | [done? cbs]))))] | |
110 | (when done? | |
111 | (abort this)) | |
112 | (doseq [cb cbs] | |
113 | (dispatch/run #(cb true))) | |
114 | (box val)))) | |
115 | (let [putter (loop [] | |
116 | (let [putter (.pop puts)] | |
117 | (when putter | |
118 | (if ^boolean (impl/active? (.-handler putter)) | |
119 | putter | |
120 | (recur)))))] | |
121 | (if putter | |
122 | (let [put-cb (impl/commit (.-handler putter))] | |
123 | (impl/commit handler) | |
124 | (dispatch/run #(put-cb true)) | |
125 | (box (.-val putter))) | |
126 | (if closed | |
127 | (do | |
128 | (when buf (add! buf)) | |
129 | (if (and (impl/active? handler) (impl/commit handler)) | |
130 | (let [has-val (and buf (pos? (count buf)))] | |
131 | (let [val (when has-val (impl/remove! buf))] | |
132 | (box val))) | |
133 | nil)) | |
134 | (do | |
135 | (if (> dirty-takes MAX_DIRTY) | |
136 | (do (set! dirty-takes 0) | |
137 | (.cleanup takes impl/active?)) | |
138 | (set! dirty-takes (inc dirty-takes))) | |
139 | (when (impl/blockable? handler) | |
140 | (assert (< (.-length takes) impl/MAX-QUEUE-SIZE) | |
141 | (str "No more than " impl/MAX-QUEUE-SIZE | |
142 | " pending takes are allowed on a single channel.")) | |
143 | (.unbounded-unshift takes handler)) | |
144 | nil))))))) | |
145 | impl/Channel | |
146 | (closed? [_] closed) | |
147 | (close! [this] | |
148 | (if ^boolean closed | |
149 | nil | |
150 | (do (set! closed true) | |
151 | (when (and buf (zero? (.-length puts))) | |
152 | (add! buf)) | |
153 | (loop [] | |
154 | (let [^not-native taker (.pop takes)] | |
155 | (when-not (nil? taker) | |
156 | (when ^boolean (impl/active? taker) | |
157 | (let [take-cb (impl/commit taker) | |
158 | val (when (and buf (pos? (count buf))) (impl/remove! buf))] | |
159 | (dispatch/run (fn [] (take-cb val))))) | |
160 | (recur)))) | |
161 | (when buf (impl/close-buf! buf)) | |
162 | nil)))) | |
163 | ||
164 | (defn- ex-handler [ex] | |
165 | (.log js/console ex) | |
166 | nil) | |
167 | ||
168 | (defn- handle [buf exh t] | |
169 | (let [else ((or exh ex-handler) t)] | |
170 | (if (nil? else) | |
171 | buf | |
172 | (impl/add! buf else)))) | |
173 | ||
174 | (defn chan | |
175 | ([buf] (chan buf nil)) | |
176 | ([buf xform] (chan buf xform nil)) | |
177 | ([buf xform exh] | |
178 | (ManyToManyChannel. (buffers/ring-buffer 32) 0 (buffers/ring-buffer 32) | |
179 | 0 buf false | |
180 | (let [add! (if xform (xform impl/add!) impl/add!)] | |
181 | (fn | |
182 | ([buf] | |
183 | (try | |
184 | (add! buf) | |
185 | (catch :default t | |
186 | (handle buf exh t)))) | |
187 | ([buf val] | |
188 | (try | |
189 | (add! buf val) | |
190 | (catch :default t | |
191 | (handle buf exh t))))))))) |
0 | (ns cljs.core.async.impl.dispatch | |
1 | (:require [cljs.core.async.impl.buffers :as buffers] | |
2 | [goog.async.nextTick])) | |
3 | ||
4 | (def tasks (buffers/ring-buffer 32)) | |
5 | (def running? false) | |
6 | (def queued? false) | |
7 | ||
8 | (def TASK_BATCH_SIZE 1024) | |
9 | ||
10 | (declare queue-dispatcher) | |
11 | ||
12 | (defn process-messages [] | |
13 | (set! running? true) | |
14 | (set! queued? false) | |
15 | (loop [count 0] | |
16 | (let [m (.pop tasks)] | |
17 | (when-not (nil? m) | |
18 | (m) | |
19 | (when (< count TASK_BATCH_SIZE) | |
20 | (recur (inc count)))))) | |
21 | (set! running? false) | |
22 | (when (> (.-length tasks) 0) | |
23 | (queue-dispatcher))) | |
24 | ||
25 | (defn queue-dispatcher [] | |
26 | (when-not (and queued? running?) | |
27 | (set! queued? true) | |
28 | (goog.async.nextTick process-messages))) | |
29 | ||
30 | (defn run [f] | |
31 | (.unbounded-unshift tasks f) | |
32 | (queue-dispatcher)) | |
33 | ||
34 | (defn queue-delay [f delay] | |
35 | (js/setTimeout f delay)) | |
36 |
0 | (ns cljs.core.async.impl.ioc-helpers | |
1 | (:require [cljs.core.async.impl.protocols :as impl]) | |
2 | (:require-macros [cljs.core.async.impl.ioc-macros :as ioc])) | |
3 | ||
4 | (def ^:const FN-IDX 0) | |
5 | (def ^:const STATE-IDX 1) | |
6 | (def ^:const VALUE-IDX 2) | |
7 | (def ^:const BINDINGS-IDX 3) | |
8 | (def ^:const EXCEPTION-FRAMES 4) | |
9 | (def ^:const CURRENT-EXCEPTION 5) | |
10 | (def ^:const USER-START-IDX 6) | |
11 | ||
12 | (defn aset-object [arr idx o] | |
13 | (aget arr idx o)) | |
14 | ||
15 | (defn aget-object [arr idx] | |
16 | (aget arr idx)) | |
17 | ||
18 | ||
19 | (defn finished? | |
20 | "Returns true if the machine is in a finished state" | |
21 | [state-array] | |
22 | (keyword-identical? (aget state-array STATE-IDX) :finished)) | |
23 | ||
24 | (defn- fn-handler | |
25 | [f] | |
26 | (reify | |
27 | impl/Handler | |
28 | (active? [_] true) | |
29 | (blockable? [_] true) | |
30 | (commit [_] f))) | |
31 | ||
32 | ||
33 | (defn run-state-machine [state] | |
34 | ((aget-object state FN-IDX) state)) | |
35 | ||
36 | (defn run-state-machine-wrapped [state] | |
37 | (try | |
38 | (run-state-machine state) | |
39 | (catch js/Object ex | |
40 | (impl/close! ^not-native (aget-object state USER-START-IDX)) | |
41 | (throw ex)))) | |
42 | ||
43 | (defn take! [state blk ^not-native c] | |
44 | (if-let [cb (impl/take! c (fn-handler | |
45 | (fn [x] | |
46 | (ioc/aset-all! state VALUE-IDX x STATE-IDX blk) | |
47 | (run-state-machine-wrapped state))))] | |
48 | (do (ioc/aset-all! state VALUE-IDX @cb STATE-IDX blk) | |
49 | :recur) | |
50 | nil)) | |
51 | ||
52 | (defn put! [state blk ^not-native c val] | |
53 | (if-let [cb (impl/put! c val (fn-handler (fn [ret-val] | |
54 | (ioc/aset-all! state VALUE-IDX ret-val STATE-IDX blk) | |
55 | (run-state-machine-wrapped state))))] | |
56 | (do (ioc/aset-all! state VALUE-IDX @cb STATE-IDX blk) | |
57 | :recur) | |
58 | nil)) | |
59 | ||
60 | (defn return-chan [state value] | |
61 | (let [^not-native c (aget state USER-START-IDX)] | |
62 | (when-not (nil? value) | |
63 | (impl/put! c value (fn-handler (fn [] nil)))) | |
64 | (impl/close! c) | |
65 | c)) | |
66 | ||
67 | (defrecord ExceptionFrame [catch-block | |
68 | ^Class catch-exception | |
69 | finally-block | |
70 | continue-block | |
71 | prev]) | |
72 | ||
73 | (defn add-exception-frame [state catch-block catch-exception finally-block continue-block] | |
74 | (ioc/aset-all! state | |
75 | EXCEPTION-FRAMES | |
76 | (->ExceptionFrame catch-block | |
77 | catch-exception | |
78 | finally-block | |
79 | continue-block | |
80 | (aget-object state EXCEPTION-FRAMES)))) | |
81 | ||
82 | (defn process-exception [state] | |
83 | (let [exception-frame (aget-object state EXCEPTION-FRAMES) | |
84 | catch-block (:catch-block exception-frame) | |
85 | catch-exception (:catch-exception exception-frame) | |
86 | exception (aget-object state CURRENT-EXCEPTION)] | |
87 | (cond | |
88 | (and exception | |
89 | (not exception-frame)) | |
90 | (throw exception) | |
91 | ||
92 | (and exception | |
93 | catch-block | |
94 | (or (= :default catch-exception) | |
95 | (instance? catch-exception exception))) | |
96 | (ioc/aset-all! state | |
97 | STATE-IDX | |
98 | catch-block | |
99 | VALUE-IDX | |
100 | exception | |
101 | CURRENT-EXCEPTION | |
102 | nil | |
103 | EXCEPTION-FRAMES | |
104 | (assoc exception-frame | |
105 | :catch-block nil | |
106 | :catch-exception nil)) | |
107 | ||
108 | ||
109 | (and exception | |
110 | (not catch-block) | |
111 | (not (:finally-block exception-frame))) | |
112 | ||
113 | (do (ioc/aset-all! state | |
114 | EXCEPTION-FRAMES | |
115 | (:prev exception-frame)) | |
116 | (recur state)) | |
117 | ||
118 | (and exception | |
119 | (not catch-block) | |
120 | (:finally-block exception-frame)) | |
121 | (ioc/aset-all! state | |
122 | STATE-IDX | |
123 | (:finally-block exception-frame) | |
124 | EXCEPTION-FRAMES | |
125 | (assoc exception-frame | |
126 | :finally-block nil)) | |
127 | ||
128 | (and (not exception) | |
129 | (:finally-block exception-frame)) | |
130 | (do (ioc/aset-all! state | |
131 | STATE-IDX | |
132 | (:finally-block exception-frame) | |
133 | EXCEPTION-FRAMES | |
134 | (assoc exception-frame | |
135 | :finally-block nil))) | |
136 | ||
137 | (and (not exception) | |
138 | (not (:finally-block exception-frame))) | |
139 | (do (ioc/aset-all! state | |
140 | STATE-IDX | |
141 | (:continue-block exception-frame) | |
142 | EXCEPTION-FRAMES | |
143 | (:prev exception-frame))) | |
144 | ||
145 | :else (throw (js/Error. "No matching clause"))))) |
0 | ; Copyright (c) Rich Hickey. All rights reserved. | |
1 | ; The use and distribution terms for this software are covered by the | |
2 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ; By using this software in any fashion, you are agreeing to be bound by | |
5 | ; the terms of this license. | |
6 | ; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | ;; by Timothy Baldridge | |
9 | ;; April 13, 2013 | |
10 | ||
11 | (ns cljs.core.async.impl.ioc-macros | |
12 | (:refer-clojure :exclude [all]) | |
13 | (:require [clojure.pprint :refer [pprint]] | |
14 | [clojure.set :refer (intersection)] | |
15 | [clojure.core.async.impl.protocols :as impl] | |
16 | [clojure.core.async.impl.dispatch :as dispatch] | |
17 | [cljs.analyzer :as cljs]) | |
18 | (:import [java.util.concurrent.locks Lock])) | |
19 | ||
20 | (defn debug [x] | |
21 | (binding [*out* *err*] | |
22 | (pprint x)) | |
23 | x) | |
24 | ||
25 | (def ^:const FN-IDX 0) | |
26 | (def ^:const STATE-IDX 1) | |
27 | (def ^:const VALUE-IDX 2) | |
28 | (def ^:const BINDINGS-IDX 3) | |
29 | (def ^:const EXCEPTION-FRAMES 4) | |
30 | (def ^:const CURRENT-EXCEPTION 5) | |
31 | (def ^:const USER-START-IDX 6) | |
32 | ||
33 | (defmacro aset-all! | |
34 | [arr & more] | |
35 | (assert (even? (count more)) "Must give an even number of args to aset-all!") | |
36 | (let [bindings (partition 2 more) | |
37 | arr-sym (gensym "statearr-")] | |
38 | `(let [~arr-sym ~arr] | |
39 | ~@(map | |
40 | (fn [[idx val]] | |
41 | `(aset ~arr-sym ~idx ~val)) | |
42 | bindings) | |
43 | ~arr-sym))) | |
44 | ||
45 | ;; State monad stuff, used only in SSA construction | |
46 | ||
47 | (defmacro gen-plan | |
48 | "Allows a user to define a state monad binding plan. | |
49 | ||
50 | (gen-plan | |
51 | [_ (assoc-in-plan [:foo :bar] 42) | |
52 | val (get-in-plan [:foo :bar])] | |
53 | val)" | |
54 | [binds id-expr] | |
55 | (let [binds (partition 2 binds) | |
56 | psym (gensym "plan_") | |
57 | forms (reduce | |
58 | (fn [acc [id expr]] | |
59 | (concat acc `[[~id ~psym] (~expr ~psym)])) | |
60 | [] | |
61 | binds)] | |
62 | `(fn [~psym] | |
63 | (let [~@forms] | |
64 | [~id-expr ~psym])))) | |
65 | ||
66 | (defn get-plan | |
67 | "Returns the final [id state] from a plan. " | |
68 | [f] | |
69 | (f {})) | |
70 | ||
71 | (defn push-binding | |
72 | "Sets the binding 'key' to value. This operation can be undone via pop-bindings. | |
73 | Bindings are stored in the state hashmap." | |
74 | [key value] | |
75 | (fn [plan] | |
76 | [nil (update-in plan [:bindings key] conj value)])) | |
77 | ||
78 | (defn push-alter-binding | |
79 | "Pushes the result of (apply f old-value args) as current value of binding key" | |
80 | [key f & args] | |
81 | (fn [plan] | |
82 | [nil (update-in plan [:bindings key] | |
83 | #(conj % (apply f (first %) args)))])) | |
84 | ||
85 | (defn get-binding | |
86 | "Gets the value of the current binding for key" | |
87 | [key] | |
88 | (fn [plan] | |
89 | [(first (get-in plan [:bindings key])) plan])) | |
90 | ||
91 | (defn pop-binding | |
92 | "Removes the most recent binding for key" | |
93 | [key] | |
94 | (fn [plan] | |
95 | [(first (get-in plan [:bindings key])) | |
96 | (update-in plan [:bindings key] pop)])) | |
97 | ||
98 | (defn no-op | |
99 | "This function can be used inside a gen-plan when no operation is to be performed" | |
100 | [] | |
101 | (fn [plan] | |
102 | [nil plan])) | |
103 | ||
104 | (defn all | |
105 | "Assumes that itms is a list of state monad function results, threads the state map | |
106 | through all of them. Returns a vector of all the results." | |
107 | [itms] | |
108 | (fn [plan] | |
109 | (reduce | |
110 | (fn [[ids plan] f] | |
111 | (let [[id plan] (f plan)] | |
112 | [(conj ids id) plan])) | |
113 | [[] plan] | |
114 | itms))) | |
115 | ||
116 | (defn assoc-in-plan | |
117 | "Same as assoc-in, but for state hash map" | |
118 | [path val] | |
119 | (fn [plan] | |
120 | [val (assoc-in plan path val)])) | |
121 | ||
122 | (defn update-in-plan | |
123 | "Same as update-in, but for a state hash map" | |
124 | [path f & args] | |
125 | (fn [plan] | |
126 | [nil (apply update-in plan path f args)])) | |
127 | ||
128 | (defn get-in-plan | |
129 | "Same as get-in, but for a state hash map" | |
130 | [path] | |
131 | (fn [plan] | |
132 | [(get-in plan path) plan])) | |
133 | ||
134 | (defn print-plan [] | |
135 | (fn [plan] | |
136 | (pprint plan) | |
137 | [nil plan])) | |
138 | ||
139 | (defn set-block | |
140 | "Sets the current block being written to by the functions. The next add-instruction call will append to this block" | |
141 | [block-id] | |
142 | (fn [plan] | |
143 | [block-id (assoc plan :current-block block-id)])) | |
144 | ||
145 | (defn get-block | |
146 | "Gets the current block" | |
147 | [] | |
148 | (fn [plan] | |
149 | [(:current-block plan) plan])) | |
150 | ||
151 | (defn add-block | |
152 | "Adds a new block, returns its id, but does not change the current block (does not call set-block)." | |
153 | [] | |
154 | (gen-plan | |
155 | [_ (update-in-plan [:block-id] (fnil inc 0)) | |
156 | blk-id (get-in-plan [:block-id]) | |
157 | cur-blk (get-block) | |
158 | _ (assoc-in-plan [:blocks blk-id] []) | |
159 | catches (get-binding :catch) | |
160 | _ (assoc-in-plan [:block-catches blk-id] catches) | |
161 | _ (if-not cur-blk | |
162 | (assoc-in-plan [:start-block] blk-id) | |
163 | (no-op))] | |
164 | blk-id)) | |
165 | ||
166 | ||
167 | (defn instruction? [x] | |
168 | (::instruction (meta x))) | |
169 | ||
170 | (defn add-instruction | |
171 | "Appends an instruction to the current block. " | |
172 | [inst] | |
173 | (let [inst-id (with-meta (gensym "inst_") | |
174 | {::instruction true}) | |
175 | inst (assoc inst :id inst-id)] | |
176 | (gen-plan | |
177 | [blk-id (get-block) | |
178 | _ (update-in-plan [:blocks blk-id] (fnil conj []) inst)] | |
179 | inst-id))) | |
180 | ||
181 | ;; | |
182 | ||
183 | ;; We're going to reduce Clojure expressions to a ssa format, | |
184 | ;; and then translate the instructions for this | |
185 | ;; virtual-virtual-machine back into Clojure data. | |
186 | ||
187 | ;; Here we define the instructions: | |
188 | ||
189 | (defprotocol IInstruction | |
190 | (reads-from [this] "Returns a list of instructions this instruction reads from") | |
191 | (writes-to [this] "Returns a list of instructions this instruction writes to") | |
192 | (block-references [this] "Returns all the blocks this instruction references")) | |
193 | ||
194 | (defprotocol IEmittableInstruction | |
195 | (emit-instruction [this state-sym] "Returns the clojure code that this instruction represents")) | |
196 | ||
197 | (defprotocol ITerminator | |
198 | (terminator-code [this] "Returns a unique symbol for this instruction") | |
199 | (terminate-block [this state-sym custom-terminators] "Emites the code to terminate a given block")) | |
200 | ||
201 | (defrecord Const [value] | |
202 | IInstruction | |
203 | (reads-from [this] [value]) | |
204 | (writes-to [this] [(:id this)]) | |
205 | (block-references [this] []) | |
206 | IEmittableInstruction | |
207 | (emit-instruction [this state-sym] | |
208 | (if (= value ::value) | |
209 | `[~(:id this) (aget ~state-sym ~VALUE-IDX)] | |
210 | `[~(:id this) ~value]))) | |
211 | ||
212 | (defrecord CustomTerminator [f blk values] | |
213 | IInstruction | |
214 | (reads-from [this] values) | |
215 | (writes-to [this] []) | |
216 | (block-references [this] []) | |
217 | ITerminator | |
218 | (terminate-block [this state-sym _] | |
219 | `(~f ~state-sym ~blk ~@values))) | |
220 | ||
221 | (defn- emit-clashing-binds | |
222 | [recur-nodes ids clashes] | |
223 | (let [temp-binds (reduce | |
224 | (fn [acc i] | |
225 | (assoc acc i (gensym "tmp"))) | |
226 | {} clashes)] | |
227 | (concat | |
228 | (mapcat (fn [i] | |
229 | `[~(temp-binds i) ~i]) | |
230 | clashes) | |
231 | (mapcat (fn [node id] | |
232 | `[~node ~(get temp-binds id id)]) | |
233 | recur-nodes | |
234 | ids)))) | |
235 | ||
236 | (defrecord Recur [recur-nodes ids] | |
237 | IInstruction | |
238 | (reads-from [this] ids) | |
239 | (writes-to [this] recur-nodes) | |
240 | (block-references [this] []) | |
241 | IEmittableInstruction | |
242 | (emit-instruction [this state-sym] | |
243 | (if-let [overlap (seq (intersection (set recur-nodes) (set ids)))] | |
244 | (emit-clashing-binds recur-nodes ids overlap) | |
245 | (mapcat (fn [r i] | |
246 | `[~r ~i]) recur-nodes ids)))) | |
247 | ||
248 | (defrecord Call [refs] | |
249 | IInstruction | |
250 | (reads-from [this] refs) | |
251 | (writes-to [this] [(:id this)]) | |
252 | (block-references [this] []) | |
253 | IEmittableInstruction | |
254 | (emit-instruction [this state-sym] | |
255 | `[~(:id this) ~(seq refs)])) | |
256 | ||
257 | (defrecord Case [val-id test-vals jmp-blocks default-block] | |
258 | IInstruction | |
259 | (reads-from [this] [val-id]) | |
260 | (writes-to [this] []) | |
261 | (block-references [this] []) | |
262 | ITerminator | |
263 | (terminate-block [this state-sym _] | |
264 | `(do (case ~val-id | |
265 | ~@(concat (mapcat (fn [test blk] | |
266 | `[~test (aset-all! ~state-sym | |
267 | ~STATE-IDX ~blk)]) | |
268 | test-vals jmp-blocks) | |
269 | (when default-block | |
270 | `[(do (aset-all! ~state-sym ~STATE-IDX ~default-block) | |
271 | :recur)]))) | |
272 | :recur))) | |
273 | ||
274 | (defrecord Fn [fn-expr local-names local-refs] | |
275 | IInstruction | |
276 | (reads-from [this] local-refs) | |
277 | (writes-to [this] [(:id this)]) | |
278 | (block-references [this] []) | |
279 | IEmittableInstruction | |
280 | (emit-instruction [this state-sym] | |
281 | `[~(:id this) | |
282 | (let [~@(interleave local-names local-refs)] | |
283 | ~@fn-expr)])) | |
284 | ||
285 | (defrecord Dot [target method args] | |
286 | IInstruction | |
287 | (reads-from [this] `[~target ~method ~@args]) | |
288 | (writes-to [this] [(:id this)]) | |
289 | (block-references [this] []) | |
290 | IEmittableInstruction | |
291 | (emit-instruction [this state-sym] | |
292 | (if (.startsWith (name method) "-") | |
293 | `[~(:id this) (. ~target ~method)] | |
294 | `[~(:id this) (. ~target ~(cons method args))]))) | |
295 | ||
296 | (defrecord Jmp [value block] | |
297 | IInstruction | |
298 | (reads-from [this] [value]) | |
299 | (writes-to [this] []) | |
300 | (block-references [this] [block]) | |
301 | ITerminator | |
302 | (terminate-block [this state-sym _] | |
303 | `(do (aset-all! ~state-sym ~VALUE-IDX ~value ~STATE-IDX ~block) | |
304 | :recur))) | |
305 | ||
306 | (defrecord Return [value] | |
307 | IInstruction | |
308 | (reads-from [this] [value]) | |
309 | (writes-to [this] []) | |
310 | (block-references [this] []) | |
311 | ITerminator | |
312 | (terminator-code [this] :Return) | |
313 | (terminate-block [this state-sym custom-terminators] | |
314 | (if-let [f (get custom-terminators (terminator-code this))] | |
315 | `(~f ~state-sym ~value) | |
316 | `(do (aset-all! ~state-sym | |
317 | ~VALUE-IDX ~value | |
318 | ~STATE-IDX :finished) | |
319 | nil)))) | |
320 | ||
321 | (defrecord Set! [field object val] | |
322 | IInstruction | |
323 | (reads-from [this] [object val]) | |
324 | (writes-to [this] [(:id this)]) | |
325 | (block-references [this] []) | |
326 | IEmittableInstruction | |
327 | (emit-instruction [this state-sym] | |
328 | (if field | |
329 | `[~(:id this) (set! (~field ~object) ~val)] | |
330 | `[~(:id this) (set! ~object ~val)]))) | |
331 | ||
332 | (defrecord CondBr [test then-block else-block] | |
333 | IInstruction | |
334 | (reads-from [this] [test]) | |
335 | (writes-to [this] []) | |
336 | (block-references [this] [then-block else-block]) | |
337 | ITerminator | |
338 | (terminate-block [this state-sym _] | |
339 | `(do (if ~test | |
340 | (aset-all! ~state-sym | |
341 | ~STATE-IDX ~then-block) | |
342 | (aset-all! ~state-sym | |
343 | ~STATE-IDX ~else-block)) | |
344 | :recur))) | |
345 | ||
346 | ||
347 | (defrecord Try [catch-block catch-exception finally-block continue-block] | |
348 | IInstruction | |
349 | (reads-from [this] []) | |
350 | (writes-to [this] []) | |
351 | (block-references [this] [catch-block finally-block continue-block]) | |
352 | IEmittableInstruction | |
353 | (emit-instruction [this state-sym] | |
354 | `[~'_ (cljs.core.async.impl.ioc-helpers/add-exception-frame ~state-sym | |
355 | ~catch-block | |
356 | ~catch-exception | |
357 | ~finally-block | |
358 | ~continue-block)])) | |
359 | ||
360 | (defrecord ProcessExceptionWithValue [value] | |
361 | IInstruction | |
362 | (reads-from [this] [value]) | |
363 | (writes-to [this] []) | |
364 | (block-references [this] []) | |
365 | ITerminator | |
366 | (terminate-block [this state-sym _] | |
367 | `(do (aset-all! ~state-sym | |
368 | ~VALUE-IDX | |
369 | ~value) | |
370 | (cljs.core.async.impl.ioc-helpers/process-exception ~state-sym) | |
371 | :recur))) | |
372 | ||
373 | (defrecord EndCatchFinally [] | |
374 | IInstruction | |
375 | (reads-from [this] []) | |
376 | (writes-to [this] []) | |
377 | (block-references [this] []) | |
378 | ITerminator | |
379 | (terminate-block [this state-sym _] | |
380 | `(do (cljs.core.async.impl.ioc-helpers/process-exception ~state-sym) | |
381 | :recur))) | |
382 | ||
383 | ||
384 | ||
385 | ;; Dispatch clojure forms based on data type | |
386 | (defmulti -item-to-ssa (fn [x] | |
387 | (cond | |
388 | (symbol? x) :symbol | |
389 | (seq? x) :list | |
390 | (map? x) :map | |
391 | (set? x) :set | |
392 | (vector? x) :vector | |
393 | :else :default))) | |
394 | ||
395 | (defn item-to-ssa [x] | |
396 | (-item-to-ssa x)) | |
397 | ||
398 | ;; given an sexpr, dispatch on the first item | |
399 | (defmulti sexpr-to-ssa (fn [[x & _]] | |
400 | x)) | |
401 | ||
402 | (defn is-special? [x] | |
403 | (let [^clojure.lang.MultiFn mfn sexpr-to-ssa] | |
404 | (.getMethod mfn x))) | |
405 | ||
406 | ||
407 | ||
408 | (defn default-sexpr [args] | |
409 | (gen-plan | |
410 | [args-ids (all (map item-to-ssa args)) | |
411 | inst-id (add-instruction (->Call args-ids))] | |
412 | inst-id)) | |
413 | ||
414 | (defn let-binding-to-ssa | |
415 | [[sym bind]] | |
416 | (gen-plan | |
417 | [bind-id (item-to-ssa bind) | |
418 | _ (push-alter-binding :locals assoc sym bind-id)] | |
419 | bind-id)) | |
420 | ||
421 | (defmethod sexpr-to-ssa 'let* | |
422 | [[_ binds & body]] | |
423 | (let [parted (partition 2 binds)] | |
424 | (gen-plan | |
425 | [let-ids (all (map let-binding-to-ssa parted)) | |
426 | body-ids (all (map item-to-ssa body)) | |
427 | _ (all (map (fn [x] | |
428 | (pop-binding :locals)) | |
429 | (range (count parted))))] | |
430 | (last body-ids)))) | |
431 | ||
432 | (defmethod sexpr-to-ssa 'loop* | |
433 | [[_ locals & body]] | |
434 | (let [parted (partition 2 locals) | |
435 | syms (map first parted) | |
436 | inits (map second parted)] | |
437 | (gen-plan | |
438 | [local-val-ids (all (map ; parallel bind | |
439 | (fn [sym init] | |
440 | (gen-plan | |
441 | [itm-id (item-to-ssa init) | |
442 | _ (push-alter-binding :locals assoc sym itm-id)] | |
443 | itm-id)) | |
444 | syms | |
445 | inits)) | |
446 | _ (all (for [x syms] | |
447 | (pop-binding :locals))) | |
448 | local-ids (all (map (comp add-instruction ->Const) local-val-ids)) | |
449 | body-blk (add-block) | |
450 | final-blk (add-block) | |
451 | _ (add-instruction (->Jmp nil body-blk)) | |
452 | ||
453 | _ (set-block body-blk) | |
454 | _ (push-alter-binding :locals merge (zipmap syms local-ids)) | |
455 | _ (push-binding :recur-point body-blk) | |
456 | _ (push-binding :recur-nodes local-ids) | |
457 | ||
458 | body-ids (all (map item-to-ssa body)) | |
459 | ||
460 | _ (pop-binding :recur-nodes) | |
461 | _ (pop-binding :recur-point) | |
462 | _ (pop-binding :locals) | |
463 | _ (if (not= (last body-ids) ::terminated) | |
464 | (add-instruction (->Jmp (last body-ids) final-blk)) | |
465 | (no-op)) | |
466 | _ (set-block final-blk) | |
467 | ret-id (add-instruction (->Const ::value))] | |
468 | ret-id))) | |
469 | ||
470 | (defmethod sexpr-to-ssa 'set! | |
471 | [[_ assignee val]] | |
472 | (let [target (cond | |
473 | (symbol? assignee) | |
474 | assignee | |
475 | (and (list? assignee) | |
476 | (= (count assignee) 2)) | |
477 | (second assignee)) | |
478 | field (if (list? assignee) | |
479 | (first assignee))] | |
480 | (gen-plan | |
481 | [locals (get-binding :locals) | |
482 | ||
483 | target-id (if (contains? locals target) | |
484 | (fn [p] | |
485 | [(get locals target) p]) | |
486 | (item-to-ssa target)) | |
487 | val-id (item-to-ssa val) | |
488 | ||
489 | ret-id (add-instruction (->Set! field target-id val-id))] | |
490 | ret-id))) | |
491 | ||
492 | (defmethod sexpr-to-ssa 'do | |
493 | [[_ & body]] | |
494 | (gen-plan | |
495 | [ids (all (map item-to-ssa body))] | |
496 | (last ids))) | |
497 | ||
498 | (defmethod sexpr-to-ssa 'case | |
499 | [[_ val & body]] | |
500 | (let [clauses (partition 2 body) | |
501 | default (when (odd? (count body)) | |
502 | (last body))] | |
503 | (gen-plan | |
504 | [end-blk (add-block) | |
505 | start-blk (get-block) | |
506 | clause-blocks (all (map (fn [expr] | |
507 | (gen-plan | |
508 | [blk-id (add-block) | |
509 | _ (set-block blk-id) | |
510 | expr-id (item-to-ssa expr) | |
511 | _ (if (not= expr-id ::terminated) | |
512 | (add-instruction (->Jmp expr-id end-blk)) | |
513 | (no-op))] | |
514 | blk-id)) | |
515 | (map second clauses))) | |
516 | default-block (if (odd? (count body)) | |
517 | (gen-plan | |
518 | [blk-id (add-block) | |
519 | _ (set-block blk-id) | |
520 | expr-id (item-to-ssa default) | |
521 | _ (if (not= expr-id ::terminated) | |
522 | (add-instruction (->Jmp expr-id end-blk)) | |
523 | (no-op))] | |
524 | blk-id) | |
525 | (no-op)) | |
526 | _ (set-block start-blk) | |
527 | val-id (item-to-ssa val) | |
528 | case-id (add-instruction (->Case val-id (map first clauses) clause-blocks default-block)) | |
529 | _ (set-block end-blk) | |
530 | ret-id (add-instruction (->Const ::value))] | |
531 | ret-id))) | |
532 | ||
533 | (defmethod sexpr-to-ssa 'quote | |
534 | [expr] | |
535 | (gen-plan | |
536 | [ret-id (add-instruction (->Const expr))] | |
537 | ret-id)) | |
538 | ||
539 | (defmethod sexpr-to-ssa '. | |
540 | [[_ target method & args]] | |
541 | (let [args (if (seq? method) | |
542 | (next method) | |
543 | args) | |
544 | method (if (seq? method) | |
545 | (first method) | |
546 | method)] | |
547 | (gen-plan | |
548 | [target-id (item-to-ssa target) | |
549 | args-ids (all (map item-to-ssa args)) | |
550 | ret-id (add-instruction (->Dot target-id method args-ids))] | |
551 | ret-id))) | |
552 | ||
553 | (defmethod sexpr-to-ssa 'try | |
554 | [[_ & body]] | |
555 | (let [finally-fn (every-pred seq? (comp (partial = 'finally) first)) | |
556 | catch-fn (every-pred seq? (comp (partial = 'catch) first)) | |
557 | finally (next (first (filter finally-fn body))) | |
558 | body (remove finally-fn body) | |
559 | catch (next (first (filter catch-fn body))) | |
560 | [ex ex-bind & catch-body] catch | |
561 | body (remove catch-fn body)] | |
562 | (gen-plan | |
563 | [end-blk (add-block) | |
564 | finally-blk (if finally | |
565 | (gen-plan | |
566 | [cur-blk (get-block) | |
567 | blk (add-block) | |
568 | _ (set-block blk) | |
569 | value-id (add-instruction (->Const ::value)) | |
570 | _ (all (map item-to-ssa finally)) | |
571 | _ (add-instruction (->EndCatchFinally)) | |
572 | _ (set-block cur-blk)] | |
573 | blk) | |
574 | (no-op)) | |
575 | catch-blk (if catch | |
576 | (gen-plan | |
577 | [cur-blk (get-block) | |
578 | blk (add-block) | |
579 | _ (set-block blk) | |
580 | ex-id (add-instruction (->Const ::value)) | |
581 | _ (push-alter-binding :locals assoc ex-bind ex-id) | |
582 | ids (all (map item-to-ssa catch-body)) | |
583 | _ (add-instruction (->ProcessExceptionWithValue (last ids))) | |
584 | _ (pop-binding :locals) | |
585 | _ (set-block cur-blk) | |
586 | _ (push-alter-binding :catch (fnil conj []) [ex blk])] | |
587 | blk) | |
588 | (no-op)) | |
589 | body-blk (add-block) | |
590 | _ (add-instruction (->Jmp nil body-blk)) | |
591 | _ (set-block body-blk) | |
592 | _ (add-instruction (->Try catch-blk ex finally-blk end-blk)) | |
593 | ids (all (map item-to-ssa body)) | |
594 | _ (if catch | |
595 | (pop-binding :catch) | |
596 | (no-op)) | |
597 | _ (add-instruction (->ProcessExceptionWithValue (last ids))) | |
598 | _ (set-block end-blk) | |
599 | ret (add-instruction (->Const ::value))] | |
600 | ret))) | |
601 | ||
602 | (defmethod sexpr-to-ssa 'recur | |
603 | [[_ & vals]] | |
604 | (gen-plan | |
605 | [val-ids (all (map item-to-ssa vals)) | |
606 | recurs (get-binding :recur-nodes) | |
607 | _ (do (assert (= (count val-ids) | |
608 | (count recurs)) | |
609 | "Wrong number of arguments to recur") | |
610 | (no-op)) | |
611 | _ (add-instruction (->Recur recurs val-ids)) | |
612 | ||
613 | recur-point (get-binding :recur-point) | |
614 | _ (add-instruction (->Jmp nil recur-point))] | |
615 | ::terminated)) | |
616 | ||
617 | (defmethod sexpr-to-ssa 'if | |
618 | [[_ test then else]] | |
619 | (gen-plan | |
620 | [test-id (item-to-ssa test) | |
621 | then-blk (add-block) | |
622 | else-blk (add-block) | |
623 | final-blk (add-block) | |
624 | _ (add-instruction (->CondBr test-id then-blk else-blk)) | |
625 | ||
626 | _ (set-block then-blk) | |
627 | then-id (item-to-ssa then) | |
628 | _ (if (not= then-id ::terminated) | |
629 | (gen-plan | |
630 | [_ (add-instruction (->Jmp then-id final-blk))] | |
631 | then-id) | |
632 | (no-op)) | |
633 | ||
634 | _ (set-block else-blk) | |
635 | else-id (item-to-ssa else) | |
636 | _ (if (not= else-id ::terminated) | |
637 | (gen-plan | |
638 | [_ (add-instruction (->Jmp else-id final-blk))] | |
639 | then-id) | |
640 | (no-op)) | |
641 | ||
642 | _ (set-block final-blk) | |
643 | val-id (add-instruction (->Const ::value))] | |
644 | val-id)) | |
645 | ||
646 | (defmethod sexpr-to-ssa 'fn* | |
647 | [& fn-expr] | |
648 | ;; For fn expressions we just want to record the expression as well | |
649 | ;; as a list of all known renamed locals | |
650 | (gen-plan | |
651 | [locals (get-binding :locals) | |
652 | fn-id (add-instruction (->Fn fn-expr (keys locals) (vals locals)))] | |
653 | fn-id)) | |
654 | ||
655 | ||
656 | (def special-override? '#{case clojure.core/case | |
657 | try clojure.core/try}) | |
658 | ||
659 | (defn expand [locals env form] | |
660 | (loop [form form] | |
661 | (if-not (seq? form) | |
662 | form | |
663 | (let [[s & r] form] | |
664 | (if (symbol? s) | |
665 | (if (or (get locals s) | |
666 | (special-override? s)) | |
667 | form | |
668 | (let [new-env (update-in env [:locals] merge locals) | |
669 | expanded (cljs/macroexpand-1 new-env form)] | |
670 | (if (= expanded form) | |
671 | form | |
672 | (recur expanded)))) | |
673 | form))))) | |
674 | ||
675 | (defn terminate-custom [vals term] | |
676 | (gen-plan | |
677 | [blk (add-block) | |
678 | vals (all (map item-to-ssa vals)) | |
679 | val (add-instruction (->CustomTerminator term blk vals)) | |
680 | _ (set-block blk) | |
681 | res (add-instruction (->Const ::value))] | |
682 | res)) | |
683 | ||
684 | (defn fixup-aliases [sym env] | |
685 | (let [aliases (ns-aliases *ns*)] | |
686 | (if-not (namespace sym) | |
687 | sym | |
688 | (if-let [ns (or (get-in env [:ns :requires-macros (symbol (namespace sym))]) | |
689 | (get-in env [:ns :requires (symbol (namespace sym))]))] | |
690 | (symbol (name ns) (name sym)) | |
691 | sym)))) | |
692 | ||
693 | (defmethod -item-to-ssa :list | |
694 | [lst] | |
695 | (gen-plan | |
696 | [env (get-binding :env) | |
697 | locals (get-binding :locals) | |
698 | terminators (get-binding :terminators) | |
699 | val (let [exp (expand locals env lst)] | |
700 | (if (seq? exp) | |
701 | (if (symbol? (first exp)) | |
702 | (let [f (fixup-aliases (first exp) env)] | |
703 | (cond | |
704 | (is-special? f) (sexpr-to-ssa exp) | |
705 | (get locals f) (default-sexpr exp) | |
706 | (get terminators f) (terminate-custom (next exp) (get terminators f)) | |
707 | :else (default-sexpr exp))) | |
708 | (default-sexpr exp)) | |
709 | (item-to-ssa exp)))] | |
710 | val)) | |
711 | ||
712 | (defmethod -item-to-ssa :default | |
713 | [x] | |
714 | (fn [plan] | |
715 | [x plan])) | |
716 | ||
717 | (defmethod -item-to-ssa :symbol | |
718 | [x] | |
719 | (gen-plan | |
720 | [locals (get-binding :locals) | |
721 | inst-id (if (contains? locals x) | |
722 | (fn [p] | |
723 | [(locals x) p]) | |
724 | (fn [p] | |
725 | [x p]) | |
726 | #_(add-instruction (->Const x)))] | |
727 | inst-id)) | |
728 | ||
729 | (defmethod -item-to-ssa :map | |
730 | [x] | |
731 | (-item-to-ssa `(hash-map ~@(mapcat identity x)))) | |
732 | ||
733 | (defmethod -item-to-ssa :vector | |
734 | [x] | |
735 | (-item-to-ssa `(vector ~@x))) | |
736 | ||
737 | (defmethod -item-to-ssa :set | |
738 | [x] | |
739 | (-item-to-ssa `(hash-set ~@x))) | |
740 | ||
741 | (defn parse-to-state-machine | |
742 | "Takes an sexpr and returns a hashmap that describes the execution flow of the sexpr as | |
743 | a series of SSA style blocks." | |
744 | [body env terminators] | |
745 | (-> (gen-plan | |
746 | [_ (push-binding :env env) | |
747 | _ (push-binding :locals (zipmap (:locals (keys env)) (:locals (keys env)))) | |
748 | _ (push-binding :terminators terminators) | |
749 | blk (add-block) | |
750 | _ (set-block blk) | |
751 | ids (all (map item-to-ssa body)) | |
752 | term-id (add-instruction (->Return (last ids))) | |
753 | _ (pop-binding :terminators) | |
754 | _ (pop-binding :locals) | |
755 | _ (pop-binding :env)] | |
756 | term-id) | |
757 | get-plan)) | |
758 | ||
759 | ||
760 | (defn index-instruction [blk-id idx inst] | |
761 | (let [idx (reduce | |
762 | (fn [acc id] | |
763 | (update-in acc [id :read-in] (fnil conj #{}) blk-id)) | |
764 | idx | |
765 | (filter instruction? (reads-from inst))) | |
766 | idx (reduce | |
767 | (fn [acc id] | |
768 | (update-in acc [id :written-in] (fnil conj #{}) blk-id)) | |
769 | idx | |
770 | (filter instruction? (writes-to inst)))] | |
771 | idx)) | |
772 | ||
773 | (defn index-block [idx [blk-id blk]] | |
774 | (reduce (partial index-instruction blk-id) idx blk)) | |
775 | ||
776 | (defn index-state-machine [machine] | |
777 | (reduce index-block {} (:blocks machine))) | |
778 | ||
779 | (defn id-for-inst [m sym] ;; m :: symbols -> integers | |
780 | (if-let [i (get @m sym)] | |
781 | i | |
782 | (let [next-idx (get @m ::next-idx)] | |
783 | (swap! m assoc sym next-idx) | |
784 | (swap! m assoc ::next-idx (inc next-idx)) | |
785 | next-idx))) | |
786 | ||
787 | (defn persistent-value? | |
788 | "Returns true if this value should be saved in the state hash map" | |
789 | [index value] | |
790 | (or (not= (-> index value :read-in) | |
791 | (-> index value :written-in)) | |
792 | (-> index value :read-in count (> 1)))) | |
793 | ||
794 | (defn count-persistent-values | |
795 | [index] | |
796 | (->> (keys index) | |
797 | (filter instruction?) | |
798 | (filter (partial persistent-value? index)) | |
799 | count)) | |
800 | ||
801 | (defn- build-block-preamble [local-map idx state-sym blk] | |
802 | (let [args (->> (mapcat reads-from blk) | |
803 | (filter instruction?) | |
804 | (filter (partial persistent-value? idx)) | |
805 | set | |
806 | vec)] | |
807 | (if (empty? args) | |
808 | [] | |
809 | (mapcat (fn [sym] | |
810 | `[~sym (aget ~state-sym ~(id-for-inst local-map sym))]) | |
811 | args)))) | |
812 | ||
813 | (defn- build-block-body [state-sym blk] | |
814 | (mapcat | |
815 | #(emit-instruction % state-sym) | |
816 | (butlast blk))) | |
817 | ||
818 | (defn- build-new-state [local-map idx state-sym blk] | |
819 | (let [results (->> blk | |
820 | (mapcat writes-to) | |
821 | (filter instruction?) | |
822 | (filter (partial persistent-value? idx)) | |
823 | set | |
824 | vec) | |
825 | results (interleave (map (partial id-for-inst local-map) results) results)] | |
826 | (if-not (empty? results) | |
827 | `(aset-all! ~state-sym ~@results) | |
828 | state-sym))) | |
829 | ||
830 | (defn- emit-state-machine [machine num-user-params custom-terminators] | |
831 | (let [index (index-state-machine machine) | |
832 | state-sym (with-meta (gensym "state_") | |
833 | {:tag 'objects}) | |
834 | local-start-idx (+ num-user-params USER-START-IDX) | |
835 | state-arr-size (+ local-start-idx (count-persistent-values index)) | |
836 | local-map (atom {::next-idx local-start-idx}) | |
837 | block-catches (:block-catches machine) | |
838 | state-val-sym (gensym "state_val_")] | |
839 | `(let [switch# (fn [~state-sym] | |
840 | (let [~state-val-sym (aget ~state-sym ~STATE-IDX)] | |
841 | (cond | |
842 | ~@(mapcat | |
843 | (fn [[id blk]] | |
844 | [`(== ~state-val-sym ~id) | |
845 | `(let [~@(concat (build-block-preamble local-map index state-sym blk) | |
846 | (build-block-body state-sym blk)) | |
847 | ~state-sym ~(build-new-state local-map index state-sym blk)] | |
848 | ~(terminate-block (last blk) state-sym custom-terminators))]) | |
849 | (:blocks machine)))))] | |
850 | (fn state-machine# | |
851 | ([] (aset-all! (make-array ~state-arr-size) | |
852 | ~FN-IDX state-machine# | |
853 | ~STATE-IDX ~(:start-block machine))) | |
854 | ([~state-sym] | |
855 | (let [ret-value# (try (loop [] | |
856 | (let [result# (switch# ~state-sym)] | |
857 | (if (cljs.core/keyword-identical? result# :recur) | |
858 | (recur) | |
859 | result#))) | |
860 | (catch js/Object ex# | |
861 | (aset-all! ~state-sym ~CURRENT-EXCEPTION ex#) | |
862 | (cljs.core.async.impl.ioc-helpers/process-exception ~state-sym) | |
863 | :recur))] | |
864 | (if (cljs.core/keyword-identical? ret-value# :recur) | |
865 | (recur ~state-sym) | |
866 | ret-value#))))))) | |
867 | ||
868 | ||
869 | (def async-custom-terminators | |
870 | {'<! 'cljs.core.async.impl.ioc-helpers/take! | |
871 | 'cljs.core.async/<! 'cljs.core.async.impl.ioc-helpers/take! | |
872 | '>! 'cljs.core.async.impl.ioc-helpers/put! | |
873 | 'cljs.core.async/>! 'cljs.core.async.impl.ioc-helpers/put! | |
874 | 'alts! 'cljs.core.async/ioc-alts! | |
875 | 'cljs.core.async/alts! 'cljs.core.async/ioc-alts! | |
876 | :Return 'cljs.core.async.impl.ioc-helpers/return-chan}) | |
877 | ||
878 | ||
879 | (defn state-machine [body num-user-params env user-transitions] | |
880 | (-> (parse-to-state-machine body env user-transitions) | |
881 | second | |
882 | (emit-state-machine num-user-params user-transitions))) |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns cljs.core.async.impl.protocols) | |
9 | ||
10 | (def ^:const MAX-QUEUE-SIZE 1024) | |
11 | ||
12 | (defprotocol ReadPort | |
13 | (take! [port fn1-handler] "derefable val if taken, nil if take was enqueued")) | |
14 | ||
15 | (defprotocol WritePort | |
16 | (put! [port val fn1-handler] "derefable boolean (false if already closed) if handled, nil if put was enqueued. | |
17 | Must throw on nil val.")) | |
18 | ||
19 | (defprotocol Channel | |
20 | (close! [chan]) | |
21 | (closed? [chan])) | |
22 | ||
23 | (defprotocol Handler | |
24 | (active? [h] "returns true if has callback. Must work w/o lock") | |
25 | (blockable? [h] "returns true if this handler may be blocked, otherwise it must not block") | |
26 | #_(lock-id [h] "a unique id for lock acquisition order, 0 if no lock") | |
27 | (commit [h] "commit to fulfilling its end of the transfer, returns cb. Must be called within lock")) | |
28 | ||
29 | (defprotocol Buffer | |
30 | (full? [b] "returns true if buffer cannot accept put") | |
31 | (remove! [b] "remove and return next item from buffer, called under chan mutex") | |
32 | (add!* [b itm] "if room, add item to the buffer, returns b, called under chan mutex") | |
33 | (close-buf! [b] "called on chan closed under chan mutex, return ignored")) | |
34 | ||
35 | (defn add! | |
36 | ([b] b) | |
37 | ([b itm] | |
38 | (assert (not (nil? itm))) | |
39 | (add!* b itm))) | |
40 | ||
41 | ;; Defines a buffer that will never block (return true to full?) | |
42 | (defprotocol UnblockingBuffer) |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns cljs.core.async.impl.timers | |
9 | (:require [cljs.core.async.impl.protocols :as impl] | |
10 | [cljs.core.async.impl.channels :as channels] | |
11 | [cljs.core.async.impl.dispatch :as dispatch])) | |
12 | ||
13 | (def MAX_LEVEL 15) ;; 16 levels | |
14 | (def P (/ 1 2)) | |
15 | ||
16 | (defn random-level | |
17 | ([] (random-level 0)) | |
18 | ([level] | |
19 | (if (and (< (.random js/Math) P) | |
20 | (< level MAX_LEVEL)) | |
21 | (recur (inc level)) | |
22 | level))) | |
23 | ||
24 | (deftype SkipListNode [key ^:mutable val forward] | |
25 | ISeqable | |
26 | (-seq [coll] | |
27 | (list key val)) | |
28 | ||
29 | IPrintWithWriter | |
30 | (-pr-writer [coll writer opts] | |
31 | (pr-sequential-writer writer pr-writer "[" " " "]" opts coll))) | |
32 | ||
33 | (defn skip-list-node | |
34 | ([level] (skip-list-node nil nil level)) | |
35 | ([k v level] | |
36 | (let [arr (make-array (inc level))] | |
37 | (loop [i 0] | |
38 | (when (< i (alength arr)) | |
39 | (aset arr i nil) | |
40 | (recur (inc i)))) | |
41 | (SkipListNode. k v arr)))) | |
42 | ||
43 | (defn least-greater-node | |
44 | ([x k level] (least-greater-node x k level nil)) | |
45 | ([x k level update] | |
46 | (if-not (neg? level) | |
47 | (let [x (loop [x x] | |
48 | (if-let [x' (aget (.-forward x) level)] | |
49 | (if (< (.-key x') k) | |
50 | (recur x') | |
51 | x) | |
52 | x))] | |
53 | (when-not (nil? update) | |
54 | (aset update level x)) | |
55 | (recur x k (dec level) update)) | |
56 | x))) | |
57 | ||
58 | (deftype SkipList [header ^:mutable level] | |
59 | Object | |
60 | (put [coll k v] | |
61 | (let [update (make-array MAX_LEVEL) | |
62 | x (least-greater-node header k level update) | |
63 | x (aget (.-forward x) 0)] | |
64 | (if (and (not (nil? x)) (== (.-key x) k)) | |
65 | (set! (.-val x) v) | |
66 | (let [new-level (random-level)] | |
67 | (when (> new-level level) | |
68 | (loop [i (inc level)] | |
69 | (when (<= i (inc new-level)) | |
70 | (aset update i header) | |
71 | (recur (inc i)))) | |
72 | (set! level new-level)) | |
73 | (let [x (skip-list-node k v (make-array new-level))] | |
74 | (loop [i 0] | |
75 | (when (<= i level) | |
76 | (let [links (.-forward (aget update i))] | |
77 | (aset (.-forward x) i (aget links i)) | |
78 | (aset links i x))))))))) | |
79 | ||
80 | (remove [coll k] | |
81 | (let [update (make-array MAX_LEVEL) | |
82 | x (least-greater-node header k level update) | |
83 | x (aget (.-forward x) 0)] | |
84 | (when (and (not (nil? x)) (== (.-key x) k)) | |
85 | (loop [i 0] | |
86 | (when (<= i level) | |
87 | (let [links (.-forward (aget update i))] | |
88 | (if (identical? (aget links i) x) | |
89 | (do | |
90 | (aset links i (aget (.-forward x) i)) | |
91 | (recur (inc i))) | |
92 | (recur (inc i)))))) | |
93 | (while (and (> level 0) | |
94 | (nil? (aget (.-forward header) level))) | |
95 | (set! level (dec level)))))) | |
96 | ||
97 | (ceilingEntry [coll k] | |
98 | (loop [x header level level] | |
99 | (if-not (neg? level) | |
100 | (let [nx (loop [x x] | |
101 | (let [x' (aget (.-forward x) level)] | |
102 | (when-not (nil? x') | |
103 | (if (>= (.-key x') k) | |
104 | x' | |
105 | (recur x')))))] | |
106 | (if-not (nil? nx) | |
107 | (recur nx (dec level)) | |
108 | (recur x (dec level)))) | |
109 | (when-not (identical? x header) | |
110 | x)))) | |
111 | ||
112 | (floorEntry [coll k] | |
113 | (loop [x header level level] | |
114 | (if-not (neg? level) | |
115 | (let [nx (loop [x x] | |
116 | (let [x' (aget (.-forward x) level)] | |
117 | (if-not (nil? x') | |
118 | (if (> (.-key x') k) | |
119 | x | |
120 | (recur x')) | |
121 | (when (zero? level) | |
122 | x))))] | |
123 | (if nx | |
124 | (recur nx (dec level)) | |
125 | (recur x (dec level)))) | |
126 | (when-not (identical? x header) | |
127 | x)))) | |
128 | ||
129 | ISeqable | |
130 | (-seq [coll] | |
131 | (letfn [(iter [node] | |
132 | (lazy-seq | |
133 | (when-not (nil? node) | |
134 | (cons [(.-key node) (.-val node)] | |
135 | (iter (aget (.-forward node) 0))))))] | |
136 | (iter (aget (.-forward header) 0)))) | |
137 | ||
138 | IPrintWithWriter | |
139 | (-pr-writer [coll writer opts] | |
140 | (let [pr-pair (fn [keyval] | |
141 | (pr-sequential-writer writer pr-writer "" " " "" opts keyval))] | |
142 | (pr-sequential-writer writer pr-pair "{" ", " "}" opts coll)))) | |
143 | ||
144 | (defn skip-list [] | |
145 | (SkipList. (skip-list-node 0) 0)) | |
146 | ||
147 | (def timeouts-map (skip-list)) | |
148 | ||
149 | (def TIMEOUT_RESOLUTION_MS 10) | |
150 | ||
151 | (defn timeout | |
152 | "returns a channel that will close after msecs" | |
153 | [msecs] | |
154 | (let [timeout (+ (.valueOf (js/Date.)) msecs) | |
155 | me (.ceilingEntry timeouts-map timeout)] | |
156 | (or (when (and me (< (.-key me) (+ timeout TIMEOUT_RESOLUTION_MS))) | |
157 | (.-val me)) | |
158 | (let [timeout-channel (channels/chan nil)] | |
159 | (.put timeouts-map timeout timeout-channel) | |
160 | (dispatch/queue-delay | |
161 | (fn [] | |
162 | (.remove timeouts-map timeout) | |
163 | (impl/close! timeout-channel)) | |
164 | msecs) | |
165 | timeout-channel)))) | |
166 |
0 | (ns cljs.core.async.macros | |
1 | (:require [cljs.core.async.impl.ioc-macros :as ioc])) | |
2 | ||
3 | (defmacro go | |
4 | "Asynchronously executes the body, returning immediately to the | |
5 | calling thread. Additionally, any visible calls to <!, >! and alt!/alts! | |
6 | channel operations within the body will block (if necessary) by | |
7 | 'parking' the calling thread rather than tying up an OS thread (or | |
8 | the only JS thread when in ClojureScript). Upon completion of the | |
9 | operation, the body will be resumed. | |
10 | ||
11 | Returns a channel which will receive the result of the body when | |
12 | completed" | |
13 | [& body] | |
14 | `(let [c# (cljs.core.async/chan 1)] | |
15 | (cljs.core.async.impl.dispatch/run | |
16 | (fn [] | |
17 | (let [f# ~(ioc/state-machine body 1 &env ioc/async-custom-terminators) | |
18 | state# (-> (f#) | |
19 | (ioc/aset-all! cljs.core.async.impl.ioc-helpers/USER-START-IDX c#))] | |
20 | (cljs.core.async.impl.ioc-helpers/run-state-machine-wrapped state#)))) | |
21 | c#)) | |
22 | ||
23 | ||
24 | (defn do-alt [alts clauses] | |
25 | (assert (even? (count clauses)) "unbalanced clauses") | |
26 | (let [clauses (partition 2 clauses) | |
27 | opt? #(keyword? (first %)) | |
28 | opts (filter opt? clauses) | |
29 | clauses (remove opt? clauses) | |
30 | [clauses bindings] | |
31 | (reduce | |
32 | (fn [[clauses bindings] [ports expr]] | |
33 | (let [ports (if (vector? ports) ports [ports]) | |
34 | [ports bindings] | |
35 | (reduce | |
36 | (fn [[ports bindings] port] | |
37 | (if (vector? port) | |
38 | (let [[port val] port | |
39 | gp (gensym) | |
40 | gv (gensym)] | |
41 | [(conj ports [gp gv]) (conj bindings [gp port] [gv val])]) | |
42 | (let [gp (gensym)] | |
43 | [(conj ports gp) (conj bindings [gp port])]))) | |
44 | [[] bindings] ports)] | |
45 | [(conj clauses [ports expr]) bindings])) | |
46 | [[] []] clauses) | |
47 | gch (gensym "ch") | |
48 | gret (gensym "ret")] | |
49 | `(let [~@(mapcat identity bindings) | |
50 | [val# ~gch :as ~gret] (~alts [~@(apply concat (map first clauses))] ~@(apply concat opts))] | |
51 | (cond | |
52 | ~@(mapcat (fn [[ports expr]] | |
53 | [`(or ~@(map (fn [port] | |
54 | `(= ~gch ~(if (vector? port) (first port) port))) | |
55 | ports)) | |
56 | (if (and (seq? expr) (vector? (first expr))) | |
57 | `(let [~(first expr) ~gret] ~@(rest expr)) | |
58 | expr)]) | |
59 | clauses) | |
60 | (= ~gch :default) val#)))) | |
61 | ||
62 | (defmacro alt! | |
63 | "Makes a single choice between one of several channel operations, | |
64 | as if by alts!, returning the value of the result expr corresponding | |
65 | to the operation completed. Must be called inside a (go ...) block. | |
66 | ||
67 | Each clause takes the form of: | |
68 | ||
69 | channel-op[s] result-expr | |
70 | ||
71 | where channel-ops is one of: | |
72 | ||
73 | take-port - a single port to take | |
74 | [take-port | [put-port put-val] ...] - a vector of ports as per alts! | |
75 | :default | :priority - an option for alts! | |
76 | ||
77 | and result-expr is either a list beginning with a vector, whereupon that | |
78 | vector will be treated as a binding for the [val port] return of the | |
79 | operation, else any other expression. | |
80 | ||
81 | (alt! | |
82 | [c t] ([val ch] (foo ch val)) | |
83 | x ([v] v) | |
84 | [[out val]] :wrote | |
85 | :default 42) | |
86 | ||
87 | Each option may appear at most once. The choice and parking | |
88 | characteristics are those of alts!." | |
89 | ||
90 | [& clauses] | |
91 | (do-alt 'alts! clauses)) | |
92 | ||
93 | ||
94 | (defmacro go-loop | |
95 | "Like (go (loop ...))" | |
96 | [bindings & body] | |
97 | `(go (loop ~bindings ~@body))) |
0 | (ns cljs.core.async | |
1 | (:refer-clojure :exclude [reduce transduce into merge map take partition partition-by]) | |
2 | (:require [cljs.core.async.impl.protocols :as impl] | |
3 | [cljs.core.async.impl.channels :as channels] | |
4 | [cljs.core.async.impl.buffers :as buffers] | |
5 | [cljs.core.async.impl.timers :as timers] | |
6 | [cljs.core.async.impl.dispatch :as dispatch] | |
7 | [cljs.core.async.impl.ioc-helpers :as helpers]) | |
8 | (:require-macros [cljs.core.async.impl.ioc-macros :as ioc] | |
9 | [cljs.core.async.macros :refer [go go-loop]])) | |
10 | ||
11 | (defn- fn-handler | |
12 | ([f] (fn-handler f true)) | |
13 | ([f blockable] | |
14 | (reify | |
15 | impl/Handler | |
16 | (active? [_] true) | |
17 | (blockable? [_] blockable) | |
18 | (commit [_] f)))) | |
19 | ||
20 | (defn buffer | |
21 | "Returns a fixed buffer of size n. When full, puts will block/park." | |
22 | [n] | |
23 | (buffers/fixed-buffer n)) | |
24 | ||
25 | (defn dropping-buffer | |
26 | "Returns a buffer of size n. When full, puts will complete but | |
27 | val will be dropped (no transfer)." | |
28 | [n] | |
29 | (buffers/dropping-buffer n)) | |
30 | ||
31 | (defn sliding-buffer | |
32 | "Returns a buffer of size n. When full, puts will complete, and be | |
33 | buffered, but oldest elements in buffer will be dropped (not | |
34 | transferred)." | |
35 | [n] | |
36 | (buffers/sliding-buffer n)) | |
37 | ||
38 | (defn unblocking-buffer? | |
39 | "Returns true if a channel created with buff will never block. That is to say, | |
40 | puts into this buffer will never cause the buffer to be full. " | |
41 | [buff] | |
42 | (satisfies? impl/UnblockingBuffer buff)) | |
43 | ||
44 | (defn chan | |
45 | "Creates a channel with an optional buffer, an optional transducer (like (map f), | |
46 | (filter p) etc or a composition thereof), and an optional exception handler. | |
47 | If buf-or-n is a number, will create and use a fixed buffer of that size. If a | |
48 | transducer is supplied a buffer must be specified. ex-handler must be a | |
49 | fn of one argument - if an exception occurs during transformation it will be called | |
50 | with the thrown value as an argument, and any non-nil return value will be placed | |
51 | in the channel." | |
52 | ([] (chan nil)) | |
53 | ([buf-or-n] (chan buf-or-n nil nil)) | |
54 | ([buf-or-n xform] (chan buf-or-n xform nil)) | |
55 | ([buf-or-n xform ex-handler] | |
56 | (let [buf-or-n (if (= buf-or-n 0) | |
57 | nil | |
58 | buf-or-n)] | |
59 | (when xform (assert buf-or-n "buffer must be supplied when transducer is")) | |
60 | (channels/chan (if (number? buf-or-n) | |
61 | (buffer buf-or-n) | |
62 | buf-or-n) | |
63 | xform | |
64 | ex-handler)))) | |
65 | ||
66 | (defn promise-chan | |
67 | "Creates a promise channel with an optional transducer, and an optional | |
68 | exception-handler. A promise channel can take exactly one value that consumers | |
69 | will receive. Once full, puts complete but val is dropped (no transfer). | |
70 | Consumers will block until either a value is placed in the channel or the | |
71 | channel is closed. See chan for the semantics of xform and ex-handler." | |
72 | ([] (promise-chan nil)) | |
73 | ([xform] (promise-chan xform nil)) | |
74 | ([xform ex-handler] | |
75 | (chan (buffers/promise-buffer) xform ex-handler))) | |
76 | ||
77 | (defn timeout | |
78 | "Returns a channel that will close after msecs" | |
79 | [msecs] | |
80 | (timers/timeout msecs)) | |
81 | ||
82 | (defn <! | |
83 | "takes a val from port. Must be called inside a (go ...) block. Will | |
84 | return nil if closed. Will park if nothing is available. | |
85 | Returns true unless port is already closed" | |
86 | [port] | |
87 | (throw (js/Error. "<! used not in (go ...) block"))) | |
88 | ||
89 | (defn take! | |
90 | "Asynchronously takes a val from port, passing to fn1. Will pass nil | |
91 | if closed. If on-caller? (default true) is true, and value is | |
92 | immediately available, will call fn1 on calling thread. | |
93 | Returns nil." | |
94 | ([port fn1] (take! port fn1 true)) | |
95 | ([port fn1 on-caller?] | |
96 | (let [ret (impl/take! port (fn-handler fn1))] | |
97 | (when ret | |
98 | (let [val @ret] | |
99 | (if on-caller? | |
100 | (fn1 val) | |
101 | (dispatch/run #(fn1 val))))) | |
102 | nil))) | |
103 | ||
104 | (defn- nop [_]) | |
105 | (def ^:private fhnop (fn-handler nop)) | |
106 | ||
107 | (defn >! | |
108 | "puts a val into port. nil values are not allowed. Must be called | |
109 | inside a (go ...) block. Will park if no buffer space is available. | |
110 | Returns true unless port is already closed." | |
111 | [port val] | |
112 | (throw (js/Error. ">! used not in (go ...) block"))) | |
113 | ||
114 | (defn put! | |
115 | "Asynchronously puts a val into port, calling fn0 (if supplied) when | |
116 | complete. nil values are not allowed. Will throw if closed. If | |
117 | on-caller? (default true) is true, and the put is immediately | |
118 | accepted, will call fn0 on calling thread. Returns nil." | |
119 | ([port val] | |
120 | (if-let [ret (impl/put! port val fhnop)] | |
121 | @ret | |
122 | true)) | |
123 | ([port val fn1] (put! port val fn1 true)) | |
124 | ([port val fn1 on-caller?] | |
125 | (if-let [retb (impl/put! port val (fn-handler fn1))] | |
126 | (let [ret @retb] | |
127 | (if on-caller? | |
128 | (fn1 ret) | |
129 | (dispatch/run #(fn1 ret))) | |
130 | ret) | |
131 | true))) | |
132 | ||
133 | (defn close! | |
134 | ([port] | |
135 | (impl/close! port))) | |
136 | ||
137 | ||
138 | (defn- random-array | |
139 | [n] | |
140 | (let [a (make-array n)] | |
141 | (dotimes [x n] | |
142 | (aset a x 0)) | |
143 | (loop [i 1] | |
144 | (if (= i n) | |
145 | a | |
146 | (do | |
147 | (let [j (rand-int i)] | |
148 | (aset a i (aget a j)) | |
149 | (aset a j i) | |
150 | (recur (inc i)))))))) | |
151 | ||
152 | (defn- alt-flag [] | |
153 | (let [flag (atom true)] | |
154 | (reify | |
155 | impl/Handler | |
156 | (active? [_] @flag) | |
157 | (blockable? [_] true) | |
158 | (commit [_] | |
159 | (reset! flag nil) | |
160 | true)))) | |
161 | ||
162 | (defn- alt-handler [flag cb] | |
163 | (reify | |
164 | impl/Handler | |
165 | (active? [_] (impl/active? flag)) | |
166 | (blockable? [_] true) | |
167 | (commit [_] | |
168 | (impl/commit flag) | |
169 | cb))) | |
170 | ||
171 | (defn do-alts | |
172 | "returns derefable [val port] if immediate, nil if enqueued" | |
173 | [fret ports opts] | |
174 | (let [flag (alt-flag) | |
175 | n (count ports) | |
176 | idxs (random-array n) | |
177 | priority (:priority opts) | |
178 | ret | |
179 | (loop [i 0] | |
180 | (when (< i n) | |
181 | (let [idx (if priority i (aget idxs i)) | |
182 | port (nth ports idx) | |
183 | wport (when (vector? port) (port 0)) | |
184 | vbox (if wport | |
185 | (let [val (port 1)] | |
186 | (impl/put! wport val (alt-handler flag #(fret [% wport])))) | |
187 | (impl/take! port (alt-handler flag #(fret [% port]))))] | |
188 | (if vbox | |
189 | (channels/box [@vbox (or wport port)]) | |
190 | (recur (inc i))))))] | |
191 | (or | |
192 | ret | |
193 | (when (contains? opts :default) | |
194 | (when-let [got (and (impl/active? flag) (impl/commit flag))] | |
195 | (channels/box [(:default opts) :default])))))) | |
196 | ||
197 | (defn alts! | |
198 | "Completes at most one of several channel operations. Must be called | |
199 | inside a (go ...) block. ports is a vector of channel endpoints, | |
200 | which can be either a channel to take from or a vector of | |
201 | [channel-to-put-to val-to-put], in any combination. Takes will be | |
202 | made as if by <!, and puts will be made as if by >!. Unless | |
203 | the :priority option is true, if more than one port operation is | |
204 | ready a non-deterministic choice will be made. If no operation is | |
205 | ready and a :default value is supplied, [default-val :default] will | |
206 | be returned, otherwise alts! will park until the first operation to | |
207 | become ready completes. Returns [val port] of the completed | |
208 | operation, where val is the value taken for takes, and a | |
209 | boolean (true unless already closed, as per put!) for puts. | |
210 | ||
211 | opts are passed as :key val ... Supported options: | |
212 | ||
213 | :default val - the value to use if none of the operations are immediately ready | |
214 | :priority true - (default nil) when true, the operations will be tried in order. | |
215 | ||
216 | Note: there is no guarantee that the port exps or val exprs will be | |
217 | used, nor in what order should they be, so they should not be | |
218 | depended upon for side effects." | |
219 | ||
220 | [ports & {:as opts}] | |
221 | (throw (js/Error. "alts! used not in (go ...) block"))) | |
222 | ||
223 | (defn offer! | |
224 | "Puts a val into port if it's possible to do so immediately. | |
225 | nil values are not allowed. Never blocks. Returns true if offer succeeds." | |
226 | [port val] | |
227 | (let [ret (impl/put! port val (fn-handler nop false))] | |
228 | (when ret @ret))) | |
229 | ||
230 | (defn poll! | |
231 | "Takes a val from port if it's possible to do so immediately. | |
232 | Never blocks. Returns value if successful, nil otherwise." | |
233 | [port] | |
234 | (let [ret (impl/take! port (fn-handler nop false))] | |
235 | (when ret @ret))) | |
236 | ||
237 | ;;;;;;; channel ops | |
238 | ||
239 | (defn pipe | |
240 | "Takes elements from the from channel and supplies them to the to | |
241 | channel. By default, the to channel will be closed when the from | |
242 | channel closes, but can be determined by the close? parameter. Will | |
243 | stop consuming the from channel if the to channel closes" | |
244 | ||
245 | ([from to] (pipe from to true)) | |
246 | ([from to close?] | |
247 | (go-loop [] | |
248 | (let [v (<! from)] | |
249 | (if (nil? v) | |
250 | (when close? (close! to)) | |
251 | (when (>! to v) | |
252 | (recur))))) | |
253 | to)) | |
254 | ||
255 | (defn- pipeline* | |
256 | ([n to xf from close? ex-handler type] | |
257 | (assert (pos? n)) | |
258 | (let [jobs (chan n) | |
259 | results (chan n) | |
260 | process (fn [[v p :as job]] | |
261 | (if (nil? job) | |
262 | (do (close! results) nil) | |
263 | (let [res (chan 1 xf ex-handler)] | |
264 | (go | |
265 | (>! res v) | |
266 | (close! res)) | |
267 | (put! p res) | |
268 | true))) | |
269 | async (fn [[v p :as job]] | |
270 | (if (nil? job) | |
271 | (do (close! results) nil) | |
272 | (let [res (chan 1)] | |
273 | (xf v res) | |
274 | (put! p res) | |
275 | true)))] | |
276 | (dotimes [_ n] | |
277 | (case type | |
278 | :compute (go-loop [] | |
279 | (let [job (<! jobs)] | |
280 | (when (process job) | |
281 | (recur)))) | |
282 | :async (go-loop [] | |
283 | (let [job (<! jobs)] | |
284 | (when (async job) | |
285 | (recur)))))) | |
286 | (go-loop [] | |
287 | (let [v (<! from)] | |
288 | (if (nil? v) | |
289 | (close! jobs) | |
290 | (let [p (chan 1)] | |
291 | (>! jobs [v p]) | |
292 | (>! results p) | |
293 | (recur))))) | |
294 | (go-loop [] | |
295 | (let [p (<! results)] | |
296 | (if (nil? p) | |
297 | (when close? (close! to)) | |
298 | (let [res (<! p)] | |
299 | (loop [] | |
300 | (let [v (<! res)] | |
301 | (when (and (not (nil? v)) (>! to v)) | |
302 | (recur)))) | |
303 | (recur)))))))) | |
304 | ||
305 | (defn pipeline-async | |
306 | "Takes elements from the from channel and supplies them to the to | |
307 | channel, subject to the async function af, with parallelism n. af | |
308 | must be a function of two arguments, the first an input value and | |
309 | the second a channel on which to place the result(s). af must close! | |
310 | the channel before returning. The presumption is that af will | |
311 | return immediately, having launched some asynchronous operation | |
312 | whose completion/callback will manipulate the result channel. Outputs | |
313 | will be returned in order relative to the inputs. By default, the to | |
314 | channel will be closed when the from channel closes, but can be | |
315 | determined by the close? parameter. Will stop consuming the from | |
316 | channel if the to channel closes." | |
317 | ([n to af from] (pipeline-async n to af from true)) | |
318 | ([n to af from close?] (pipeline* n to af from close? nil :async))) | |
319 | ||
320 | (defn pipeline | |
321 | "Takes elements from the from channel and supplies them to the to | |
322 | channel, subject to the transducer xf, with parallelism n. Because | |
323 | it is parallel, the transducer will be applied independently to each | |
324 | element, not across elements, and may produce zero or more outputs | |
325 | per input. Outputs will be returned in order relative to the | |
326 | inputs. By default, the to channel will be closed when the from | |
327 | channel closes, but can be determined by the close? parameter. Will | |
328 | stop consuming the from channel if the to channel closes. | |
329 | ||
330 | Note this is supplied for API compatibility with the Clojure version. | |
331 | Values of N > 1 will not result in actual concurrency in a | |
332 | single-threaded runtime." | |
333 | ([n to xf from] (pipeline n to xf from true)) | |
334 | ([n to xf from close?] (pipeline n to xf from close? nil)) | |
335 | ([n to xf from close? ex-handler] (pipeline* n to xf from close? ex-handler :compute))) | |
336 | ||
337 | (defn split | |
338 | "Takes a predicate and a source channel and returns a vector of two | |
339 | channels, the first of which will contain the values for which the | |
340 | predicate returned true, the second those for which it returned | |
341 | false. | |
342 | ||
343 | The out channels will be unbuffered by default, or two buf-or-ns can | |
344 | be supplied. The channels will close after the source channel has | |
345 | closed." | |
346 | ([p ch] (split p ch nil nil)) | |
347 | ([p ch t-buf-or-n f-buf-or-n] | |
348 | (let [tc (chan t-buf-or-n) | |
349 | fc (chan f-buf-or-n)] | |
350 | (go-loop [] | |
351 | (let [v (<! ch)] | |
352 | (if (nil? v) | |
353 | (do (close! tc) (close! fc)) | |
354 | (when (>! (if (p v) tc fc) v) | |
355 | (recur))))) | |
356 | [tc fc]))) | |
357 | ||
358 | (defn reduce | |
359 | "f should be a function of 2 arguments. Returns a channel containing | |
360 | the single result of applying f to init and the first item from the | |
361 | channel, then applying f to that result and the 2nd item, etc. If | |
362 | the channel closes without yielding items, returns init and f is not | |
363 | called. ch must close before reduce produces a result." | |
364 | [f init ch] | |
365 | (go-loop [ret init] | |
366 | (let [v (<! ch)] | |
367 | (if (nil? v) | |
368 | ret | |
369 | (let [ret' (f ret v)] | |
370 | (if (reduced? ret') | |
371 | @ret' | |
372 | (recur ret'))))))) | |
373 | ||
374 | (defn transduce | |
375 | "async/reduces a channel with a transformation (xform f). | |
376 | Returns a channel containing the result. ch must close before | |
377 | transduce produces a result." | |
378 | [xform f init ch] | |
379 | (let [f (xform f)] | |
380 | (go | |
381 | (let [ret (<! (reduce f init ch))] | |
382 | (f ret))))) | |
383 | ||
384 | (defn onto-chan | |
385 | "Puts the contents of coll into the supplied channel. | |
386 | ||
387 | By default the channel will be closed after the items are copied, | |
388 | but can be determined by the close? parameter. | |
389 | ||
390 | Returns a channel which will close after the items are copied." | |
391 | ([ch coll] (onto-chan ch coll true)) | |
392 | ([ch coll close?] | |
393 | (go-loop [vs (seq coll)] | |
394 | (if (and vs (>! ch (first vs))) | |
395 | (recur (next vs)) | |
396 | (when close? | |
397 | (close! ch)))))) | |
398 | ||
399 | ||
400 | (defn to-chan | |
401 | "Creates and returns a channel which contains the contents of coll, | |
402 | closing when exhausted." | |
403 | [coll] | |
404 | (let [ch (chan (bounded-count 100 coll))] | |
405 | (onto-chan ch coll) | |
406 | ch)) | |
407 | ||
408 | ||
409 | (defprotocol Mux | |
410 | (muxch* [_])) | |
411 | ||
412 | (defprotocol Mult | |
413 | (tap* [m ch close?]) | |
414 | (untap* [m ch]) | |
415 | (untap-all* [m])) | |
416 | ||
417 | (defn mult | |
418 | "Creates and returns a mult(iple) of the supplied channel. Channels | |
419 | containing copies of the channel can be created with 'tap', and | |
420 | detached with 'untap'. | |
421 | ||
422 | Each item is distributed to all taps in parallel and synchronously, | |
423 | i.e. each tap must accept before the next item is distributed. Use | |
424 | buffering/windowing to prevent slow taps from holding up the mult. | |
425 | ||
426 | Items received when there are no taps get dropped. | |
427 | ||
428 | If a tap puts to a closed channel, it will be removed from the mult." | |
429 | [ch] | |
430 | (let [cs (atom {}) ;;ch->close? | |
431 | m (reify | |
432 | Mux | |
433 | (muxch* [_] ch) | |
434 | ||
435 | Mult | |
436 | (tap* [_ ch close?] (swap! cs assoc ch close?) nil) | |
437 | (untap* [_ ch] (swap! cs dissoc ch) nil) | |
438 | (untap-all* [_] (reset! cs {}) nil)) | |
439 | dchan (chan 1) | |
440 | dctr (atom nil) | |
441 | done (fn [_] (when (zero? (swap! dctr dec)) | |
442 | (put! dchan true)))] | |
443 | (go-loop [] | |
444 | (let [val (<! ch)] | |
445 | (if (nil? val) | |
446 | (doseq [[c close?] @cs] | |
447 | (when close? (close! c))) | |
448 | (let [chs (keys @cs)] | |
449 | (reset! dctr (count chs)) | |
450 | (doseq [c chs] | |
451 | (when-not (put! c val done) | |
452 | (done nil) | |
453 | (untap* m c))) | |
454 | ;;wait for all | |
455 | (when (seq chs) | |
456 | (<! dchan)) | |
457 | (recur))))) | |
458 | m)) | |
459 | ||
460 | (defn tap | |
461 | "Copies the mult source onto the supplied channel. | |
462 | ||
463 | By default the channel will be closed when the source closes, | |
464 | but can be determined by the close? parameter." | |
465 | ([mult ch] (tap mult ch true)) | |
466 | ([mult ch close?] (tap* mult ch close?) ch)) | |
467 | ||
468 | (defn untap | |
469 | "Disconnects a target channel from a mult" | |
470 | [mult ch] | |
471 | (untap* mult ch)) | |
472 | ||
473 | (defn untap-all | |
474 | "Disconnects all target channels from a mult" | |
475 | [mult] (untap-all* mult)) | |
476 | ||
477 | (defprotocol Mix | |
478 | (admix* [m ch]) | |
479 | (unmix* [m ch]) | |
480 | (unmix-all* [m]) | |
481 | (toggle* [m state-map]) | |
482 | (solo-mode* [m mode])) | |
483 | ||
484 | (defn ioc-alts! [state cont-block ports & {:as opts}] | |
485 | (ioc/aset-all! state helpers/STATE-IDX cont-block) | |
486 | (when-let [cb (cljs.core.async/do-alts | |
487 | (fn [val] | |
488 | (ioc/aset-all! state helpers/VALUE-IDX val) | |
489 | (helpers/run-state-machine-wrapped state)) | |
490 | ports | |
491 | opts)] | |
492 | (ioc/aset-all! state helpers/VALUE-IDX @cb) | |
493 | :recur)) | |
494 | ||
495 | (defn mix | |
496 | "Creates and returns a mix of one or more input channels which will | |
497 | be put on the supplied out channel. Input sources can be added to | |
498 | the mix with 'admix', and removed with 'unmix'. A mix supports | |
499 | soloing, muting and pausing multiple inputs atomically using | |
500 | 'toggle', and can solo using either muting or pausing as determined | |
501 | by 'solo-mode'. | |
502 | ||
503 | Each channel can have zero or more boolean modes set via 'toggle': | |
504 | ||
505 | :solo - when true, only this (ond other soloed) channel(s) will appear | |
506 | in the mix output channel. :mute and :pause states of soloed | |
507 | channels are ignored. If solo-mode is :mute, non-soloed | |
508 | channels are muted, if :pause, non-soloed channels are | |
509 | paused. | |
510 | ||
511 | :mute - muted channels will have their contents consumed but not included in the mix | |
512 | :pause - paused channels will not have their contents consumed (and thus also not included in the mix) | |
513 | " | |
514 | [out] | |
515 | (let [cs (atom {}) ;;ch->attrs-map | |
516 | solo-modes #{:mute :pause} | |
517 | attrs (conj solo-modes :solo) | |
518 | solo-mode (atom :mute) | |
519 | change (chan) | |
520 | changed #(put! change true) | |
521 | pick (fn [attr chs] | |
522 | (reduce-kv | |
523 | (fn [ret c v] | |
524 | (if (attr v) | |
525 | (conj ret c) | |
526 | ret)) | |
527 | #{} chs)) | |
528 | calc-state (fn [] | |
529 | (let [chs @cs | |
530 | mode @solo-mode | |
531 | solos (pick :solo chs) | |
532 | pauses (pick :pause chs)] | |
533 | {:solos solos | |
534 | :mutes (pick :mute chs) | |
535 | :reads (conj | |
536 | (if (and (= mode :pause) (not (empty? solos))) | |
537 | (vec solos) | |
538 | (vec (remove pauses (keys chs)))) | |
539 | change)})) | |
540 | m (reify | |
541 | Mux | |
542 | (muxch* [_] out) | |
543 | Mix | |
544 | (admix* [_ ch] (swap! cs assoc ch {}) (changed)) | |
545 | (unmix* [_ ch] (swap! cs dissoc ch) (changed)) | |
546 | (unmix-all* [_] (reset! cs {}) (changed)) | |
547 | (toggle* [_ state-map] (swap! cs (partial merge-with cljs.core/merge) state-map) (changed)) | |
548 | (solo-mode* [_ mode] | |
549 | (assert (solo-modes mode) (str "mode must be one of: " solo-modes)) | |
550 | (reset! solo-mode mode) | |
551 | (changed)))] | |
552 | (go-loop [{:keys [solos mutes reads] :as state} (calc-state)] | |
553 | (let [[v c] (alts! reads)] | |
554 | (if (or (nil? v) (= c change)) | |
555 | (do (when (nil? v) | |
556 | (swap! cs dissoc c)) | |
557 | (recur (calc-state))) | |
558 | (if (or (solos c) | |
559 | (and (empty? solos) (not (mutes c)))) | |
560 | (when (>! out v) | |
561 | (recur state)) | |
562 | (recur state))))) | |
563 | m)) | |
564 | ||
565 | (defn admix | |
566 | "Adds ch as an input to the mix" | |
567 | [mix ch] | |
568 | (admix* mix ch)) | |
569 | ||
570 | (defn unmix | |
571 | "Removes ch as an input to the mix" | |
572 | [mix ch] | |
573 | (unmix* mix ch)) | |
574 | ||
575 | (defn unmix-all | |
576 | "removes all inputs from the mix" | |
577 | [mix] | |
578 | (unmix-all* mix)) | |
579 | ||
580 | (defn toggle | |
581 | "Atomically sets the state(s) of one or more channels in a mix. The | |
582 | state map is a map of channels -> channel-state-map. A | |
583 | channel-state-map is a map of attrs -> boolean, where attr is one or | |
584 | more of :mute, :pause or :solo. Any states supplied are merged with | |
585 | the current state. | |
586 | ||
587 | Note that channels can be added to a mix via toggle, which can be | |
588 | used to add channels in a particular (e.g. paused) state." | |
589 | [mix state-map] | |
590 | (toggle* mix state-map)) | |
591 | ||
592 | (defn solo-mode | |
593 | "Sets the solo mode of the mix. mode must be one of :mute or :pause" | |
594 | [mix mode] | |
595 | (solo-mode* mix mode)) | |
596 | ||
597 | ||
598 | (defprotocol Pub | |
599 | (sub* [p v ch close?]) | |
600 | (unsub* [p v ch]) | |
601 | (unsub-all* [p] [p v])) | |
602 | ||
603 | (defn pub | |
604 | "Creates and returns a pub(lication) of the supplied channel, | |
605 | partitioned into topics by the topic-fn. topic-fn will be applied to | |
606 | each value on the channel and the result will determine the 'topic' | |
607 | on which that value will be put. Channels can be subscribed to | |
608 | receive copies of topics using 'sub', and unsubscribed using | |
609 | 'unsub'. Each topic will be handled by an internal mult on a | |
610 | dedicated channel. By default these internal channels are | |
611 | unbuffered, but a buf-fn can be supplied which, given a topic, | |
612 | creates a buffer with desired properties. | |
613 | ||
614 | Each item is distributed to all subs in parallel and synchronously, | |
615 | i.e. each sub must accept before the next item is distributed. Use | |
616 | buffering/windowing to prevent slow subs from holding up the pub. | |
617 | ||
618 | Items received when there are no matching subs get dropped. | |
619 | ||
620 | Note that if buf-fns are used then each topic is handled | |
621 | asynchronously, i.e. if a channel is subscribed to more than one | |
622 | topic it should not expect them to be interleaved identically with | |
623 | the source." | |
624 | ([ch topic-fn] (pub ch topic-fn (constantly nil))) | |
625 | ([ch topic-fn buf-fn] | |
626 | (let [mults (atom {}) ;;topic->mult | |
627 | ensure-mult (fn [topic] | |
628 | (or (get @mults topic) | |
629 | (get (swap! mults | |
630 | #(if (% topic) % (assoc % topic (mult (chan (buf-fn topic)))))) | |
631 | topic))) | |
632 | p (reify | |
633 | Mux | |
634 | (muxch* [_] ch) | |
635 | ||
636 | Pub | |
637 | (sub* [p topic ch close?] | |
638 | (let [m (ensure-mult topic)] | |
639 | (tap m ch close?))) | |
640 | (unsub* [p topic ch] | |
641 | (when-let [m (get @mults topic)] | |
642 | (untap m ch))) | |
643 | (unsub-all* [_] (reset! mults {})) | |
644 | (unsub-all* [_ topic] (swap! mults dissoc topic)))] | |
645 | (go-loop [] | |
646 | (let [val (<! ch)] | |
647 | (if (nil? val) | |
648 | (doseq [m (vals @mults)] | |
649 | (close! (muxch* m))) | |
650 | (let [topic (topic-fn val) | |
651 | m (get @mults topic)] | |
652 | (when m | |
653 | (when-not (>! (muxch* m) val) | |
654 | (swap! mults dissoc topic))) | |
655 | (recur))))) | |
656 | p))) | |
657 | ||
658 | (defn sub | |
659 | "Subscribes a channel to a topic of a pub. | |
660 | ||
661 | By default the channel will be closed when the source closes, | |
662 | but can be determined by the close? parameter." | |
663 | ([p topic ch] (sub p topic ch true)) | |
664 | ([p topic ch close?] (sub* p topic ch close?))) | |
665 | ||
666 | (defn unsub | |
667 | "Unsubscribes a channel from a topic of a pub" | |
668 | [p topic ch] | |
669 | (unsub* p topic ch)) | |
670 | ||
671 | (defn unsub-all | |
672 | "Unsubscribes all channels from a pub, or a topic of a pub" | |
673 | ([p] (unsub-all* p)) | |
674 | ([p topic] (unsub-all* p topic))) | |
675 | ||
676 | ||
677 | ;;;; | |
678 | ||
679 | (defn map | |
680 | "Takes a function and a collection of source channels, and returns a | |
681 | channel which contains the values produced by applying f to the set | |
682 | of first items taken from each source channel, followed by applying | |
683 | f to the set of second items from each channel, until any one of the | |
684 | channels is closed, at which point the output channel will be | |
685 | closed. The returned channel will be unbuffered by default, or a | |
686 | buf-or-n can be supplied" | |
687 | ([f chs] (map f chs nil)) | |
688 | ([f chs buf-or-n] | |
689 | (let [chs (vec chs) | |
690 | out (chan buf-or-n) | |
691 | cnt (count chs) | |
692 | rets (object-array cnt) | |
693 | dchan (chan 1) | |
694 | dctr (atom nil) | |
695 | done (mapv (fn [i] | |
696 | (fn [ret] | |
697 | (aset rets i ret) | |
698 | (when (zero? (swap! dctr dec)) | |
699 | (put! dchan (.slice rets 0))))) | |
700 | (range cnt))] | |
701 | (go-loop [] | |
702 | (reset! dctr cnt) | |
703 | (dotimes [i cnt] | |
704 | (try | |
705 | (take! (chs i) (done i)) | |
706 | (catch js/Object e | |
707 | (swap! dctr dec)))) | |
708 | (let [rets (<! dchan)] | |
709 | (if (some nil? rets) | |
710 | (close! out) | |
711 | (do (>! out (apply f rets)) | |
712 | (recur))))) | |
713 | out))) | |
714 | ||
715 | (defn merge | |
716 | "Takes a collection of source channels and returns a channel which | |
717 | contains all values taken from them. The returned channel will be | |
718 | unbuffered by default, or a buf-or-n can be supplied. The channel | |
719 | will close after all the source channels have closed." | |
720 | ([chs] (merge chs nil)) | |
721 | ([chs buf-or-n] | |
722 | (let [out (chan buf-or-n)] | |
723 | (go-loop [cs (vec chs)] | |
724 | (if (pos? (count cs)) | |
725 | (let [[v c] (alts! cs)] | |
726 | (if (nil? v) | |
727 | (recur (filterv #(not= c %) cs)) | |
728 | (do (>! out v) | |
729 | (recur cs)))) | |
730 | (close! out))) | |
731 | out))) | |
732 | ||
733 | (defn into | |
734 | "Returns a channel containing the single (collection) result of the | |
735 | items taken from the channel conjoined to the supplied | |
736 | collection. ch must close before into produces a result." | |
737 | [coll ch] | |
738 | (reduce conj coll ch)) | |
739 | ||
740 | (defn take | |
741 | "Returns a channel that will return, at most, n items from ch. After n items | |
742 | have been returned, or ch has been closed, the return chanel will close. | |
743 | ||
744 | The output channel is unbuffered by default, unless buf-or-n is given." | |
745 | ([n ch] | |
746 | (take n ch nil)) | |
747 | ([n ch buf-or-n] | |
748 | (let [out (chan buf-or-n)] | |
749 | (go (loop [x 0] | |
750 | (when (< x n) | |
751 | (let [v (<! ch)] | |
752 | (when (not (nil? v)) | |
753 | (>! out v) | |
754 | (recur (inc x)))))) | |
755 | (close! out)) | |
756 | out))) | |
757 | ||
758 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; deprecated - do not use ;;;;;;;;;;;;;;;;;;;;;;;;; | |
759 | ||
760 | (defn map< | |
761 | "Deprecated - this function will be removed. Use transducer instead" | |
762 | [f ch] | |
763 | (reify | |
764 | impl/Channel | |
765 | (close! [_] (impl/close! ch)) | |
766 | (closed? [_] (impl/closed? ch)) | |
767 | ||
768 | impl/ReadPort | |
769 | (take! [_ fn1] | |
770 | (let [ret | |
771 | (impl/take! ch | |
772 | (reify | |
773 | impl/Handler | |
774 | (active? [_] (impl/active? fn1)) | |
775 | (blockable? [_] true) | |
776 | #_(lock-id [_] (impl/lock-id fn1)) | |
777 | (commit [_] | |
778 | (let [f1 (impl/commit fn1)] | |
779 | #(f1 (if (nil? %) nil (f %)))))))] | |
780 | (if (and ret (not (nil? @ret))) | |
781 | (channels/box (f @ret)) | |
782 | ret))) | |
783 | ||
784 | impl/WritePort | |
785 | (put! [_ val fn1] (impl/put! ch val fn1)))) | |
786 | ||
787 | (defn map> | |
788 | "Deprecated - this function will be removed. Use transducer instead" | |
789 | [f ch] | |
790 | (reify | |
791 | impl/Channel | |
792 | (close! [_] (impl/close! ch)) | |
793 | ||
794 | impl/ReadPort | |
795 | (take! [_ fn1] (impl/take! ch fn1)) | |
796 | ||
797 | impl/WritePort | |
798 | (put! [_ val fn1] | |
799 | (impl/put! ch (f val) fn1)))) | |
800 | ||
801 | (defn filter> | |
802 | "Deprecated - this function will be removed. Use transducer instead" | |
803 | [p ch] | |
804 | (reify | |
805 | impl/Channel | |
806 | (close! [_] (impl/close! ch)) | |
807 | (closed? [_] (impl/closed? ch)) | |
808 | ||
809 | impl/ReadPort | |
810 | (take! [_ fn1] (impl/take! ch fn1)) | |
811 | ||
812 | impl/WritePort | |
813 | (put! [_ val fn1] | |
814 | (if (p val) | |
815 | (impl/put! ch val fn1) | |
816 | (channels/box (not (impl/closed? ch))))))) | |
817 | ||
818 | (defn remove> | |
819 | "Deprecated - this function will be removed. Use transducer instead" | |
820 | [p ch] | |
821 | (filter> (complement p) ch)) | |
822 | ||
823 | (defn filter< | |
824 | "Deprecated - this function will be removed. Use transducer instead" | |
825 | ([p ch] (filter< p ch nil)) | |
826 | ([p ch buf-or-n] | |
827 | (let [out (chan buf-or-n)] | |
828 | (go-loop [] | |
829 | (let [val (<! ch)] | |
830 | (if (nil? val) | |
831 | (close! out) | |
832 | (do (when (p val) | |
833 | (>! out val)) | |
834 | (recur))))) | |
835 | out))) | |
836 | ||
837 | (defn remove< | |
838 | "Deprecated - this function will be removed. Use transducer instead" | |
839 | ([p ch] (remove< p ch nil)) | |
840 | ([p ch buf-or-n] (filter< (complement p) ch buf-or-n))) | |
841 | ||
842 | (defn- mapcat* [f in out] | |
843 | (go-loop [] | |
844 | (let [val (<! in)] | |
845 | (if (nil? val) | |
846 | (close! out) | |
847 | (do (doseq [v (f val)] | |
848 | (>! out v)) | |
849 | (when-not (impl/closed? out) | |
850 | (recur))))))) | |
851 | ||
852 | (defn mapcat< | |
853 | "Deprecated - this function will be removed. Use transducer instead" | |
854 | ([f in] (mapcat< f in nil)) | |
855 | ([f in buf-or-n] | |
856 | (let [out (chan buf-or-n)] | |
857 | (mapcat* f in out) | |
858 | out))) | |
859 | ||
860 | (defn mapcat> | |
861 | "Deprecated - this function will be removed. Use transducer instead" | |
862 | ([f out] (mapcat> f out nil)) | |
863 | ([f out buf-or-n] | |
864 | (let [in (chan buf-or-n)] | |
865 | (mapcat* f in out) | |
866 | in))) | |
867 | ||
868 | (defn unique | |
869 | "Deprecated - this function will be removed. Use transducer instead" | |
870 | ([ch] | |
871 | (unique ch nil)) | |
872 | ([ch buf-or-n] | |
873 | (let [out (chan buf-or-n)] | |
874 | (go (loop [last nil] | |
875 | (let [v (<! ch)] | |
876 | (when (not (nil? v)) | |
877 | (if (= v last) | |
878 | (recur last) | |
879 | (do (>! out v) | |
880 | (recur v)))))) | |
881 | (close! out)) | |
882 | out))) | |
883 | ||
884 | (defn partition | |
885 | "Deprecated - this function will be removed. Use transducer instead" | |
886 | ([n ch] | |
887 | (partition n ch nil)) | |
888 | ([n ch buf-or-n] | |
889 | (let [out (chan buf-or-n)] | |
890 | (go (loop [arr (make-array n) | |
891 | idx 0] | |
892 | (let [v (<! ch)] | |
893 | (if (not (nil? v)) | |
894 | (do (aset ^objects arr idx v) | |
895 | (let [new-idx (inc idx)] | |
896 | (if (< new-idx n) | |
897 | (recur arr new-idx) | |
898 | (do (>! out (vec arr)) | |
899 | (recur (make-array n) 0))))) | |
900 | (do (when (> idx 0) | |
901 | (>! out (vec arr))) | |
902 | (close! out)))))) | |
903 | out))) | |
904 | ||
905 | ||
906 | (defn partition-by | |
907 | "Deprecated - this function will be removed. Use transducer instead" | |
908 | ([f ch] | |
909 | (partition-by f ch nil)) | |
910 | ([f ch buf-or-n] | |
911 | (let [out (chan buf-or-n)] | |
912 | (go (loop [lst (make-array 0) | |
913 | last ::nothing] | |
914 | (let [v (<! ch)] | |
915 | (if (not (nil? v)) | |
916 | (let [new-itm (f v)] | |
917 | (if (or (= new-itm last) | |
918 | (keyword-identical? last ::nothing)) | |
919 | (do (.push lst v) | |
920 | (recur lst new-itm)) | |
921 | (do (>! out (vec lst)) | |
922 | (let [new-lst (make-array 0)] | |
923 | (.push new-lst v) | |
924 | (recur new-lst new-itm))))) | |
925 | (do (when (> (alength lst) 0) | |
926 | (>! out (vec lst))) | |
927 | (close! out)))))) | |
928 | out))) |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns ^{:skip-wiki true} | |
9 | clojure.core.async.impl.buffers | |
10 | (:require [clojure.core.async.impl.protocols :as impl]) | |
11 | (:import [java.util LinkedList Queue])) | |
12 | ||
13 | (set! *warn-on-reflection* true) | |
14 | ||
15 | (deftype FixedBuffer [^LinkedList buf ^long n] | |
16 | impl/Buffer | |
17 | (full? [this] | |
18 | (>= (.size buf) n)) | |
19 | (remove! [this] | |
20 | (.removeLast buf)) | |
21 | (add!* [this itm] | |
22 | (.addFirst buf itm) | |
23 | this) | |
24 | (close-buf! [this]) | |
25 | clojure.lang.Counted | |
26 | (count [this] | |
27 | (.size buf))) | |
28 | ||
29 | (defn fixed-buffer [^long n] | |
30 | (FixedBuffer. (LinkedList.) n)) | |
31 | ||
32 | ||
33 | (deftype DroppingBuffer [^LinkedList buf ^long n] | |
34 | impl/UnblockingBuffer | |
35 | impl/Buffer | |
36 | (full? [this] | |
37 | false) | |
38 | (remove! [this] | |
39 | (.removeLast buf)) | |
40 | (add!* [this itm] | |
41 | (when-not (>= (.size buf) n) | |
42 | (.addFirst buf itm)) | |
43 | this) | |
44 | (close-buf! [this]) | |
45 | clojure.lang.Counted | |
46 | (count [this] | |
47 | (.size buf))) | |
48 | ||
49 | (defn dropping-buffer [n] | |
50 | (DroppingBuffer. (LinkedList.) n)) | |
51 | ||
52 | (deftype SlidingBuffer [^LinkedList buf ^long n] | |
53 | impl/UnblockingBuffer | |
54 | impl/Buffer | |
55 | (full? [this] | |
56 | false) | |
57 | (remove! [this] | |
58 | (.removeLast buf)) | |
59 | (add!* [this itm] | |
60 | (when (= (.size buf) n) | |
61 | (impl/remove! this)) | |
62 | (.addFirst buf itm) | |
63 | this) | |
64 | (close-buf! [this]) | |
65 | clojure.lang.Counted | |
66 | (count [this] | |
67 | (.size buf))) | |
68 | ||
69 | (defn sliding-buffer [n] | |
70 | (SlidingBuffer. (LinkedList.) n)) | |
71 | ||
72 | (defonce ^:private NO-VAL (Object.)) | |
73 | (defn- undelivered? [val] | |
74 | (identical? NO-VAL val)) | |
75 | ||
76 | (deftype PromiseBuffer [^:unsynchronized-mutable val] | |
77 | impl/UnblockingBuffer | |
78 | impl/Buffer | |
79 | (full? [_] | |
80 | false) | |
81 | (remove! [_] | |
82 | val) | |
83 | (add!* [this itm] | |
84 | (when (undelivered? val) | |
85 | (set! val itm)) | |
86 | this) | |
87 | (close-buf! [_] | |
88 | (when (undelivered? val) | |
89 | (set! val nil))) | |
90 | clojure.lang.Counted | |
91 | (count [_] | |
92 | (if (undelivered? val) 0 1))) | |
93 | ||
94 | (defn promise-buffer [] | |
95 | (PromiseBuffer. NO-VAL))⏎ |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns ^{:skip-wiki true} | |
9 | clojure.core.async.impl.channels | |
10 | (:require [clojure.core.async.impl.protocols :as impl] | |
11 | [clojure.core.async.impl.dispatch :as dispatch] | |
12 | [clojure.core.async.impl.mutex :as mutex]) | |
13 | (:import [java.util LinkedList Queue Iterator] | |
14 | [java.util.concurrent.locks Lock])) | |
15 | ||
16 | (set! *warn-on-reflection* true) | |
17 | ||
18 | (defmacro assert-unlock [lock test msg] | |
19 | `(when-not ~test | |
20 | (.unlock ~lock) | |
21 | (throw (new AssertionError (str "Assert failed: " ~msg "\n" (pr-str '~test)))))) | |
22 | ||
23 | (defn box [val] | |
24 | (reify clojure.lang.IDeref | |
25 | (deref [_] val))) | |
26 | ||
27 | (defprotocol MMC | |
28 | (cleanup [_]) | |
29 | (abort [_])) | |
30 | ||
31 | (deftype ManyToManyChannel [^LinkedList takes ^LinkedList puts ^Queue buf closed ^Lock mutex add!] | |
32 | MMC | |
33 | (cleanup | |
34 | [_] | |
35 | (when-not (.isEmpty takes) | |
36 | (let [iter (.iterator takes)] | |
37 | (loop [taker (.next iter)] | |
38 | (when-not (impl/active? taker) | |
39 | (.remove iter)) | |
40 | (when (.hasNext iter) | |
41 | (recur (.next iter)))))) | |
42 | (when-not (.isEmpty puts) | |
43 | (let [iter (.iterator puts)] | |
44 | (loop [[putter] (.next iter)] | |
45 | (when-not (impl/active? putter) | |
46 | (.remove iter)) | |
47 | (when (.hasNext iter) | |
48 | (recur (.next iter))))))) | |
49 | ||
50 | (abort | |
51 | [this] | |
52 | (let [iter (.iterator puts)] | |
53 | (when (.hasNext iter) | |
54 | (loop [^Lock putter (.next iter)] | |
55 | (.lock putter) | |
56 | (let [put-cb (and (impl/active? putter) (impl/commit putter))] | |
57 | (.unlock putter) | |
58 | (when put-cb | |
59 | (dispatch/run (fn [] (put-cb true)))) | |
60 | (when (.hasNext iter) | |
61 | (recur (.next iter))))))) | |
62 | (.clear puts) | |
63 | (impl/close! this)) | |
64 | ||
65 | impl/WritePort | |
66 | (put! | |
67 | [this val handler] | |
68 | (when (nil? val) | |
69 | (throw (IllegalArgumentException. "Can't put nil on channel"))) | |
70 | (.lock mutex) | |
71 | (cleanup this) | |
72 | (if @closed | |
73 | (do (.unlock mutex) | |
74 | (box false)) | |
75 | (let [^Lock handler handler] | |
76 | (if (and buf (not (impl/full? buf)) (not (.isEmpty takes))) | |
77 | (do | |
78 | (.lock handler) | |
79 | (let [put-cb (and (impl/active? handler) (impl/commit handler))] | |
80 | (.unlock handler) | |
81 | (if put-cb | |
82 | (let [done? (reduced? (add! buf val))] | |
83 | (if (pos? (count buf)) | |
84 | (let [iter (.iterator takes) | |
85 | take-cbs (loop [takers []] | |
86 | (if (and (.hasNext iter) (pos? (count buf))) | |
87 | (let [^Lock taker (.next iter)] | |
88 | (.lock taker) | |
89 | (let [ret (and (impl/active? taker) (impl/commit taker))] | |
90 | (.unlock taker) | |
91 | (if ret | |
92 | (let [val (impl/remove! buf)] | |
93 | (.remove iter) | |
94 | (recur (conj takers (fn [] (ret val))))) | |
95 | (recur takers)))) | |
96 | takers))] | |
97 | (if (seq take-cbs) | |
98 | (do | |
99 | (when done? | |
100 | (abort this)) | |
101 | (.unlock mutex) | |
102 | (doseq [f take-cbs] | |
103 | (dispatch/run f))) | |
104 | (do | |
105 | (when done? | |
106 | (abort this)) | |
107 | (.unlock mutex)))) | |
108 | (do | |
109 | (when done? | |
110 | (abort this)) | |
111 | (.unlock mutex))) | |
112 | (box true)) | |
113 | (do (.unlock mutex) | |
114 | nil)))) | |
115 | (let [iter (.iterator takes) | |
116 | [put-cb take-cb] (when (.hasNext iter) | |
117 | (loop [^Lock taker (.next iter)] | |
118 | (if (< (impl/lock-id handler) (impl/lock-id taker)) | |
119 | (do (.lock handler) (.lock taker)) | |
120 | (do (.lock taker) (.lock handler))) | |
121 | (let [ret (when (and (impl/active? handler) (impl/active? taker)) | |
122 | [(impl/commit handler) (impl/commit taker)])] | |
123 | (.unlock handler) | |
124 | (.unlock taker) | |
125 | (if ret | |
126 | (do | |
127 | (.remove iter) | |
128 | ret) | |
129 | (when (.hasNext iter) | |
130 | (recur (.next iter)))))))] | |
131 | (if (and put-cb take-cb) | |
132 | (do | |
133 | (.unlock mutex) | |
134 | (dispatch/run (fn [] (take-cb val))) | |
135 | (box true)) | |
136 | (if (and buf (not (impl/full? buf))) | |
137 | (do | |
138 | (.lock handler) | |
139 | (let [put-cb (and (impl/active? handler) (impl/commit handler))] | |
140 | (.unlock handler) | |
141 | (if put-cb | |
142 | (let [done? (reduced? (add! buf val))] | |
143 | (when done? | |
144 | (abort this)) | |
145 | (.unlock mutex) | |
146 | (box true)) | |
147 | (do (.unlock mutex) | |
148 | nil)))) | |
149 | (do | |
150 | (when (and (impl/active? handler) (impl/blockable? handler)) | |
151 | (assert-unlock mutex | |
152 | (< (.size puts) impl/MAX-QUEUE-SIZE) | |
153 | (str "No more than " impl/MAX-QUEUE-SIZE | |
154 | " pending puts are allowed on a single channel." | |
155 | " Consider using a windowed buffer.")) | |
156 | (.add puts [handler val])) | |
157 | (.unlock mutex) | |
158 | nil)))))))) | |
159 | ||
160 | impl/ReadPort | |
161 | (take! | |
162 | [this handler] | |
163 | (.lock mutex) | |
164 | (cleanup this) | |
165 | (let [^Lock handler handler | |
166 | commit-handler (fn [] | |
167 | (.lock handler) | |
168 | (let [take-cb (and (impl/active? handler) (impl/commit handler))] | |
169 | (.unlock handler) | |
170 | take-cb))] | |
171 | (if (and buf (pos? (count buf))) | |
172 | (do | |
173 | (if-let [take-cb (commit-handler)] | |
174 | (let [val (impl/remove! buf) | |
175 | iter (.iterator puts) | |
176 | [done? cbs] | |
177 | (when (.hasNext iter) | |
178 | (loop [cbs [] | |
179 | [^Lock putter val] (.next iter)] | |
180 | (.lock putter) | |
181 | (let [cb (and (impl/active? putter) (impl/commit putter))] | |
182 | (.unlock putter) | |
183 | (.remove iter) | |
184 | (let [cbs (if cb (conj cbs cb) cbs) | |
185 | done? (when cb (reduced? (add! buf val)))] | |
186 | (if (and (not done?) (not (impl/full? buf)) (.hasNext iter)) | |
187 | (recur cbs (.next iter)) | |
188 | [done? cbs])))))] | |
189 | (when done? | |
190 | (abort this)) | |
191 | (.unlock mutex) | |
192 | (doseq [cb cbs] | |
193 | (dispatch/run #(cb true))) | |
194 | (box val)) | |
195 | (do (.unlock mutex) | |
196 | nil))) | |
197 | (let [iter (.iterator puts) | |
198 | [take-cb put-cb val] | |
199 | (when (.hasNext iter) | |
200 | (loop [[^Lock putter val] (.next iter)] | |
201 | (if (< (impl/lock-id handler) (impl/lock-id putter)) | |
202 | (do (.lock handler) (.lock putter)) | |
203 | (do (.lock putter) (.lock handler))) | |
204 | (let [ret (when (and (impl/active? handler) (impl/active? putter)) | |
205 | [(impl/commit handler) (impl/commit putter) val])] | |
206 | (.unlock handler) | |
207 | (.unlock putter) | |
208 | (if ret | |
209 | (do | |
210 | (.remove iter) | |
211 | ret) | |
212 | (when-not (impl/active? putter) | |
213 | (.remove iter) | |
214 | (when (.hasNext iter) | |
215 | (recur (.next iter))))))))] | |
216 | (if (and put-cb take-cb) | |
217 | (do | |
218 | (.unlock mutex) | |
219 | (dispatch/run #(put-cb true)) | |
220 | (box val)) | |
221 | (if @closed | |
222 | (do | |
223 | (when buf (add! buf)) | |
224 | (let [has-val (and buf (pos? (count buf)))] | |
225 | (if-let [take-cb (commit-handler)] | |
226 | (let [val (when has-val (impl/remove! buf))] | |
227 | (.unlock mutex) | |
228 | (box val)) | |
229 | (do | |
230 | (.unlock mutex) | |
231 | nil)))) | |
232 | (do | |
233 | (when (impl/blockable? handler) | |
234 | (assert-unlock mutex | |
235 | (< (.size takes) impl/MAX-QUEUE-SIZE) | |
236 | (str "No more than " impl/MAX-QUEUE-SIZE | |
237 | " pending takes are allowed on a single channel.")) | |
238 | (.add takes handler)) | |
239 | (.unlock mutex) | |
240 | nil))))))) | |
241 | ||
242 | impl/Channel | |
243 | (closed? [_] @closed) | |
244 | (close! | |
245 | [this] | |
246 | (.lock mutex) | |
247 | (cleanup this) | |
248 | (if @closed | |
249 | (do | |
250 | (.unlock mutex) | |
251 | nil) | |
252 | (do | |
253 | (reset! closed true) | |
254 | (when (and buf (.isEmpty puts)) | |
255 | (add! buf)) | |
256 | (let [iter (.iterator takes)] | |
257 | (when (.hasNext iter) | |
258 | (loop [^Lock taker (.next iter)] | |
259 | (.lock taker) | |
260 | (let [take-cb (and (impl/active? taker) (impl/commit taker))] | |
261 | (.unlock taker) | |
262 | (when take-cb | |
263 | (let [val (when (and buf (pos? (count buf))) (impl/remove! buf))] | |
264 | (dispatch/run (fn [] (take-cb val))))) | |
265 | (.remove iter) | |
266 | (when (.hasNext iter) | |
267 | (recur (.next iter))))))) | |
268 | (when buf (impl/close-buf! buf)) | |
269 | (.unlock mutex) | |
270 | nil)))) | |
271 | ||
272 | (defn- ex-handler [ex] | |
273 | (-> (Thread/currentThread) | |
274 | .getUncaughtExceptionHandler | |
275 | (.uncaughtException (Thread/currentThread) ex)) | |
276 | nil) | |
277 | ||
278 | (defn- handle [buf exh t] | |
279 | (let [else ((or exh ex-handler) t)] | |
280 | (if (nil? else) | |
281 | buf | |
282 | (impl/add! buf else)))) | |
283 | ||
284 | (defn chan | |
285 | ([buf] (chan buf nil)) | |
286 | ([buf xform] (chan buf xform nil)) | |
287 | ([buf xform exh] | |
288 | (ManyToManyChannel. | |
289 | (LinkedList.) (LinkedList.) buf (atom false) (mutex/mutex) | |
290 | (let [add! (if xform (xform impl/add!) impl/add!)] | |
291 | (fn | |
292 | ([buf] | |
293 | (try | |
294 | (add! buf) | |
295 | (catch Throwable t | |
296 | (handle buf exh t)))) | |
297 | ([buf val] | |
298 | (try | |
299 | (add! buf val) | |
300 | (catch Throwable t | |
301 | (handle buf exh t))))))))) | |
302 |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns ^{:skip-wiki true} | |
9 | clojure.core.async.impl.concurrent | |
10 | (:import [java.util.concurrent ThreadFactory])) | |
11 | ||
12 | (set! *warn-on-reflection* true) | |
13 | ||
14 | (defn counted-thread-factory | |
15 | "Create a ThreadFactory that maintains a counter for naming Threads. | |
16 | name-format specifies thread names - use %d to include counter | |
17 | daemon is a flag for whether threads are daemons or not" | |
18 | [name-format daemon] | |
19 | (let [counter (atom 0)] | |
20 | (reify | |
21 | ThreadFactory | |
22 | (newThread [this runnable] | |
23 | (doto (Thread. runnable) | |
24 | (.setName (format name-format (swap! counter inc))) | |
25 | (.setDaemon daemon)))))) | |
26 | ||
27 | (defonce | |
28 | ^{:doc "Number of processors reported by the JVM"} | |
29 | processors (.availableProcessors (Runtime/getRuntime))) |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns ^{:skip-wiki true} | |
9 | clojure.core.async.impl.dispatch | |
10 | (:require [clojure.core.async.impl.protocols :as impl] | |
11 | [clojure.core.async.impl.exec.threadpool :as tp])) | |
12 | ||
13 | (set! *warn-on-reflection* true) | |
14 | ||
15 | (defonce executor (delay (tp/thread-pool-executor))) | |
16 | ||
17 | (defn run | |
18 | "Runs Runnable r in a thread pool thread" | |
19 | [^Runnable r] | |
20 | (impl/exec @executor r)) |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns clojure.core.async.impl.exec.threadpool | |
9 | (:require [clojure.core.async.impl.protocols :as impl] | |
10 | [clojure.core.async.impl.concurrent :as conc]) | |
11 | (:import [java.util.concurrent Executors Executor])) | |
12 | ||
13 | (set! *warn-on-reflection* true) | |
14 | ||
15 | (def ^:private pool-size | |
16 | "Value is set via clojure.core.async.pool-size system property; defaults to 8; uses a | |
17 | delay so property can be set from code after core.async namespace is loaded but before | |
18 | any use of the async thread pool." | |
19 | (delay (or (when-let [prop (System/getProperty "clojure.core.async.pool-size")] | |
20 | (Long/parseLong prop)) | |
21 | 8))) | |
22 | ||
23 | (defn thread-pool-executor | |
24 | [] | |
25 | (let [executor-svc (Executors/newFixedThreadPool | |
26 | @pool-size | |
27 | (conc/counted-thread-factory "async-dispatch-%d" true))] | |
28 | (reify impl/Executor | |
29 | (impl/exec [this r] | |
30 | (.execute executor-svc ^Runnable r))))) |
0 | (ns ^{:skip-wiki true} | |
1 | clojure.core.async.impl.ioc-alt | |
2 | (:require [clojure.core.async.impl.ioc-macros :refer :all :as m] | |
3 | [clojure.core.async.impl.dispatch :as dispatch] | |
4 | [clojure.core.async.impl.protocols :as impl])) | |
5 | ||
6 |
0 | ; Copyright (c) Rich Hickey. All rights reserved. | |
1 | ; The use and distribution terms for this software are covered by the | |
2 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ; By using this software in any fashion, you are agreeing to be bound by | |
5 | ; the terms of this license. | |
6 | ; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | ;; by Timothy Baldridge | |
9 | ;; April 13, 2013 | |
10 | ||
11 | (ns ^{:skip-wiki true} | |
12 | clojure.core.async.impl.ioc-macros | |
13 | (:refer-clojure :exclude [all]) | |
14 | (:require [clojure.pprint :refer [pprint]] | |
15 | [clojure.tools.analyzer :as an] | |
16 | [clojure.tools.analyzer.ast :as ast] | |
17 | [clojure.tools.analyzer.env :as env] | |
18 | [clojure.tools.analyzer.passes :refer [schedule]] | |
19 | [clojure.tools.analyzer.passes.jvm.annotate-loops :refer [annotate-loops]] | |
20 | [clojure.tools.analyzer.passes.jvm.warn-on-reflection :refer [warn-on-reflection]] | |
21 | [clojure.tools.analyzer.jvm :as an-jvm] | |
22 | [clojure.core.async.impl.protocols :as impl] | |
23 | [clojure.core.async.impl.dispatch :as dispatch] | |
24 | [clojure.set :refer (intersection union difference)]) | |
25 | (:import [java.util.concurrent.locks Lock] | |
26 | [java.util.concurrent.atomic AtomicReferenceArray])) | |
27 | ||
28 | (defn debug [x] | |
29 | (pprint x) | |
30 | x) | |
31 | ||
32 | ||
33 | (def ^:const FN-IDX 0) | |
34 | (def ^:const STATE-IDX 1) | |
35 | (def ^:const VALUE-IDX 2) | |
36 | (def ^:const BINDINGS-IDX 3) | |
37 | (def ^:const EXCEPTION-FRAMES 4) | |
38 | (def ^:const CURRENT-EXCEPTION 5) | |
39 | (def ^:const USER-START-IDX 6) | |
40 | ||
41 | (defn aset-object [^AtomicReferenceArray arr idx ^Object o] | |
42 | (.set arr idx o)) | |
43 | ||
44 | (defn aget-object [^AtomicReferenceArray arr idx] | |
45 | (.get arr idx)) | |
46 | ||
47 | (defmacro aset-all! | |
48 | [arr & more] | |
49 | (assert (even? (count more)) "Must give an even number of args to aset-all!") | |
50 | (let [bindings (partition 2 more) | |
51 | arr-sym (gensym "statearr-")] | |
52 | `(let [~arr-sym ~arr] | |
53 | ~@(map | |
54 | (fn [[idx val]] | |
55 | `(aset-object ~arr-sym ~idx ~val)) | |
56 | bindings) | |
57 | ~arr-sym))) | |
58 | ||
59 | ;; State monad stuff, used only in SSA construction | |
60 | ||
61 | (defmacro gen-plan | |
62 | "Allows a user to define a state monad binding plan. | |
63 | ||
64 | (gen-plan | |
65 | [_ (assoc-in-plan [:foo :bar] 42) | |
66 | val (get-in-plan [:foo :bar])] | |
67 | val)" | |
68 | [binds id-expr] | |
69 | (let [binds (partition 2 binds) | |
70 | psym (gensym "plan_") | |
71 | forms (reduce | |
72 | (fn [acc [id expr]] | |
73 | (concat acc `[[~id ~psym] (~expr ~psym)])) | |
74 | [] | |
75 | binds)] | |
76 | `(fn [~psym] | |
77 | (let [~@forms] | |
78 | [~id-expr ~psym])))) | |
79 | ||
80 | (defn get-plan | |
81 | "Returns the final [id state] from a plan. " | |
82 | [f] | |
83 | (f {})) | |
84 | ||
85 | (defn push-binding | |
86 | "Sets the binding 'key' to value. This operation can be undone via pop-bindings. | |
87 | Bindings are stored in the state hashmap." | |
88 | [key value] | |
89 | (fn [plan] | |
90 | [nil (update-in plan [:bindings key] conj value)])) | |
91 | ||
92 | (defn push-alter-binding | |
93 | "Pushes the result of (apply f old-value args) as current value of binding key" | |
94 | [key f & args] | |
95 | (fn [plan] | |
96 | [nil (update-in plan [:bindings key] | |
97 | #(conj % (apply f (first %) args)))])) | |
98 | ||
99 | (defn get-binding | |
100 | "Gets the value of the current binding for key" | |
101 | [key] | |
102 | (fn [plan] | |
103 | [(first (get-in plan [:bindings key])) plan])) | |
104 | ||
105 | (defn pop-binding | |
106 | "Removes the most recent binding for key" | |
107 | [key] | |
108 | (fn [plan] | |
109 | [(first (get-in plan [:bindings key])) | |
110 | (update-in plan [:bindings key] pop)])) | |
111 | ||
112 | (defn no-op | |
113 | "This function can be used inside a gen-plan when no operation is to be performed" | |
114 | [] | |
115 | (fn [plan] | |
116 | [nil plan])) | |
117 | ||
118 | (defn all | |
119 | "Assumes that itms is a list of state monad function results, threads the state map | |
120 | through all of them. Returns a vector of all the results." | |
121 | [itms] | |
122 | (fn [plan] | |
123 | (reduce | |
124 | (fn [[ids plan] f] | |
125 | (let [[id plan] (f plan)] | |
126 | [(conj ids id) plan])) | |
127 | [[] plan] | |
128 | itms))) | |
129 | ||
130 | (defn assoc-in-plan | |
131 | "Same as assoc-in, but for state hash map" | |
132 | [path val] | |
133 | (fn [plan] | |
134 | [val (assoc-in plan path val)])) | |
135 | ||
136 | (defn update-in-plan | |
137 | "Same as update-in, but for a state hash map" | |
138 | [path f & args] | |
139 | (fn [plan] | |
140 | [nil (apply update-in plan path f args)])) | |
141 | ||
142 | (defn get-in-plan | |
143 | "Same as get-in, but for a state hash map" | |
144 | [path] | |
145 | (fn [plan] | |
146 | [(get-in plan path) plan])) | |
147 | ||
148 | (defn print-plan [] | |
149 | (fn [plan] | |
150 | (pprint plan) | |
151 | [nil plan])) | |
152 | ||
153 | (defn set-block | |
154 | "Sets the current block being written to by the functions. The next add-instruction call will append to this block" | |
155 | [block-id] | |
156 | (fn [plan] | |
157 | [block-id (assoc plan :current-block block-id)])) | |
158 | ||
159 | (defn get-block | |
160 | "Gets the current block" | |
161 | [] | |
162 | (fn [plan] | |
163 | [(:current-block plan) plan])) | |
164 | ||
165 | (defn add-block | |
166 | "Adds a new block, returns its id, but does not change the current block (does not call set-block)." | |
167 | [] | |
168 | (gen-plan | |
169 | [_ (update-in-plan [:block-id] (fnil inc 0)) | |
170 | blk-id (get-in-plan [:block-id]) | |
171 | cur-blk (get-block) | |
172 | _ (assoc-in-plan [:blocks blk-id] []) | |
173 | catches (get-binding :catch) | |
174 | _ (assoc-in-plan [:block-catches blk-id] catches) | |
175 | _ (if-not cur-blk | |
176 | (assoc-in-plan [:start-block] blk-id) | |
177 | (no-op))] | |
178 | blk-id)) | |
179 | ||
180 | ||
181 | (defn instruction? [x] | |
182 | (::instruction (meta x))) | |
183 | ||
184 | (defn add-instruction | |
185 | "Appends an instruction to the current block. " | |
186 | [inst] | |
187 | (let [inst-id (with-meta (gensym "inst_") | |
188 | {::instruction true}) | |
189 | inst (assoc inst :id inst-id)] | |
190 | (gen-plan | |
191 | [blk-id (get-block) | |
192 | _ (update-in-plan [:blocks blk-id] (fnil conj []) inst)] | |
193 | inst-id))) | |
194 | ||
195 | ;; | |
196 | ||
197 | ;; We're going to reduce Clojure expressions to a ssa format, | |
198 | ;; and then translate the instructions for this | |
199 | ;; virtual-virtual-machine back into Clojure data. | |
200 | ||
201 | ;; Here we define the instructions: | |
202 | ||
203 | (defprotocol IInstruction | |
204 | (reads-from [this] "Returns a list of instructions this instruction reads from") | |
205 | (writes-to [this] "Returns a list of instructions this instruction writes to") | |
206 | (block-references [this] "Returns all the blocks this instruction references")) | |
207 | ||
208 | (defprotocol IEmittableInstruction | |
209 | (emit-instruction [this state-sym] "Returns the clojure code that this instruction represents")) | |
210 | ||
211 | (defprotocol ITerminator | |
212 | (terminator-code [this] "Returns a unique symbol for this instruction") | |
213 | (terminate-block [this state-sym custom-terminators] "Emites the code to terminate a given block")) | |
214 | ||
215 | (defrecord Const [value] | |
216 | IInstruction | |
217 | (reads-from [this] [value]) | |
218 | (writes-to [this] [(:id this)]) | |
219 | (block-references [this] []) | |
220 | IEmittableInstruction | |
221 | (emit-instruction [this state-sym] | |
222 | (if (= value ::value) | |
223 | `[~(:id this) (aget-object ~state-sym ~VALUE-IDX)] | |
224 | `[~(:id this) ~value]))) | |
225 | ||
226 | (defrecord RawCode [ast locals] | |
227 | IInstruction | |
228 | (reads-from [this] | |
229 | (keep (or locals #{}) | |
230 | (map :name (-> ast :env :locals vals)))) | |
231 | (writes-to [this] [(:id this)]) | |
232 | (block-references [this] []) | |
233 | IEmittableInstruction | |
234 | (emit-instruction [this state-sym] | |
235 | (if (not-empty (reads-from this)) | |
236 | `[~@(->> (-> ast :env :locals vals) | |
237 | (map #(select-keys % [:op :name :form])) | |
238 | (filter (fn [local] | |
239 | (when locals | |
240 | (get locals (:name local))))) | |
241 | set | |
242 | (mapcat | |
243 | (fn [local] | |
244 | `[~(:form local) ~(get locals (:name local))]))) | |
245 | ~(:id this) ~(:form ast)] | |
246 | `[~(:id this) ~(:form ast)]))) | |
247 | ||
248 | (defrecord CustomTerminator [f blk values meta] | |
249 | IInstruction | |
250 | (reads-from [this] values) | |
251 | (writes-to [this] []) | |
252 | (block-references [this] []) | |
253 | ITerminator | |
254 | (terminate-block [this state-sym _] | |
255 | (with-meta `(~f ~state-sym ~blk ~@values) | |
256 | meta))) | |
257 | ||
258 | (defn- emit-clashing-binds | |
259 | [recur-nodes ids clashes] | |
260 | (let [temp-binds (reduce | |
261 | (fn [acc i] | |
262 | (assoc acc i (gensym "tmp"))) | |
263 | {} clashes)] | |
264 | (concat | |
265 | (mapcat (fn [i] | |
266 | `[~(temp-binds i) ~i]) | |
267 | clashes) | |
268 | (mapcat (fn [node id] | |
269 | `[~node ~(get temp-binds id id)]) | |
270 | recur-nodes | |
271 | ids)))) | |
272 | ||
273 | (defrecord Recur [recur-nodes ids] | |
274 | IInstruction | |
275 | (reads-from [this] ids) | |
276 | (writes-to [this] recur-nodes) | |
277 | (block-references [this] []) | |
278 | IEmittableInstruction | |
279 | (emit-instruction [this state-sym] | |
280 | (if-let [overlap (seq (intersection (set recur-nodes) (set ids)))] | |
281 | (emit-clashing-binds recur-nodes ids overlap) | |
282 | (mapcat (fn [r i] | |
283 | `[~r ~i]) recur-nodes ids)))) | |
284 | ||
285 | (defrecord Call [refs] | |
286 | IInstruction | |
287 | (reads-from [this] refs) | |
288 | (writes-to [this] [(:id this)]) | |
289 | (block-references [this] []) | |
290 | IEmittableInstruction | |
291 | (emit-instruction [this state-sym] | |
292 | `[~(:id this) ~(seq refs)])) | |
293 | ||
294 | (defrecord StaticCall [class method refs] | |
295 | IInstruction | |
296 | (reads-from [this] refs) | |
297 | (writes-to [this] [(:id this)]) | |
298 | (block-references [this] []) | |
299 | IEmittableInstruction | |
300 | (emit-instruction [this state-sym] | |
301 | `[~(:id this) (. ~class ~method ~@(seq refs))])) | |
302 | ||
303 | (defrecord InstanceInterop [instance-id op refs] | |
304 | IInstruction | |
305 | (reads-from [this] (cons instance-id refs)) | |
306 | (writes-to [this] [(:id this)]) | |
307 | (block-references [this] []) | |
308 | IEmittableInstruction | |
309 | (emit-instruction [this state-sym] | |
310 | `[~(:id this) (. ~instance-id ~op ~@(seq refs))])) | |
311 | ||
312 | (defrecord Case [val-id test-vals jmp-blocks default-block] | |
313 | IInstruction | |
314 | (reads-from [this] [val-id]) | |
315 | (writes-to [this] []) | |
316 | (block-references [this] []) | |
317 | ITerminator | |
318 | (terminate-block [this state-sym _] | |
319 | `(do (case ~val-id | |
320 | ~@(concat (mapcat (fn [test blk] | |
321 | `[~test (aset-all! ~state-sym | |
322 | ~STATE-IDX ~blk)]) | |
323 | test-vals jmp-blocks) | |
324 | (when default-block | |
325 | `[(do (aset-all! ~state-sym ~STATE-IDX ~default-block) | |
326 | :recur)]))) | |
327 | :recur))) | |
328 | ||
329 | (defrecord Fn [fn-expr local-names local-refs] | |
330 | IInstruction | |
331 | (reads-from [this] local-refs) | |
332 | (writes-to [this] [(:id this)]) | |
333 | (block-references [this] []) | |
334 | IEmittableInstruction | |
335 | (emit-instruction [this state-sym] | |
336 | `[~(:id this) | |
337 | (let [~@(interleave local-names local-refs)] | |
338 | ~@fn-expr)])) | |
339 | ||
340 | (defrecord Dot [cls-or-instance method args] | |
341 | IInstruction | |
342 | (reads-from [this] `[~cls-or-instance ~method ~@args]) | |
343 | (writes-to [this] [(:id this)]) | |
344 | (block-references [this] []) | |
345 | IEmittableInstruction | |
346 | (emit-instruction [this state-sym] | |
347 | `[~(:id this) (. ~cls-or-instance ~method ~@args)])) | |
348 | ||
349 | (defrecord Jmp [value block] | |
350 | IInstruction | |
351 | (reads-from [this] [value]) | |
352 | (writes-to [this] []) | |
353 | (block-references [this] [block]) | |
354 | ITerminator | |
355 | (terminate-block [this state-sym _] | |
356 | `(do (aset-all! ~state-sym ~VALUE-IDX ~value ~STATE-IDX ~block) | |
357 | :recur))) | |
358 | ||
359 | (defrecord Return [value] | |
360 | IInstruction | |
361 | (reads-from [this] [value]) | |
362 | (writes-to [this] []) | |
363 | (block-references [this] []) | |
364 | ITerminator | |
365 | (terminator-code [this] :Return) | |
366 | (terminate-block [this state-sym custom-terminators] | |
367 | (if-let [f (get custom-terminators (terminator-code this))] | |
368 | `(~f ~state-sym ~value) | |
369 | `(do (aset-all! ~state-sym | |
370 | ~VALUE-IDX ~value | |
371 | ~STATE-IDX ::finished) | |
372 | nil)))) | |
373 | ||
374 | (defrecord CondBr [test then-block else-block] | |
375 | IInstruction | |
376 | (reads-from [this] [test]) | |
377 | (writes-to [this] []) | |
378 | (block-references [this] [then-block else-block]) | |
379 | ITerminator | |
380 | (terminate-block [this state-sym _] | |
381 | `(do (if ~test | |
382 | (aset-all! ~state-sym | |
383 | ~STATE-IDX ~then-block) | |
384 | (aset-all! ~state-sym | |
385 | ~STATE-IDX ~else-block)) | |
386 | :recur))) | |
387 | ||
388 | (defrecord PushTry [catch-block] | |
389 | IInstruction | |
390 | (reads-from [this] []) | |
391 | (writes-to [this] []) | |
392 | (block-references [this] [catch-block]) | |
393 | IEmittableInstruction | |
394 | (emit-instruction [this state-sym] | |
395 | `[~'_ (aset-all! ~state-sym ~EXCEPTION-FRAMES (cons ~catch-block (aget-object ~state-sym ~EXCEPTION-FRAMES)))])) | |
396 | ||
397 | (defrecord PopTry [] | |
398 | IInstruction | |
399 | (reads-from [this] []) | |
400 | (writes-to [this] []) | |
401 | (block-references [this] []) | |
402 | IEmittableInstruction | |
403 | (emit-instruction [this state-sym] | |
404 | `[~'_ (aset-all! ~state-sym ~EXCEPTION-FRAMES (rest (aget-object ~state-sym ~EXCEPTION-FRAMES)))])) | |
405 | ||
406 | (defrecord CatchHandler [catches] | |
407 | IInstruction | |
408 | (reads-from [this] []) | |
409 | (writes-to [this] []) | |
410 | (block-references [this] (map first catches)) | |
411 | ITerminator | |
412 | (terminate-block [this state-sym _] | |
413 | (let [ex (gensym 'ex)] | |
414 | `(let [~ex (aget-object ~state-sym ~VALUE-IDX)] | |
415 | (aset-all! ~state-sym ~CURRENT-EXCEPTION ~ex) | |
416 | (cond | |
417 | ~@(for [[handler-idx type] catches | |
418 | i [`(instance? ~type ~ex) ` (aset-all! ~state-sym | |
419 | ~STATE-IDX ~handler-idx | |
420 | ~CURRENT-EXCEPTION nil)]] | |
421 | i) | |
422 | :else (throw ~ex)) | |
423 | :recur)))) | |
424 | ||
425 | (defrecord EndFinally [] | |
426 | IInstruction | |
427 | (reads-from [this] []) | |
428 | (writes-to [this] []) | |
429 | (block-references [this] []) | |
430 | IEmittableInstruction | |
431 | (emit-instruction [this state-sym] | |
432 | `[~'_ (when-let [e# (aget-object ~state-sym ~CURRENT-EXCEPTION)] | |
433 | (throw e#))])) | |
434 | ||
435 | ;; Dispatch clojure forms based on :op | |
436 | (def -item-to-ssa nil) ;; for help in the repl | |
437 | (defmulti -item-to-ssa :op) | |
438 | ||
439 | (defmethod -item-to-ssa :default | |
440 | [ast] | |
441 | (gen-plan | |
442 | [locals (get-binding :locals) | |
443 | id (add-instruction (->RawCode ast locals))] | |
444 | id)) | |
445 | ||
446 | (defn item-to-ssa [ast] | |
447 | (if (or (::transform? ast) | |
448 | (contains? #{:local :const :quote} (:op ast))) | |
449 | (-item-to-ssa ast) | |
450 | (gen-plan | |
451 | [locals (get-binding :locals) | |
452 | id (add-instruction (->RawCode ast locals))] | |
453 | id))) | |
454 | ||
455 | (defmethod -item-to-ssa :invoke | |
456 | [{f :fn args :args}] | |
457 | (gen-plan | |
458 | [arg-ids (all (map item-to-ssa (cons f args))) | |
459 | inst-id (add-instruction (->Call arg-ids))] | |
460 | inst-id)) | |
461 | ||
462 | (defmethod -item-to-ssa :keyword-invoke | |
463 | [{f :keyword target :target}] | |
464 | (gen-plan | |
465 | [arg-ids (all (map item-to-ssa (list f target))) | |
466 | inst-id (add-instruction (->Call arg-ids))] | |
467 | inst-id)) | |
468 | ||
469 | (defmethod -item-to-ssa :protocol-invoke | |
470 | [{f :protocol-fn target :target args :args}] | |
471 | (gen-plan | |
472 | [arg-ids (all (map item-to-ssa (list* f target args))) | |
473 | inst-id (add-instruction (->Call arg-ids))] | |
474 | inst-id)) | |
475 | ||
476 | (defmethod -item-to-ssa :instance? | |
477 | [{:keys [class target]}] | |
478 | (gen-plan | |
479 | [arg-id (item-to-ssa target) | |
480 | inst-id (add-instruction (->Call (list `instance? class arg-id)))] | |
481 | inst-id)) | |
482 | ||
483 | (defmethod -item-to-ssa :prim-invoke | |
484 | [{f :fn args :args}] | |
485 | (gen-plan | |
486 | [arg-ids (all (map item-to-ssa (cons f args))) | |
487 | inst-id (add-instruction (->Call arg-ids))] | |
488 | inst-id)) | |
489 | ||
490 | (defmethod -item-to-ssa :instance-call | |
491 | [{:keys [instance method args]}] | |
492 | (gen-plan | |
493 | [arg-ids (all (map item-to-ssa args)) | |
494 | instance-id (item-to-ssa instance) | |
495 | inst-id (add-instruction (->InstanceInterop instance-id method arg-ids))] | |
496 | inst-id)) | |
497 | ||
498 | (defmethod -item-to-ssa :instance-field | |
499 | [{:keys [instance field]}] | |
500 | (gen-plan | |
501 | [instance-id (item-to-ssa instance) | |
502 | inst-id (add-instruction (->InstanceInterop instance-id (symbol (str "-" field)) ()))] | |
503 | inst-id)) | |
504 | ||
505 | (defmethod -item-to-ssa :host-interop | |
506 | [{:keys [target m-or-f]}] | |
507 | (gen-plan | |
508 | [instance-id (item-to-ssa target) | |
509 | inst-id (add-instruction (->InstanceInterop instance-id m-or-f ()))] | |
510 | inst-id)) | |
511 | ||
512 | (defmethod -item-to-ssa :static-call | |
513 | [{:keys [class method args]}] | |
514 | (gen-plan | |
515 | [arg-ids (all (map item-to-ssa args)) | |
516 | inst-id (add-instruction (->StaticCall class method arg-ids))] | |
517 | inst-id)) | |
518 | ||
519 | (defmethod -item-to-ssa :set! | |
520 | [{:keys [val target]}] | |
521 | (gen-plan | |
522 | [arg-ids (all (map item-to-ssa (list target val))) | |
523 | inst-id (add-instruction (->Call (cons 'set! arg-ids)))] | |
524 | inst-id)) | |
525 | ||
526 | (defn var-name [v] | |
527 | (let [nm (:name (meta v)) | |
528 | nsp (.getName ^clojure.lang.Namespace (:ns (meta v)))] | |
529 | (symbol (name nsp) (name nm)))) | |
530 | ||
531 | ||
532 | (defmethod -item-to-ssa :var | |
533 | [{:keys [var]}] | |
534 | (gen-plan | |
535 | [] | |
536 | (var-name var))) | |
537 | ||
538 | (defmethod -item-to-ssa :const | |
539 | [{:keys [form]}] | |
540 | (gen-plan | |
541 | [] | |
542 | form)) | |
543 | ||
544 | (defn let-binding-to-ssa | |
545 | [{:keys [name init form]}] | |
546 | (gen-plan | |
547 | [bind-id (item-to-ssa init) | |
548 | _ (push-alter-binding :locals assoc (vary-meta name merge (meta form)) bind-id)] | |
549 | bind-id)) | |
550 | ||
551 | (defmethod -item-to-ssa :let | |
552 | [{:keys [bindings body]}] | |
553 | (gen-plan | |
554 | [let-ids (all (map let-binding-to-ssa bindings)) | |
555 | _ (all (map (fn [_] (pop-binding :locals)) bindings)) | |
556 | ||
557 | local-ids (all (map (comp add-instruction ->Const) let-ids)) | |
558 | _ (push-alter-binding :locals merge (into {} (map (fn [id {:keys [name form]}] | |
559 | [name (vary-meta id merge (meta form))]) | |
560 | local-ids bindings))) | |
561 | ||
562 | body-id (item-to-ssa body) | |
563 | _ (pop-binding :locals)] | |
564 | body-id)) | |
565 | ||
566 | (defmethod -item-to-ssa :loop | |
567 | [{:keys [body bindings] :as ast}] | |
568 | (gen-plan | |
569 | [local-val-ids (all (map let-binding-to-ssa bindings)) | |
570 | _ (all (for [_ bindings] | |
571 | (pop-binding :locals))) | |
572 | local-ids (all (map (comp add-instruction ->Const) local-val-ids)) | |
573 | body-blk (add-block) | |
574 | final-blk (add-block) | |
575 | _ (add-instruction (->Jmp nil body-blk)) | |
576 | ||
577 | _ (set-block body-blk) | |
578 | _ (push-alter-binding :locals merge (into {} (map (fn [id {:keys [name form]}] | |
579 | [name (vary-meta id merge (meta form))]) | |
580 | local-ids bindings))) | |
581 | _ (push-binding :recur-point body-blk) | |
582 | _ (push-binding :recur-nodes local-ids) | |
583 | ||
584 | ret-id (item-to-ssa body) | |
585 | ||
586 | _ (pop-binding :recur-nodes) | |
587 | _ (pop-binding :recur-point) | |
588 | _ (pop-binding :locals) | |
589 | _ (if (not= ret-id ::terminated) | |
590 | (add-instruction (->Jmp ret-id final-blk)) | |
591 | (no-op)) | |
592 | _ (set-block final-blk) | |
593 | ret-id (add-instruction (->Const ::value))] | |
594 | ret-id)) | |
595 | ||
596 | (defmethod -item-to-ssa :do | |
597 | [{:keys [statements ret] :as ast}] | |
598 | (gen-plan | |
599 | [_ (all (map item-to-ssa statements)) | |
600 | ret-id (item-to-ssa ret)] | |
601 | ret-id)) | |
602 | ||
603 | (defmethod -item-to-ssa :case | |
604 | [{:keys [test tests thens default] :as ast}] | |
605 | (gen-plan | |
606 | [end-blk (add-block) | |
607 | start-blk (get-block) | |
608 | clause-blocks (all (map (fn [expr] | |
609 | (assert expr) | |
610 | (gen-plan | |
611 | [blk-id (add-block) | |
612 | _ (set-block blk-id) | |
613 | expr-id (item-to-ssa expr) | |
614 | _ (if (not= expr-id ::terminated) | |
615 | (add-instruction (->Jmp expr-id end-blk)) | |
616 | (no-op))] | |
617 | blk-id)) | |
618 | (map :then thens))) | |
619 | default-block (if default | |
620 | (gen-plan | |
621 | [blk-id (add-block) | |
622 | _ (set-block blk-id) | |
623 | expr-id (item-to-ssa default) | |
624 | _ (if (not= expr-id ::terminated) | |
625 | (add-instruction (->Jmp expr-id end-blk)) | |
626 | (no-op))] | |
627 | blk-id) | |
628 | (no-op)) | |
629 | _ (set-block start-blk) | |
630 | val-id (item-to-ssa test) | |
631 | case-id (add-instruction (->Case val-id (map (comp :form :test) tests) | |
632 | clause-blocks | |
633 | default-block)) | |
634 | _ (set-block end-blk) | |
635 | ret-id (add-instruction (->Const ::value))] | |
636 | ret-id)) | |
637 | ||
638 | (defmethod -item-to-ssa :quote | |
639 | [{:keys [form]}] | |
640 | (gen-plan | |
641 | [ret-id (add-instruction (->Const form))] | |
642 | ret-id)) | |
643 | ||
644 | (defmethod -item-to-ssa :try | |
645 | [{:keys [catches body finally] :as ast}] | |
646 | (gen-plan | |
647 | [body-block (add-block) | |
648 | exit-block (add-block) | |
649 | ;; Two routes to the finally block, via normal execution and | |
650 | ;; exception execution | |
651 | finally-blk (if finally | |
652 | (gen-plan | |
653 | [cur-blk (get-block) | |
654 | finally-blk (add-block) | |
655 | _ (set-block finally-blk) | |
656 | result-id (add-instruction (->Const ::value)) | |
657 | _ (item-to-ssa finally) | |
658 | ;; rethrow exception on exception path | |
659 | _ (add-instruction (->EndFinally)) | |
660 | _ (add-instruction (->Jmp result-id exit-block)) | |
661 | _ (set-block cur-blk)] | |
662 | finally-blk) | |
663 | (gen-plan [] exit-block)) | |
664 | catch-blocks (all | |
665 | (for [{ex-bind :local {ex :val} :class catch-body :body} catches] | |
666 | (gen-plan | |
667 | [cur-blk (get-block) | |
668 | catch-blk (add-block) | |
669 | _ (set-block catch-blk) | |
670 | ex-id (add-instruction (->Const ::value)) | |
671 | _ (push-alter-binding :locals assoc (:name ex-bind) | |
672 | (vary-meta ex-id merge (when (:tag ex-bind) | |
673 | {:tag (.getName ^Class (:tag ex-bind))}))) | |
674 | result-id (item-to-ssa catch-body) | |
675 | ;; if there is a finally, jump to it after | |
676 | ;; handling the exception, if not jump to exit | |
677 | _ (add-instruction (->Jmp result-id finally-blk)) | |
678 | _ (pop-binding :locals) | |
679 | _ (set-block cur-blk)] | |
680 | [catch-blk ex]))) | |
681 | ;; catch block handler routes exceptions to the correct handler, | |
682 | ;; rethrows if there is no match | |
683 | catch-handler-block (add-block) | |
684 | cur-blk (get-block) | |
685 | _ (set-block catch-handler-block) | |
686 | _ (add-instruction (->CatchHandler catch-blocks)) | |
687 | _ (set-block cur-blk) | |
688 | _ (add-instruction (->Jmp nil body-block)) | |
689 | _ (set-block body-block) | |
690 | ;; the finally gets pushed on to the exception handler stack, so | |
691 | ;; it will be executed if there is an exception | |
692 | _ (if finally | |
693 | (add-instruction (->PushTry finally-blk)) | |
694 | (no-op)) | |
695 | _ (add-instruction (->PushTry catch-handler-block)) | |
696 | body (item-to-ssa body) | |
697 | _ (add-instruction (->PopTry)) | |
698 | _ (if finally | |
699 | (add-instruction (->PopTry)) | |
700 | (no-op)) | |
701 | ;; if the body finishes executing normally, jump to the finally | |
702 | ;; block, if it exists | |
703 | _ (add-instruction (->Jmp body finally-blk)) | |
704 | _ (set-block exit-block) | |
705 | ret (add-instruction (->Const ::value))] | |
706 | ret)) | |
707 | ||
708 | (defmethod -item-to-ssa :throw | |
709 | [{:keys [exception] :as ast}] | |
710 | (gen-plan | |
711 | [exception-id (item-to-ssa exception) | |
712 | ret-id (add-instruction (->Call ['throw exception-id]))] | |
713 | ret-id)) | |
714 | ||
715 | (defmethod -item-to-ssa :new | |
716 | [{:keys [args class] :as ast}] | |
717 | (gen-plan | |
718 | [arg-ids (all (map item-to-ssa args)) | |
719 | ret-id (add-instruction (->Call (list* 'new (:val class) arg-ids)))] | |
720 | ret-id)) | |
721 | ||
722 | (defmethod -item-to-ssa :recur | |
723 | [{:keys [exprs] :as ast}] | |
724 | (gen-plan | |
725 | [val-ids (all (map item-to-ssa exprs)) | |
726 | recurs (get-binding :recur-nodes) | |
727 | _ (do (assert (= (count val-ids) | |
728 | (count recurs)) | |
729 | "Wrong number of arguments to recur") | |
730 | (no-op)) | |
731 | _ (add-instruction (->Recur recurs val-ids)) | |
732 | ||
733 | recur-point (get-binding :recur-point) | |
734 | ||
735 | _ (add-instruction (->Jmp nil recur-point))] | |
736 | ::terminated)) | |
737 | ||
738 | (defmethod -item-to-ssa :if | |
739 | [{:keys [test then else]}] | |
740 | (gen-plan | |
741 | [test-id (item-to-ssa test) | |
742 | then-blk (add-block) | |
743 | else-blk (add-block) | |
744 | final-blk (add-block) | |
745 | _ (add-instruction (->CondBr test-id then-blk else-blk)) | |
746 | ||
747 | _ (set-block then-blk) | |
748 | then-id (item-to-ssa then) | |
749 | _ (if (not= then-id ::terminated) | |
750 | (gen-plan | |
751 | [_ (add-instruction (->Jmp then-id final-blk))] | |
752 | then-id) | |
753 | (no-op)) | |
754 | ||
755 | _ (set-block else-blk) | |
756 | else-id (item-to-ssa else) | |
757 | _ (if (not= else-id ::terminated) | |
758 | (gen-plan | |
759 | [_ (add-instruction (->Jmp else-id final-blk))] | |
760 | then-id) | |
761 | (no-op)) | |
762 | ||
763 | _ (set-block final-blk) | |
764 | val-id (add-instruction (->Const ::value))] | |
765 | val-id)) | |
766 | ||
767 | (defmethod -item-to-ssa :transition | |
768 | [{:keys [name args form]}] | |
769 | (gen-plan | |
770 | [blk (add-block) | |
771 | vals (all (map item-to-ssa args)) | |
772 | val (add-instruction (->CustomTerminator name blk vals (meta form))) | |
773 | _ (set-block blk) | |
774 | res (add-instruction (->Const ::value))] | |
775 | res)) | |
776 | ||
777 | (defmethod -item-to-ssa :local | |
778 | [{:keys [name form]}] | |
779 | (gen-plan | |
780 | [locals (get-binding :locals) | |
781 | inst-id (if (contains? locals name) | |
782 | (fn [p] | |
783 | [(locals name) p]) | |
784 | (fn [p] | |
785 | [form p]))] | |
786 | inst-id)) | |
787 | ||
788 | (defmethod -item-to-ssa :map | |
789 | [{:keys [keys vals]}] | |
790 | (gen-plan | |
791 | [keys-ids (all (map item-to-ssa keys)) | |
792 | vals-ids (all (map item-to-ssa vals)) | |
793 | id (add-instruction (->Call (cons 'clojure.core/hash-map | |
794 | (interleave keys-ids vals-ids))))] | |
795 | id)) | |
796 | ||
797 | (defmethod -item-to-ssa :with-meta | |
798 | [{:keys [expr meta]}] | |
799 | (gen-plan | |
800 | [meta-id (item-to-ssa meta) | |
801 | expr-id (item-to-ssa expr) | |
802 | id (add-instruction (->Call (list 'clojure.core/with-meta expr-id meta-id)))] | |
803 | id)) | |
804 | ||
805 | (defmethod -item-to-ssa :record | |
806 | [x] | |
807 | (-item-to-ssa `(~(symbol (.getName (class x)) "create") | |
808 | (hash-map ~@(mapcat identity x))))) | |
809 | ||
810 | (defmethod -item-to-ssa :vector | |
811 | [{:keys [items]}] | |
812 | (gen-plan | |
813 | [item-ids (all (map item-to-ssa items)) | |
814 | id (add-instruction (->Call (cons 'clojure.core/vector | |
815 | item-ids)))] | |
816 | id)) | |
817 | ||
818 | (defmethod -item-to-ssa :set | |
819 | [{:keys [items]}] | |
820 | (gen-plan | |
821 | [item-ids (all (map item-to-ssa items)) | |
822 | id (add-instruction (->Call (cons 'clojure.core/hash-set | |
823 | item-ids)))] | |
824 | id)) | |
825 | ||
826 | (defn parse-to-state-machine | |
827 | "Takes an sexpr and returns a hashmap that describes the execution flow of the sexpr as | |
828 | a series of SSA style blocks." | |
829 | [body terminators] | |
830 | (-> (gen-plan | |
831 | [_ (push-binding :terminators terminators) | |
832 | blk (add-block) | |
833 | _ (set-block blk) | |
834 | id (item-to-ssa body) | |
835 | term-id (add-instruction (->Return id)) | |
836 | _ (pop-binding :terminators)] | |
837 | term-id) | |
838 | get-plan)) | |
839 | ||
840 | ||
841 | (defn index-instruction [blk-id idx inst] | |
842 | (let [idx (reduce | |
843 | (fn [acc id] | |
844 | (update-in acc [id :read-in] (fnil conj #{}) blk-id)) | |
845 | idx | |
846 | (filter instruction? (reads-from inst))) | |
847 | idx (reduce | |
848 | (fn [acc id] | |
849 | (update-in acc [id :written-in] (fnil conj #{}) blk-id)) | |
850 | idx | |
851 | (filter instruction? (writes-to inst)))] | |
852 | idx)) | |
853 | ||
854 | (defn index-block [idx [blk-id blk]] | |
855 | (reduce (partial index-instruction blk-id) idx blk)) | |
856 | ||
857 | (defn index-state-machine [machine] | |
858 | (reduce index-block {} (:blocks machine))) | |
859 | ||
860 | (defn id-for-inst [m sym] ;; m :: symbols -> integers | |
861 | (if-let [i (get @m sym)] | |
862 | i | |
863 | (let [next-idx (get @m ::next-idx)] | |
864 | (swap! m assoc sym next-idx) | |
865 | (swap! m assoc ::next-idx (inc next-idx)) | |
866 | next-idx))) | |
867 | ||
868 | (defn persistent-value? | |
869 | "Returns true if this value should be saved in the state hash map" | |
870 | [index value] | |
871 | (or (not= (-> index value :read-in) | |
872 | (-> index value :written-in)) | |
873 | (-> index value :read-in count (> 1)))) | |
874 | ||
875 | (defn count-persistent-values | |
876 | [index] | |
877 | (->> (keys index) | |
878 | (filter instruction?) | |
879 | (filter (partial persistent-value? index)) | |
880 | count)) | |
881 | ||
882 | (defn- build-block-preamble [local-map idx state-sym blk] | |
883 | (let [args (->> (mapcat reads-from blk) | |
884 | (filter instruction?) | |
885 | (filter (partial persistent-value? idx)) | |
886 | set | |
887 | vec)] | |
888 | (if (empty? args) | |
889 | [] | |
890 | (mapcat (fn [sym] | |
891 | `[~sym (aget-object ~state-sym ~(id-for-inst local-map sym))]) | |
892 | args)))) | |
893 | ||
894 | (defn- build-block-body [state-sym blk] | |
895 | (mapcat | |
896 | #(emit-instruction % state-sym) | |
897 | (butlast blk))) | |
898 | ||
899 | (defn- build-new-state [local-map idx state-sym blk] | |
900 | (let [results (->> blk | |
901 | (mapcat writes-to) | |
902 | (filter instruction?) | |
903 | (filter (partial persistent-value? idx)) | |
904 | set | |
905 | vec) | |
906 | results (interleave (map (partial id-for-inst local-map) results) results)] | |
907 | (if-not (empty? results) | |
908 | [state-sym `(aset-all! ~state-sym ~@results)] | |
909 | []))) | |
910 | ||
911 | (defn- emit-state-machine [machine num-user-params custom-terminators] | |
912 | (let [index (index-state-machine machine) | |
913 | state-sym (with-meta (gensym "state_") | |
914 | {:tag 'objects}) | |
915 | local-start-idx (+ num-user-params USER-START-IDX) | |
916 | state-arr-size (+ local-start-idx (count-persistent-values index)) | |
917 | local-map (atom {::next-idx local-start-idx}) | |
918 | block-catches (:block-catches machine)] | |
919 | `(fn state-machine# | |
920 | ([] (aset-all! (AtomicReferenceArray. ~state-arr-size) | |
921 | ~FN-IDX state-machine# | |
922 | ~STATE-IDX ~(:start-block machine))) | |
923 | ([~state-sym] | |
924 | (let [old-frame# (clojure.lang.Var/getThreadBindingFrame) | |
925 | ret-value# (try | |
926 | (clojure.lang.Var/resetThreadBindingFrame (aget-object ~state-sym ~BINDINGS-IDX)) | |
927 | (loop [] | |
928 | (let [result# (case (int (aget-object ~state-sym ~STATE-IDX)) | |
929 | ~@(mapcat | |
930 | (fn [[id blk]] | |
931 | [id `(let [~@(concat (build-block-preamble local-map index state-sym blk) | |
932 | (build-block-body state-sym blk)) | |
933 | ~@(build-new-state local-map index state-sym blk)] | |
934 | ~(terminate-block (last blk) state-sym custom-terminators))]) | |
935 | (:blocks machine)))] | |
936 | (if (identical? result# :recur) | |
937 | (recur) | |
938 | result#))) | |
939 | (catch Throwable ex# | |
940 | (aset-all! ~state-sym ~VALUE-IDX ex#) | |
941 | (if (seq (aget-object ~state-sym ~EXCEPTION-FRAMES)) | |
942 | (aset-all! ~state-sym ~STATE-IDX (first (aget-object ~state-sym ~EXCEPTION-FRAMES)) | |
943 | ~EXCEPTION-FRAMES (rest (aget-object ~state-sym ~EXCEPTION-FRAMES))) | |
944 | (throw ex#)) | |
945 | :recur) | |
946 | (finally | |
947 | (clojure.lang.Var/resetThreadBindingFrame old-frame#)))] | |
948 | (if (identical? ret-value# :recur) | |
949 | (recur ~state-sym) | |
950 | ret-value#)))))) | |
951 | ||
952 | (defn finished? | |
953 | "Returns true if the machine is in a finished state" | |
954 | [state-array] | |
955 | (identical? (aget-object state-array STATE-IDX) ::finished)) | |
956 | ||
957 | (defn- fn-handler | |
958 | [f] | |
959 | (reify | |
960 | Lock | |
961 | (lock [_]) | |
962 | (unlock [_]) | |
963 | ||
964 | impl/Handler | |
965 | (active? [_] true) | |
966 | (blockable? [_] true) | |
967 | (lock-id [_] 0) | |
968 | (commit [_] f))) | |
969 | ||
970 | ||
971 | (defn run-state-machine [state] | |
972 | ((aget-object state FN-IDX) state)) | |
973 | ||
974 | (defn run-state-machine-wrapped [state] | |
975 | (try | |
976 | (run-state-machine state) | |
977 | (catch Throwable ex | |
978 | (impl/close! (aget-object state USER-START-IDX)) | |
979 | (throw ex)))) | |
980 | ||
981 | (defn take! [state blk c] | |
982 | (if-let [cb (impl/take! c (fn-handler | |
983 | (fn [x] | |
984 | (aset-all! state VALUE-IDX x STATE-IDX blk) | |
985 | (run-state-machine-wrapped state))))] | |
986 | (do (aset-all! state VALUE-IDX @cb STATE-IDX blk) | |
987 | :recur) | |
988 | nil)) | |
989 | ||
990 | (defn put! [state blk c val] | |
991 | (if-let [cb (impl/put! c val (fn-handler (fn [ret-val] | |
992 | (aset-all! state VALUE-IDX ret-val STATE-IDX blk) | |
993 | (run-state-machine-wrapped state))))] | |
994 | (do (aset-all! state VALUE-IDX @cb STATE-IDX blk) | |
995 | :recur) | |
996 | nil)) | |
997 | ||
998 | (defn return-chan [state value] | |
999 | (let [c (aget-object state USER-START-IDX)] | |
1000 | (when-not (nil? value) | |
1001 | (impl/put! c value (fn-handler (fn [] nil)))) | |
1002 | (impl/close! c) | |
1003 | c)) | |
1004 | ||
1005 | ||
1006 | (def async-custom-terminators | |
1007 | {'clojure.core.async/<! `take! | |
1008 | 'clojure.core.async/>! `put! | |
1009 | 'clojure.core.async/alts! 'clojure.core.async/ioc-alts! | |
1010 | :Return `return-chan}) | |
1011 | ||
1012 | (defn mark-transitions | |
1013 | {:pass-info {:walk :post :depends #{} :after an-jvm/default-passes}} | |
1014 | [{:keys [op fn] :as ast}] | |
1015 | (let [transitions (-> (env/deref-env) :passes-opts :mark-transitions/transitions)] | |
1016 | (if (and (= op :invoke) | |
1017 | (= (:op fn) :var) | |
1018 | (contains? transitions (var-name (:var fn)))) | |
1019 | (merge ast | |
1020 | {:op :transition | |
1021 | :name (get transitions (var-name (:var fn)))}) | |
1022 | ast))) | |
1023 | ||
1024 | (defn propagate-transitions | |
1025 | {:pass-info {:walk :post :depends #{#'mark-transitions}}} | |
1026 | [{:keys [op] :as ast}] | |
1027 | (if (or (= op :transition) | |
1028 | (some #(or (= (:op %) :transition) | |
1029 | (::transform? %)) | |
1030 | (ast/children ast))) | |
1031 | (assoc ast ::transform? true) | |
1032 | ast)) | |
1033 | ||
1034 | (defn propagate-recur | |
1035 | {:pass-info {:walk :post :depends #{#'annotate-loops #'propagate-transitions}}} | |
1036 | [ast] | |
1037 | (if (and (= (:op ast) :loop) | |
1038 | (::transform? ast)) | |
1039 | ;; If we are a loop and we need to transform, and | |
1040 | ;; one of our children is a recur, then we must transform everything | |
1041 | ;; that has a recur | |
1042 | (let [loop-id (:loop-id ast)] | |
1043 | (ast/postwalk ast #(if (contains? (:loops %) loop-id) | |
1044 | (assoc % ::transform? true) | |
1045 | %))) | |
1046 | ast)) | |
1047 | ||
1048 | (defn nested-go? [env] | |
1049 | (-> env vals first map?)) | |
1050 | ||
1051 | (defn make-env [input-env crossing-env] | |
1052 | (assoc (an-jvm/empty-env) | |
1053 | :locals (into {} | |
1054 | (if (nested-go? input-env) | |
1055 | (for [[l expr] input-env | |
1056 | :let [local (get crossing-env l)]] | |
1057 | [local (-> expr | |
1058 | (assoc :form local) | |
1059 | (assoc :name local))]) | |
1060 | (for [l (keys input-env) | |
1061 | :let [local (get crossing-env l)]] | |
1062 | [local {:op :local | |
1063 | :form local | |
1064 | :name local}]))))) | |
1065 | ||
1066 | (defn pdebug [x] | |
1067 | (clojure.pprint/pprint x) | |
1068 | (println "----") | |
1069 | x) | |
1070 | ||
1071 | (def passes (into (disj an-jvm/default-passes #'warn-on-reflection) | |
1072 | #{#'propagate-recur | |
1073 | #'propagate-transitions | |
1074 | #'mark-transitions})) | |
1075 | ||
1076 | (def run-passes | |
1077 | (schedule passes)) | |
1078 | ||
1079 | (defn emit-hinted [local tag env] | |
1080 | (let [tag (or tag (-> local meta :tag)) | |
1081 | init (list (get env local))] | |
1082 | (if-let [prim-fn (case (cond-> tag (string? tag) symbol) | |
1083 | int `int | |
1084 | long `long | |
1085 | char `char | |
1086 | float `float | |
1087 | double `double | |
1088 | byte `byte | |
1089 | short `short | |
1090 | boolean `boolean | |
1091 | nil)] | |
1092 | [(vary-meta local dissoc :tag) (list prim-fn init)] | |
1093 | [(vary-meta local merge (when tag {:tag tag})) init]))) | |
1094 | ||
1095 | (defn state-machine [body num-user-params [crossing-env env] user-transitions] | |
1096 | (binding [an-jvm/run-passes run-passes] | |
1097 | (-> (an-jvm/analyze `(let [~@(if (nested-go? env) | |
1098 | (mapcat (fn [[l {:keys [tag]}]] | |
1099 | (emit-hinted l tag crossing-env)) | |
1100 | env) | |
1101 | (mapcat (fn [[l ^clojure.lang.Compiler$LocalBinding lb]] | |
1102 | (emit-hinted l (when (.hasJavaClass lb) | |
1103 | (some-> lb .getJavaClass .getName)) | |
1104 | crossing-env)) | |
1105 | env))] | |
1106 | ~body) | |
1107 | (make-env env crossing-env) | |
1108 | {:passes-opts (merge an-jvm/default-passes-opts | |
1109 | {:uniquify/uniquify-env true | |
1110 | :mark-transitions/transitions user-transitions})}) | |
1111 | (parse-to-state-machine user-transitions) | |
1112 | second | |
1113 | (emit-state-machine num-user-params user-transitions)))) |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns ^{:skip-wiki true} | |
9 | clojure.core.async.impl.mutex | |
10 | (:require [clojure.core.async.impl.protocols :as impl]) | |
11 | (:import [clojure.core.async Mutex] | |
12 | [java.util.concurrent.locks Lock ReentrantLock])) | |
13 | ||
14 | (defn mutex [] | |
15 | (let [m (ReentrantLock.)] | |
16 | (reify | |
17 | Lock | |
18 | (lock [_] (.lock m)) | |
19 | (unlock [_] (.unlock m))))) | |
20 | ||
21 | #_(defn mutex [] | |
22 | (let [cas (java.util.concurrent.atomic.AtomicInteger.)] | |
23 | (reify | |
24 | Lock | |
25 | (lock [_] (loop [got (.compareAndSet cas 0 1)] | |
26 | (if got | |
27 | nil | |
28 | (recur (.compareAndSet cas 0 1))))) | |
29 | (unlock [_] (.set cas 0))))) |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns ^{:skip-wiki true} | |
9 | clojure.core.async.impl.protocols) | |
10 | ||
11 | ||
12 | (def ^:const ^{:tag 'int} MAX-QUEUE-SIZE 1024) | |
13 | ||
14 | (defprotocol ReadPort | |
15 | (take! [port fn1-handler] "derefable val if taken, nil if take was enqueued")) | |
16 | ||
17 | (defprotocol WritePort | |
18 | (put! [port val fn1-handler] "derefable boolean (false iff already closed) if handled, nil if put was enqueued. Must throw on nil val.")) | |
19 | ||
20 | (defprotocol Channel | |
21 | (close! [chan]) | |
22 | (closed? [chan])) | |
23 | ||
24 | (defprotocol Handler | |
25 | (active? [h] "returns true if has callback. Must work w/o lock") | |
26 | (blockable? [h] "returns true if this handler may be blocked, otherwise it must not block") | |
27 | (lock-id [h] "a unique id for lock acquisition order, 0 if no lock") | |
28 | (commit [h] "commit to fulfilling its end of the transfer, returns cb. Must be called within lock")) | |
29 | ||
30 | (defprotocol Buffer | |
31 | (full? [b] "returns true if buffer cannot accept put") | |
32 | (remove! [b] "remove and return next item from buffer, called under chan mutex") | |
33 | (add!* [b itm] "if room, add item to the buffer, returns b, called under chan mutex") | |
34 | (close-buf! [b] "called on chan closed under chan mutex, return ignored")) | |
35 | ||
36 | (defn add! | |
37 | ([b] b) | |
38 | ([b itm] | |
39 | (assert (not (nil? itm))) | |
40 | (add!* b itm))) | |
41 | ||
42 | (defprotocol Executor | |
43 | (exec [e runnable] "execute runnable asynchronously")) | |
44 | ||
45 | ;; Defines a buffer that will never block (return true to full?) | |
46 | (defprotocol UnblockingBuffer) |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns ^{:skip-wiki true} | |
9 | clojure.core.async.impl.timers | |
10 | (:require [clojure.core.async.impl.protocols :as impl] | |
11 | [clojure.core.async.impl.channels :as channels]) | |
12 | (:import [java.util.concurrent DelayQueue Delayed TimeUnit ConcurrentSkipListMap])) | |
13 | ||
14 | (set! *warn-on-reflection* true) | |
15 | ||
16 | (defonce ^:private ^DelayQueue timeouts-queue | |
17 | (DelayQueue.)) | |
18 | ||
19 | (defonce ^:private ^ConcurrentSkipListMap timeouts-map | |
20 | (ConcurrentSkipListMap.)) | |
21 | ||
22 | (def ^:const TIMEOUT_RESOLUTION_MS 10) | |
23 | ||
24 | (deftype TimeoutQueueEntry [channel ^long timestamp] | |
25 | Delayed | |
26 | (getDelay [this time-unit] | |
27 | (.convert time-unit | |
28 | (- timestamp (System/currentTimeMillis)) | |
29 | TimeUnit/MILLISECONDS)) | |
30 | (compareTo | |
31 | [this other] | |
32 | (let [ostamp (.timestamp ^TimeoutQueueEntry other)] | |
33 | (if (< timestamp ostamp) | |
34 | -1 | |
35 | (if (= timestamp ostamp) | |
36 | 0 | |
37 | 1)))) | |
38 | impl/Channel | |
39 | (close! [this] | |
40 | (impl/close! channel))) | |
41 | ||
42 | (defn timeout | |
43 | "returns a channel that will close after msecs" | |
44 | [^long msecs] | |
45 | (let [timeout (+ (System/currentTimeMillis) msecs) | |
46 | me (.ceilingEntry timeouts-map timeout)] | |
47 | (or (when (and me (< (.getKey me) (+ timeout TIMEOUT_RESOLUTION_MS))) | |
48 | (.channel ^TimeoutQueueEntry (.getValue me))) | |
49 | (let [timeout-channel (channels/chan nil) | |
50 | timeout-entry (TimeoutQueueEntry. timeout-channel timeout)] | |
51 | (.put timeouts-map timeout timeout-entry) | |
52 | (.put timeouts-queue timeout-entry) | |
53 | timeout-channel)))) | |
54 | ||
55 | (defn- timeout-worker | |
56 | [] | |
57 | (let [q timeouts-queue] | |
58 | (loop [] | |
59 | (let [^TimeoutQueueEntry tqe (.take q)] | |
60 | (.remove timeouts-map (.timestamp tqe) tqe) | |
61 | (impl/close! tqe)) | |
62 | (recur)))) | |
63 | ||
64 | (defonce timeout-daemon | |
65 | (doto (Thread. ^Runnable timeout-worker "clojure.core.async.timers/timeout-daemon") | |
66 | (.setDaemon true) | |
67 | (.start))) |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns clojure.core.async.lab | |
9 | "core.async HIGHLY EXPERIMENTAL feature exploration | |
10 | ||
11 | Caveats: | |
12 | ||
13 | 1. Everything defined in this namespace is experimental, and subject | |
14 | to change or deletion without warning. | |
15 | ||
16 | 2. Many features provided by this namespace are highly coupled to | |
17 | implementation details of core.async. Potential features which | |
18 | operate at higher levels of abstraction are suitable for inclusion | |
19 | in the examples. | |
20 | ||
21 | 3. Features provided by this namespace MAY be promoted to | |
22 | clojure.core.async at a later point in time, but there is no | |
23 | guarantee any of them will." | |
24 | (:require [clojure.core.async :as async] | |
25 | [clojure.core.async.impl.protocols :as impl] | |
26 | [clojure.core.async.impl.mutex :as mutex] | |
27 | [clojure.core.async.impl.dispatch :as dispatch] | |
28 | [clojure.core.async.impl.channels :as channels]) | |
29 | (:import [java.util HashSet Set Collection] | |
30 | [java.util.concurrent.locks Lock])) | |
31 | ||
32 | (deftype MultiplexingReadPort | |
33 | [^Lock mutex ^Set read-ports] | |
34 | impl/ReadPort | |
35 | (take! [this handler] | |
36 | (if (empty? read-ports) | |
37 | (channels/box nil) | |
38 | (do | |
39 | (.lock mutex) | |
40 | (let [^Lock handler handler | |
41 | commit-handler (fn [] | |
42 | (.lock handler) | |
43 | (let [take-cb (and (impl/active? handler) (impl/commit handler))] | |
44 | (.unlock handler) | |
45 | take-cb)) | |
46 | fret (fn [[val alt-port]] | |
47 | (if (nil? val) | |
48 | (do (.lock mutex) | |
49 | (.remove read-ports alt-port) | |
50 | (.unlock mutex) | |
51 | (impl/take! this handler)) | |
52 | (when-let [take-cb (commit-handler)] | |
53 | (dispatch/run #(take-cb val))))) | |
54 | current-ports (seq read-ports)] | |
55 | (if-let [alt-res (async/do-alts fret current-ports {})] | |
56 | (let [[val alt-port] @alt-res] | |
57 | (if (nil? val) | |
58 | (do (.remove read-ports alt-port) | |
59 | (.unlock mutex) | |
60 | (recur handler)) | |
61 | (do (.unlock mutex) | |
62 | (when-let [take-cb (commit-handler)] | |
63 | (dispatch/run #(take-cb val)))))) | |
64 | (do | |
65 | (.unlock mutex) | |
66 | nil))))))) | |
67 | ||
68 | (defn multiplex | |
69 | "Returns a multiplexing read port which, when read from, produces a | |
70 | value from one of ports. | |
71 | ||
72 | If at read time only one port is available to be read from, the | |
73 | multiplexing port will return that value. If multiple ports are | |
74 | available to be read from, the multiplexing port will return one | |
75 | value from a port chosen non-deterministicly. If no port is | |
76 | available to be read from, parks execution until a value is | |
77 | available." | |
78 | [& ports] | |
79 | (->MultiplexingReadPort (mutex/mutex) (HashSet. ^Collection ports))) | |
80 | ||
81 | (defn- broadcast-write | |
82 | [port-set val handler] | |
83 | (if (= (count port-set) 1) | |
84 | (impl/put! (first port-set) val handler) | |
85 | (let [clauses (map (fn [port] [port val]) port-set) | |
86 | recur-step (fn [[_ port]] (broadcast-write (disj port-set port) val handler))] | |
87 | (when-let [alt-res (async/do-alts recur-step clauses {})] | |
88 | (recur (disj port-set (second @alt-res)) | |
89 | val | |
90 | handler))))) | |
91 | ||
92 | (deftype BroadcastingWritePort | |
93 | [write-ports] | |
94 | impl/WritePort | |
95 | (put! [port val handler] | |
96 | (broadcast-write write-ports val handler))) | |
97 | ||
98 | (defn broadcast | |
99 | "Returns a broadcasting write port which, when written to, writes | |
100 | the value to each of ports. | |
101 | ||
102 | Writes to the broadcasting port will park until the value is written | |
103 | to each of the ports used to create it. For this reason, it is | |
104 | strongly advised that each of the underlying ports support buffered | |
105 | writes." | |
106 | [& ports] | |
107 | (->BroadcastingWritePort (set ports)))⏎ |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns clojure.core.async | |
9 | "Facilities for async programming and communication. | |
10 | ||
11 | go blocks are dispatched over an internal thread pool, which | |
12 | defaults to 8 threads. The size of this pool can be modified using | |
13 | the Java system property `clojure.core.async.pool-size`." | |
14 | (:refer-clojure :exclude [reduce transduce into merge map take partition | |
15 | partition-by bounded-count]) | |
16 | (:require [clojure.core.async.impl.protocols :as impl] | |
17 | [clojure.core.async.impl.channels :as channels] | |
18 | [clojure.core.async.impl.buffers :as buffers] | |
19 | [clojure.core.async.impl.timers :as timers] | |
20 | [clojure.core.async.impl.dispatch :as dispatch] | |
21 | [clojure.core.async.impl.ioc-macros :as ioc] | |
22 | [clojure.core.async.impl.mutex :as mutex] | |
23 | [clojure.core.async.impl.concurrent :as conc] | |
24 | ) | |
25 | (:import [clojure.core.async ThreadLocalRandom] | |
26 | [java.util.concurrent.locks Lock] | |
27 | [java.util.concurrent Executors Executor] | |
28 | [java.util ArrayList])) | |
29 | ||
30 | (alias 'core 'clojure.core) | |
31 | ||
32 | (set! *warn-on-reflection* false) | |
33 | ||
34 | (defn fn-handler | |
35 | ([f] | |
36 | (fn-handler f true)) | |
37 | ([f blockable] | |
38 | (reify | |
39 | Lock | |
40 | (lock [_]) | |
41 | (unlock [_]) | |
42 | ||
43 | impl/Handler | |
44 | (active? [_] true) | |
45 | (blockable? [_] blockable) | |
46 | (lock-id [_] 0) | |
47 | (commit [_] f)))) | |
48 | ||
49 | (defn buffer | |
50 | "Returns a fixed buffer of size n. When full, puts will block/park." | |
51 | [n] | |
52 | (buffers/fixed-buffer n)) | |
53 | ||
54 | (defn dropping-buffer | |
55 | "Returns a buffer of size n. When full, puts will complete but | |
56 | val will be dropped (no transfer)." | |
57 | [n] | |
58 | (buffers/dropping-buffer n)) | |
59 | ||
60 | (defn sliding-buffer | |
61 | "Returns a buffer of size n. When full, puts will complete, and be | |
62 | buffered, but oldest elements in buffer will be dropped (not | |
63 | transferred)." | |
64 | [n] | |
65 | (buffers/sliding-buffer n)) | |
66 | ||
67 | (defn unblocking-buffer? | |
68 | "Returns true if a channel created with buff will never block. That is to say, | |
69 | puts into this buffer will never cause the buffer to be full. " | |
70 | [buff] | |
71 | (extends? impl/UnblockingBuffer (class buff))) | |
72 | ||
73 | (defn chan | |
74 | "Creates a channel with an optional buffer, an optional transducer | |
75 | (like (map f), (filter p) etc or a composition thereof), and an | |
76 | optional exception-handler. If buf-or-n is a number, will create | |
77 | and use a fixed buffer of that size. If a transducer is supplied a | |
78 | buffer must be specified. ex-handler must be a fn of one argument - | |
79 | if an exception occurs during transformation it will be called with | |
80 | the Throwable as an argument, and any non-nil return value will be | |
81 | placed in the channel." | |
82 | ([] (chan nil)) | |
83 | ([buf-or-n] (chan buf-or-n nil)) | |
84 | ([buf-or-n xform] (chan buf-or-n xform nil)) | |
85 | ([buf-or-n xform ex-handler] | |
86 | (when (and buf-or-n (number? buf-or-n)) (assert (pos? buf-or-n) "fixed buffers must have size > 0")) | |
87 | (when xform (assert buf-or-n "buffer must be supplied when transducer is")) | |
88 | (channels/chan (if (number? buf-or-n) (buffer buf-or-n) buf-or-n) xform ex-handler))) | |
89 | ||
90 | (defn promise-chan | |
91 | "Creates a promise channel with an optional transducer, and an optional | |
92 | exception-handler. A promise channel can take exactly one value that consumers | |
93 | will receive. Once full, puts complete but val is dropped (no transfer). | |
94 | Consumers will block until either a value is placed in the channel or the | |
95 | channel is closed. See chan for the semantics of xform and ex-handler." | |
96 | ([] (promise-chan nil)) | |
97 | ([xform] (promise-chan xform nil)) | |
98 | ([xform ex-handler] | |
99 | (chan (buffers/promise-buffer) xform ex-handler))) | |
100 | ||
101 | (defn timeout | |
102 | "Returns a channel that will close after msecs" | |
103 | [^long msecs] | |
104 | (timers/timeout msecs)) | |
105 | ||
106 | (defn <!! | |
107 | "takes a val from port. Will return nil if closed. Will block | |
108 | if nothing is available." | |
109 | [port] | |
110 | (let [p (promise) | |
111 | ret (impl/take! port (fn-handler (fn [v] (deliver p v))))] | |
112 | (if ret | |
113 | @ret | |
114 | (deref p)))) | |
115 | ||
116 | (defn <! | |
117 | "takes a val from port. Must be called inside a (go ...) block. Will | |
118 | return nil if closed. Will park if nothing is available." | |
119 | [port] | |
120 | (assert nil "<! used not in (go ...) block")) | |
121 | ||
122 | (defn take! | |
123 | "Asynchronously takes a val from port, passing to fn1. Will pass nil | |
124 | if closed. If on-caller? (default true) is true, and value is | |
125 | immediately available, will call fn1 on calling thread. | |
126 | Returns nil." | |
127 | ([port fn1] (take! port fn1 true)) | |
128 | ([port fn1 on-caller?] | |
129 | (let [ret (impl/take! port (fn-handler fn1))] | |
130 | (when ret | |
131 | (let [val @ret] | |
132 | (if on-caller? | |
133 | (fn1 val) | |
134 | (dispatch/run #(fn1 val))))) | |
135 | nil))) | |
136 | ||
137 | (defn >!! | |
138 | "puts a val into port. nil values are not allowed. Will block if no | |
139 | buffer space is available. Returns true unless port is already closed." | |
140 | [port val] | |
141 | (let [p (promise) | |
142 | ret (impl/put! port val (fn-handler (fn [open?] (deliver p open?))))] | |
143 | (if ret | |
144 | @ret | |
145 | (deref p)))) | |
146 | ||
147 | (defn >! | |
148 | "puts a val into port. nil values are not allowed. Must be called | |
149 | inside a (go ...) block. Will park if no buffer space is available. | |
150 | Returns true unless port is already closed." | |
151 | [port val] | |
152 | (assert nil ">! used not in (go ...) block")) | |
153 | ||
154 | (defn- nop [_]) | |
155 | (def ^:private fhnop (fn-handler nop)) | |
156 | ||
157 | (defn put! | |
158 | "Asynchronously puts a val into port, calling fn1 (if supplied) when | |
159 | complete, passing false iff port is already closed. nil values are | |
160 | not allowed. If on-caller? (default true) is true, and the put is | |
161 | immediately accepted, will call fn1 on calling thread. Returns | |
162 | true unless port is already closed." | |
163 | ([port val] | |
164 | (if-let [ret (impl/put! port val fhnop)] | |
165 | @ret | |
166 | true)) | |
167 | ([port val fn1] (put! port val fn1 true)) | |
168 | ([port val fn1 on-caller?] | |
169 | (if-let [retb (impl/put! port val (fn-handler fn1))] | |
170 | (let [ret @retb] | |
171 | (if on-caller? | |
172 | (fn1 ret) | |
173 | (dispatch/run #(fn1 ret))) | |
174 | ret) | |
175 | true))) | |
176 | ||
177 | (defn close! | |
178 | "Closes a channel. The channel will no longer accept any puts (they | |
179 | will be ignored). Data in the channel remains available for taking, until | |
180 | exhausted, after which takes will return nil. If there are any | |
181 | pending takes, they will be dispatched with nil. Closing a closed | |
182 | channel is a no-op. Returns nil. | |
183 | ||
184 | Logically closing happens after all puts have been delivered. Therefore, any | |
185 | blocked or parked puts will remain blocked/parked until a taker releases them." | |
186 | ||
187 | [chan] | |
188 | (impl/close! chan)) | |
189 | ||
190 | (defonce ^:private ^java.util.concurrent.atomic.AtomicLong id-gen (java.util.concurrent.atomic.AtomicLong.)) | |
191 | ||
192 | (defn- random-array | |
193 | [n] | |
194 | (let [rand (ThreadLocalRandom/current) | |
195 | a (int-array n)] | |
196 | (loop [i 1] | |
197 | (if (= i n) | |
198 | a | |
199 | (do | |
200 | (let [j (.nextInt rand (inc i))] | |
201 | (aset a i (aget a j)) | |
202 | (aset a j i) | |
203 | (recur (inc i)))))))) | |
204 | ||
205 | (defn- alt-flag [] | |
206 | (let [^Lock m (mutex/mutex) | |
207 | flag (atom true) | |
208 | id (.incrementAndGet id-gen)] | |
209 | (reify | |
210 | Lock | |
211 | (lock [_] (.lock m)) | |
212 | (unlock [_] (.unlock m)) | |
213 | ||
214 | impl/Handler | |
215 | (active? [_] @flag) | |
216 | (blockable? [_] true) | |
217 | (lock-id [_] id) | |
218 | (commit [_] | |
219 | (reset! flag nil) | |
220 | true)))) | |
221 | ||
222 | (defn- alt-handler [^Lock flag cb] | |
223 | (reify | |
224 | Lock | |
225 | (lock [_] (.lock flag)) | |
226 | (unlock [_] (.unlock flag)) | |
227 | ||
228 | impl/Handler | |
229 | (active? [_] (impl/active? flag)) | |
230 | (blockable? [_] true) | |
231 | (lock-id [_] (impl/lock-id flag)) | |
232 | (commit [_] | |
233 | (impl/commit flag) | |
234 | cb))) | |
235 | ||
236 | (defn do-alts | |
237 | "returns derefable [val port] if immediate, nil if enqueued" | |
238 | [fret ports opts] | |
239 | (let [flag (alt-flag) | |
240 | n (count ports) | |
241 | ^ints idxs (random-array n) | |
242 | priority (:priority opts) | |
243 | ret | |
244 | (loop [i 0] | |
245 | (when (< i n) | |
246 | (let [idx (if priority i (aget idxs i)) | |
247 | port (nth ports idx) | |
248 | wport (when (vector? port) (port 0)) | |
249 | vbox (if wport | |
250 | (let [val (port 1)] | |
251 | (impl/put! wport val (alt-handler flag #(fret [% wport])))) | |
252 | (impl/take! port (alt-handler flag #(fret [% port]))))] | |
253 | (if vbox | |
254 | (channels/box [@vbox (or wport port)]) | |
255 | (recur (inc i))))))] | |
256 | (or | |
257 | ret | |
258 | (when (contains? opts :default) | |
259 | (.lock ^Lock flag) | |
260 | (let [got (and (impl/active? flag) (impl/commit flag))] | |
261 | (.unlock ^Lock flag) | |
262 | (when got | |
263 | (channels/box [(:default opts) :default]))))))) | |
264 | ||
265 | (defn alts!! | |
266 | "Like alts!, except takes will be made as if by <!!, and puts will | |
267 | be made as if by >!!, will block until completed, and not intended | |
268 | for use in (go ...) blocks." | |
269 | [ports & {:as opts}] | |
270 | (let [p (promise) | |
271 | ret (do-alts (partial deliver p) ports opts)] | |
272 | (if ret | |
273 | @ret | |
274 | (deref p)))) | |
275 | ||
276 | (defn alts! | |
277 | "Completes at most one of several channel operations. Must be called | |
278 | inside a (go ...) block. ports is a vector of channel endpoints, | |
279 | which can be either a channel to take from or a vector of | |
280 | [channel-to-put-to val-to-put], in any combination. Takes will be | |
281 | made as if by <!, and puts will be made as if by >!. Unless | |
282 | the :priority option is true, if more than one port operation is | |
283 | ready a non-deterministic choice will be made. If no operation is | |
284 | ready and a :default value is supplied, [default-val :default] will | |
285 | be returned, otherwise alts! will park until the first operation to | |
286 | become ready completes. Returns [val port] of the completed | |
287 | operation, where val is the value taken for takes, and a | |
288 | boolean (true unless already closed, as per put!) for puts. | |
289 | ||
290 | opts are passed as :key val ... Supported options: | |
291 | ||
292 | :default val - the value to use if none of the operations are immediately ready | |
293 | :priority true - (default nil) when true, the operations will be tried in order. | |
294 | ||
295 | Note: there is no guarantee that the port exps or val exprs will be | |
296 | used, nor in what order should they be, so they should not be | |
297 | depended upon for side effects." | |
298 | ||
299 | [ports & {:as opts}] | |
300 | (assert nil "alts! used not in (go ...) block")) | |
301 | ||
302 | (defn do-alt [alts clauses] | |
303 | (assert (even? (count clauses)) "unbalanced clauses") | |
304 | (let [clauses (core/partition 2 clauses) | |
305 | opt? #(keyword? (first %)) | |
306 | opts (filter opt? clauses) | |
307 | clauses (remove opt? clauses) | |
308 | [clauses bindings] | |
309 | (core/reduce | |
310 | (fn [[clauses bindings] [ports expr]] | |
311 | (let [ports (if (vector? ports) ports [ports]) | |
312 | [ports bindings] | |
313 | (core/reduce | |
314 | (fn [[ports bindings] port] | |
315 | (if (vector? port) | |
316 | (let [[port val] port | |
317 | gp (gensym) | |
318 | gv (gensym)] | |
319 | [(conj ports [gp gv]) (conj bindings [gp port] [gv val])]) | |
320 | (let [gp (gensym)] | |
321 | [(conj ports gp) (conj bindings [gp port])]))) | |
322 | [[] bindings] ports)] | |
323 | [(conj clauses [ports expr]) bindings])) | |
324 | [[] []] clauses) | |
325 | gch (gensym "ch") | |
326 | gret (gensym "ret")] | |
327 | `(let [~@(mapcat identity bindings) | |
328 | [val# ~gch :as ~gret] (~alts [~@(apply concat (core/map first clauses))] ~@(apply concat opts))] | |
329 | (cond | |
330 | ~@(mapcat (fn [[ports expr]] | |
331 | [`(or ~@(core/map (fn [port] | |
332 | `(= ~gch ~(if (vector? port) (first port) port))) | |
333 | ports)) | |
334 | (if (and (seq? expr) (vector? (first expr))) | |
335 | `(let [~(first expr) ~gret] ~@(rest expr)) | |
336 | expr)]) | |
337 | clauses) | |
338 | (= ~gch :default) val#)))) | |
339 | ||
340 | (defmacro alt!! | |
341 | "Like alt!, except as if by alts!!, will block until completed, and | |
342 | not intended for use in (go ...) blocks." | |
343 | ||
344 | [& clauses] | |
345 | (do-alt `alts!! clauses)) | |
346 | ||
347 | (defmacro alt! | |
348 | "Makes a single choice between one of several channel operations, | |
349 | as if by alts!, returning the value of the result expr corresponding | |
350 | to the operation completed. Must be called inside a (go ...) block. | |
351 | ||
352 | Each clause takes the form of: | |
353 | ||
354 | channel-op[s] result-expr | |
355 | ||
356 | where channel-ops is one of: | |
357 | ||
358 | take-port - a single port to take | |
359 | [take-port | [put-port put-val] ...] - a vector of ports as per alts! | |
360 | :default | :priority - an option for alts! | |
361 | ||
362 | and result-expr is either a list beginning with a vector, whereupon that | |
363 | vector will be treated as a binding for the [val port] return of the | |
364 | operation, else any other expression. | |
365 | ||
366 | (alt! | |
367 | [c t] ([val ch] (foo ch val)) | |
368 | x ([v] v) | |
369 | [[out val]] :wrote | |
370 | :default 42) | |
371 | ||
372 | Each option may appear at most once. The choice and parking | |
373 | characteristics are those of alts!." | |
374 | ||
375 | [& clauses] | |
376 | (do-alt `alts! clauses)) | |
377 | ||
378 | (defn ioc-alts! [state cont-block ports & {:as opts}] | |
379 | (ioc/aset-all! state ioc/STATE-IDX cont-block) | |
380 | (when-let [cb (clojure.core.async/do-alts | |
381 | (fn [val] | |
382 | (ioc/aset-all! state ioc/VALUE-IDX val) | |
383 | (ioc/run-state-machine-wrapped state)) | |
384 | ports | |
385 | opts)] | |
386 | (ioc/aset-all! state ioc/VALUE-IDX @cb) | |
387 | :recur)) | |
388 | ||
389 | (defn offer! | |
390 | "Puts a val into port if it's possible to do so immediately. | |
391 | nil values are not allowed. Never blocks. Returns true if offer succeeds." | |
392 | [port val] | |
393 | (let [ret (impl/put! port val (fn-handler nop false))] | |
394 | (when ret @ret))) | |
395 | ||
396 | (defn poll! | |
397 | "Takes a val from port if it's possible to do so immediately. | |
398 | Never blocks. Returns value if successful, nil otherwise." | |
399 | [port] | |
400 | (let [ret (impl/take! port (fn-handler nop false))] | |
401 | (when ret @ret))) | |
402 | ||
403 | (defmacro go | |
404 | "Asynchronously executes the body, returning immediately to the | |
405 | calling thread. Additionally, any visible calls to <!, >! and alt!/alts! | |
406 | channel operations within the body will block (if necessary) by | |
407 | 'parking' the calling thread rather than tying up an OS thread (or | |
408 | the only JS thread when in ClojureScript). Upon completion of the | |
409 | operation, the body will be resumed. | |
410 | ||
411 | Returns a channel which will receive the result of the body when | |
412 | completed" | |
413 | [& body] | |
414 | (let [crossing-env (zipmap (keys &env) (repeatedly gensym))] | |
415 | `(let [c# (chan 1) | |
416 | captured-bindings# (clojure.lang.Var/getThreadBindingFrame)] | |
417 | (dispatch/run | |
418 | (^:once fn* [] | |
419 | (let [~@(mapcat (fn [[l sym]] [sym `(^:once fn* [] ~(vary-meta l dissoc :tag))]) crossing-env) | |
420 | f# ~(ioc/state-machine `(do ~@body) 1 [crossing-env &env] ioc/async-custom-terminators) | |
421 | state# (-> (f#) | |
422 | (ioc/aset-all! ioc/USER-START-IDX c# | |
423 | ioc/BINDINGS-IDX captured-bindings#))] | |
424 | (ioc/run-state-machine-wrapped state#)))) | |
425 | c#))) | |
426 | ||
427 | (defonce ^:private ^Executor thread-macro-executor | |
428 | (Executors/newCachedThreadPool (conc/counted-thread-factory "async-thread-macro-%d" true))) | |
429 | ||
430 | (defn thread-call | |
431 | "Executes f in another thread, returning immediately to the calling | |
432 | thread. Returns a channel which will receive the result of calling | |
433 | f when completed, then close." | |
434 | [f] | |
435 | (let [c (chan 1)] | |
436 | (let [binds (clojure.lang.Var/getThreadBindingFrame)] | |
437 | (.execute thread-macro-executor | |
438 | (fn [] | |
439 | (clojure.lang.Var/resetThreadBindingFrame binds) | |
440 | (try | |
441 | (let [ret (f)] | |
442 | (when-not (nil? ret) | |
443 | (>!! c ret))) | |
444 | (finally | |
445 | (close! c)))))) | |
446 | c)) | |
447 | ||
448 | (defmacro thread | |
449 | "Executes the body in another thread, returning immediately to the | |
450 | calling thread. Returns a channel which will receive the result of | |
451 | the body when completed, then close." | |
452 | [& body] | |
453 | `(thread-call (^:once fn* [] ~@body))) | |
454 | ||
455 | ;;;;;;;;;;;;;;;;;;;; ops ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
456 | ||
457 | (defmacro go-loop | |
458 | "Like (go (loop ...))" | |
459 | [bindings & body] | |
460 | `(go (loop ~bindings ~@body))) | |
461 | ||
462 | (defn pipe | |
463 | "Takes elements from the from channel and supplies them to the to | |
464 | channel. By default, the to channel will be closed when the from | |
465 | channel closes, but can be determined by the close? parameter. Will | |
466 | stop consuming the from channel if the to channel closes" | |
467 | ([from to] (pipe from to true)) | |
468 | ([from to close?] | |
469 | (go-loop [] | |
470 | (let [v (<! from)] | |
471 | (if (nil? v) | |
472 | (when close? (close! to)) | |
473 | (when (>! to v) | |
474 | (recur))))) | |
475 | to)) | |
476 | ||
477 | (defn- pipeline* | |
478 | ([n to xf from close? ex-handler type] | |
479 | (assert (pos? n)) | |
480 | (let [ex-handler (or ex-handler (fn [ex] | |
481 | (-> (Thread/currentThread) | |
482 | .getUncaughtExceptionHandler | |
483 | (.uncaughtException (Thread/currentThread) ex)) | |
484 | nil)) | |
485 | jobs (chan n) | |
486 | results (chan n) | |
487 | process (fn [[v p :as job]] | |
488 | (if (nil? job) | |
489 | (do (close! results) nil) | |
490 | (let [res (chan 1 xf ex-handler)] | |
491 | (>!! res v) | |
492 | (close! res) | |
493 | (put! p res) | |
494 | true))) | |
495 | async (fn [[v p :as job]] | |
496 | (if (nil? job) | |
497 | (do (close! results) nil) | |
498 | (let [res (chan 1)] | |
499 | (xf v res) | |
500 | (put! p res) | |
501 | true)))] | |
502 | (dotimes [_ n] | |
503 | (case type | |
504 | :blocking (thread | |
505 | (let [job (<!! jobs)] | |
506 | (when (process job) | |
507 | (recur)))) | |
508 | :compute (go-loop [] | |
509 | (let [job (<! jobs)] | |
510 | (when (process job) | |
511 | (recur)))) | |
512 | :async (go-loop [] | |
513 | (let [job (<! jobs)] | |
514 | (when (async job) | |
515 | (recur)))))) | |
516 | (go-loop [] | |
517 | (let [v (<! from)] | |
518 | (if (nil? v) | |
519 | (close! jobs) | |
520 | (let [p (chan 1)] | |
521 | (>! jobs [v p]) | |
522 | (>! results p) | |
523 | (recur))))) | |
524 | (go-loop [] | |
525 | (let [p (<! results)] | |
526 | (if (nil? p) | |
527 | (when close? (close! to)) | |
528 | (let [res (<! p)] | |
529 | (loop [] | |
530 | (let [v (<! res)] | |
531 | (when (and (not (nil? v)) (>! to v)) | |
532 | (recur)))) | |
533 | (recur)))))))) | |
534 | ||
535 | ;;todo - switch pipe arg order to match these (to/from) | |
536 | (defn pipeline | |
537 | "Takes elements from the from channel and supplies them to the to | |
538 | channel, subject to the transducer xf, with parallelism n. Because | |
539 | it is parallel, the transducer will be applied independently to each | |
540 | element, not across elements, and may produce zero or more outputs | |
541 | per input. Outputs will be returned in order relative to the | |
542 | inputs. By default, the to channel will be closed when the from | |
543 | channel closes, but can be determined by the close? parameter. Will | |
544 | stop consuming the from channel if the to channel closes. Note this | |
545 | should be used for computational parallelism. If you have multiple | |
546 | blocking operations to put in flight, use pipeline-blocking instead, | |
547 | If you have multiple asynchronous operations to put in flight, use | |
548 | pipeline-async instead." | |
549 | ([n to xf from] (pipeline n to xf from true)) | |
550 | ([n to xf from close?] (pipeline n to xf from close? nil)) | |
551 | ([n to xf from close? ex-handler] (pipeline* n to xf from close? ex-handler :compute))) | |
552 | ||
553 | (defn pipeline-blocking | |
554 | "Like pipeline, for blocking operations." | |
555 | ([n to xf from] (pipeline-blocking n to xf from true)) | |
556 | ([n to xf from close?] (pipeline-blocking n to xf from close? nil)) | |
557 | ([n to xf from close? ex-handler] (pipeline* n to xf from close? ex-handler :blocking))) | |
558 | ||
559 | (defn pipeline-async | |
560 | "Takes elements from the from channel and supplies them to the to | |
561 | channel, subject to the async function af, with parallelism n. af | |
562 | must be a function of two arguments, the first an input value and | |
563 | the second a channel on which to place the result(s). af must close! | |
564 | the channel before returning. The presumption is that af will | |
565 | return immediately, having launched some asynchronous operation | |
566 | (i.e. in another thread) whose completion/callback will manipulate | |
567 | the result channel. Outputs will be returned in order relative to | |
568 | the inputs. By default, the to channel will be closed when the from | |
569 | channel closes, but can be determined by the close? parameter. Will | |
570 | stop consuming the from channel if the to channel closes. See also | |
571 | pipeline, pipeline-blocking." | |
572 | ([n to af from] (pipeline-async n to af from true)) | |
573 | ([n to af from close?] (pipeline* n to af from close? nil :async))) | |
574 | ||
575 | (defn split | |
576 | "Takes a predicate and a source channel and returns a vector of two | |
577 | channels, the first of which will contain the values for which the | |
578 | predicate returned true, the second those for which it returned | |
579 | false. | |
580 | ||
581 | The out channels will be unbuffered by default, or two buf-or-ns can | |
582 | be supplied. The channels will close after the source channel has | |
583 | closed." | |
584 | ([p ch] (split p ch nil nil)) | |
585 | ([p ch t-buf-or-n f-buf-or-n] | |
586 | (let [tc (chan t-buf-or-n) | |
587 | fc (chan f-buf-or-n)] | |
588 | (go-loop [] | |
589 | (let [v (<! ch)] | |
590 | (if (nil? v) | |
591 | (do (close! tc) (close! fc)) | |
592 | (when (>! (if (p v) tc fc) v) | |
593 | (recur))))) | |
594 | [tc fc]))) | |
595 | ||
596 | (defn reduce | |
597 | "f should be a function of 2 arguments. Returns a channel containing | |
598 | the single result of applying f to init and the first item from the | |
599 | channel, then applying f to that result and the 2nd item, etc. If | |
600 | the channel closes without yielding items, returns init and f is not | |
601 | called. ch must close before reduce produces a result." | |
602 | [f init ch] | |
603 | (go-loop [ret init] | |
604 | (let [v (<! ch)] | |
605 | (if (nil? v) | |
606 | ret | |
607 | (let [ret' (f ret v)] | |
608 | (if (reduced? ret') | |
609 | @ret' | |
610 | (recur ret'))))))) | |
611 | ||
612 | (defn transduce | |
613 | "async/reduces a channel with a transformation (xform f). | |
614 | Returns a channel containing the result. ch must close before | |
615 | transduce produces a result." | |
616 | [xform f init ch] | |
617 | (let [f (xform f)] | |
618 | (go | |
619 | (let [ret (<! (reduce f init ch))] | |
620 | (f ret))))) | |
621 | ||
622 | (defn- bounded-count | |
623 | "Returns the smaller of n or the count of coll, without examining | |
624 | more than n items if coll is not counted" | |
625 | [n coll] | |
626 | (if (counted? coll) | |
627 | (min n (count coll)) | |
628 | (loop [i 0 s (seq coll)] | |
629 | (if (and s (< i n)) | |
630 | (recur (inc i) (next s)) | |
631 | i)))) | |
632 | ||
633 | (defn onto-chan | |
634 | "Puts the contents of coll into the supplied channel. | |
635 | ||
636 | By default the channel will be closed after the items are copied, | |
637 | but can be determined by the close? parameter. | |
638 | ||
639 | Returns a channel which will close after the items are copied." | |
640 | ([ch coll] (onto-chan ch coll true)) | |
641 | ([ch coll close?] | |
642 | (go-loop [vs (seq coll)] | |
643 | (if (and vs (>! ch (first vs))) | |
644 | (recur (next vs)) | |
645 | (when close? | |
646 | (close! ch)))))) | |
647 | ||
648 | (defn to-chan | |
649 | "Creates and returns a channel which contains the contents of coll, | |
650 | closing when exhausted." | |
651 | [coll] | |
652 | (let [c (bounded-count 100 coll)] | |
653 | (if (pos? c) | |
654 | (let [ch (chan c)] | |
655 | (onto-chan ch coll) | |
656 | ch) | |
657 | (let [ch (chan)] | |
658 | (close! ch) | |
659 | ch)))) | |
660 | ||
661 | (defprotocol Mux | |
662 | (muxch* [_])) | |
663 | ||
664 | (defprotocol Mult | |
665 | (tap* [m ch close?]) | |
666 | (untap* [m ch]) | |
667 | (untap-all* [m])) | |
668 | ||
669 | (defn mult | |
670 | "Creates and returns a mult(iple) of the supplied channel. Channels | |
671 | containing copies of the channel can be created with 'tap', and | |
672 | detached with 'untap'. | |
673 | ||
674 | Each item is distributed to all taps in parallel and synchronously, | |
675 | i.e. each tap must accept before the next item is distributed. Use | |
676 | buffering/windowing to prevent slow taps from holding up the mult. | |
677 | ||
678 | Items received when there are no taps get dropped. | |
679 | ||
680 | If a tap puts to a closed channel, it will be removed from the mult." | |
681 | [ch] | |
682 | (let [cs (atom {}) ;;ch->close? | |
683 | m (reify | |
684 | Mux | |
685 | (muxch* [_] ch) | |
686 | ||
687 | Mult | |
688 | (tap* [_ ch close?] (swap! cs assoc ch close?) nil) | |
689 | (untap* [_ ch] (swap! cs dissoc ch) nil) | |
690 | (untap-all* [_] (reset! cs {}) nil)) | |
691 | dchan (chan 1) | |
692 | dctr (atom nil) | |
693 | done (fn [_] (when (zero? (swap! dctr dec)) | |
694 | (put! dchan true)))] | |
695 | (go-loop [] | |
696 | (let [val (<! ch)] | |
697 | (if (nil? val) | |
698 | (doseq [[c close?] @cs] | |
699 | (when close? (close! c))) | |
700 | (let [chs (keys @cs)] | |
701 | (reset! dctr (count chs)) | |
702 | (doseq [c chs] | |
703 | (when-not (put! c val done) | |
704 | (done nil) | |
705 | (untap* m c))) | |
706 | ;;wait for all | |
707 | (when (seq chs) | |
708 | (<! dchan)) | |
709 | (recur))))) | |
710 | m)) | |
711 | ||
712 | (defn tap | |
713 | "Copies the mult source onto the supplied channel. | |
714 | ||
715 | By default the channel will be closed when the source closes, | |
716 | but can be determined by the close? parameter." | |
717 | ([mult ch] (tap mult ch true)) | |
718 | ([mult ch close?] (tap* mult ch close?) ch)) | |
719 | ||
720 | (defn untap | |
721 | "Disconnects a target channel from a mult" | |
722 | [mult ch] | |
723 | (untap* mult ch)) | |
724 | ||
725 | (defn untap-all | |
726 | "Disconnects all target channels from a mult" | |
727 | [mult] (untap-all* mult)) | |
728 | ||
729 | (defprotocol Mix | |
730 | (admix* [m ch]) | |
731 | (unmix* [m ch]) | |
732 | (unmix-all* [m]) | |
733 | (toggle* [m state-map]) | |
734 | (solo-mode* [m mode])) | |
735 | ||
736 | (defn mix | |
737 | "Creates and returns a mix of one or more input channels which will | |
738 | be put on the supplied out channel. Input sources can be added to | |
739 | the mix with 'admix', and removed with 'unmix'. A mix supports | |
740 | soloing, muting and pausing multiple inputs atomically using | |
741 | 'toggle', and can solo using either muting or pausing as determined | |
742 | by 'solo-mode'. | |
743 | ||
744 | Each channel can have zero or more boolean modes set via 'toggle': | |
745 | ||
746 | :solo - when true, only this (ond other soloed) channel(s) will appear | |
747 | in the mix output channel. :mute and :pause states of soloed | |
748 | channels are ignored. If solo-mode is :mute, non-soloed | |
749 | channels are muted, if :pause, non-soloed channels are | |
750 | paused. | |
751 | ||
752 | :mute - muted channels will have their contents consumed but not included in the mix | |
753 | :pause - paused channels will not have their contents consumed (and thus also not included in the mix) | |
754 | " | |
755 | [out] | |
756 | (let [cs (atom {}) ;;ch->attrs-map | |
757 | solo-modes #{:mute :pause} | |
758 | attrs (conj solo-modes :solo) | |
759 | solo-mode (atom :mute) | |
760 | change (chan) | |
761 | changed #(put! change true) | |
762 | pick (fn [attr chs] | |
763 | (reduce-kv | |
764 | (fn [ret c v] | |
765 | (if (attr v) | |
766 | (conj ret c) | |
767 | ret)) | |
768 | #{} chs)) | |
769 | calc-state (fn [] | |
770 | (let [chs @cs | |
771 | mode @solo-mode | |
772 | solos (pick :solo chs) | |
773 | pauses (pick :pause chs)] | |
774 | {:solos solos | |
775 | :mutes (pick :mute chs) | |
776 | :reads (conj | |
777 | (if (and (= mode :pause) (not (empty? solos))) | |
778 | (vec solos) | |
779 | (vec (remove pauses (keys chs)))) | |
780 | change)})) | |
781 | m (reify | |
782 | Mux | |
783 | (muxch* [_] out) | |
784 | Mix | |
785 | (admix* [_ ch] (swap! cs assoc ch {}) (changed)) | |
786 | (unmix* [_ ch] (swap! cs dissoc ch) (changed)) | |
787 | (unmix-all* [_] (reset! cs {}) (changed)) | |
788 | (toggle* [_ state-map] (swap! cs (partial merge-with core/merge) state-map) (changed)) | |
789 | (solo-mode* [_ mode] | |
790 | (assert (solo-modes mode) (str "mode must be one of: " solo-modes)) | |
791 | (reset! solo-mode mode) | |
792 | (changed)))] | |
793 | (go-loop [{:keys [solos mutes reads] :as state} (calc-state)] | |
794 | (let [[v c] (alts! reads)] | |
795 | (if (or (nil? v) (= c change)) | |
796 | (do (when (nil? v) | |
797 | (swap! cs dissoc c)) | |
798 | (recur (calc-state))) | |
799 | (if (or (solos c) | |
800 | (and (empty? solos) (not (mutes c)))) | |
801 | (when (>! out v) | |
802 | (recur state)) | |
803 | (recur state))))) | |
804 | m)) | |
805 | ||
806 | (defn admix | |
807 | "Adds ch as an input to the mix" | |
808 | [mix ch] | |
809 | (admix* mix ch)) | |
810 | ||
811 | (defn unmix | |
812 | "Removes ch as an input to the mix" | |
813 | [mix ch] | |
814 | (unmix* mix ch)) | |
815 | ||
816 | (defn unmix-all | |
817 | "removes all inputs from the mix" | |
818 | [mix] | |
819 | (unmix-all* mix)) | |
820 | ||
821 | (defn toggle | |
822 | "Atomically sets the state(s) of one or more channels in a mix. The | |
823 | state map is a map of channels -> channel-state-map. A | |
824 | channel-state-map is a map of attrs -> boolean, where attr is one or | |
825 | more of :mute, :pause or :solo. Any states supplied are merged with | |
826 | the current state. | |
827 | ||
828 | Note that channels can be added to a mix via toggle, which can be | |
829 | used to add channels in a particular (e.g. paused) state." | |
830 | [mix state-map] | |
831 | (toggle* mix state-map)) | |
832 | ||
833 | (defn solo-mode | |
834 | "Sets the solo mode of the mix. mode must be one of :mute or :pause" | |
835 | [mix mode] | |
836 | (solo-mode* mix mode)) | |
837 | ||
838 | (defprotocol Pub | |
839 | (sub* [p v ch close?]) | |
840 | (unsub* [p v ch]) | |
841 | (unsub-all* [p] [p v])) | |
842 | ||
843 | (defn pub | |
844 | "Creates and returns a pub(lication) of the supplied channel, | |
845 | partitioned into topics by the topic-fn. topic-fn will be applied to | |
846 | each value on the channel and the result will determine the 'topic' | |
847 | on which that value will be put. Channels can be subscribed to | |
848 | receive copies of topics using 'sub', and unsubscribed using | |
849 | 'unsub'. Each topic will be handled by an internal mult on a | |
850 | dedicated channel. By default these internal channels are | |
851 | unbuffered, but a buf-fn can be supplied which, given a topic, | |
852 | creates a buffer with desired properties. | |
853 | ||
854 | Each item is distributed to all subs in parallel and synchronously, | |
855 | i.e. each sub must accept before the next item is distributed. Use | |
856 | buffering/windowing to prevent slow subs from holding up the pub. | |
857 | ||
858 | Items received when there are no matching subs get dropped. | |
859 | ||
860 | Note that if buf-fns are used then each topic is handled | |
861 | asynchronously, i.e. if a channel is subscribed to more than one | |
862 | topic it should not expect them to be interleaved identically with | |
863 | the source." | |
864 | ([ch topic-fn] (pub ch topic-fn (constantly nil))) | |
865 | ([ch topic-fn buf-fn] | |
866 | (let [mults (atom {}) ;;topic->mult | |
867 | ensure-mult (fn [topic] | |
868 | (or (get @mults topic) | |
869 | (get (swap! mults | |
870 | #(if (% topic) % (assoc % topic (mult (chan (buf-fn topic)))))) | |
871 | topic))) | |
872 | p (reify | |
873 | Mux | |
874 | (muxch* [_] ch) | |
875 | ||
876 | Pub | |
877 | (sub* [p topic ch close?] | |
878 | (let [m (ensure-mult topic)] | |
879 | (tap m ch close?))) | |
880 | (unsub* [p topic ch] | |
881 | (when-let [m (get @mults topic)] | |
882 | (untap m ch))) | |
883 | (unsub-all* [_] (reset! mults {})) | |
884 | (unsub-all* [_ topic] (swap! mults dissoc topic)))] | |
885 | (go-loop [] | |
886 | (let [val (<! ch)] | |
887 | (if (nil? val) | |
888 | (doseq [m (vals @mults)] | |
889 | (close! (muxch* m))) | |
890 | (let [topic (topic-fn val) | |
891 | m (get @mults topic)] | |
892 | (when m | |
893 | (when-not (>! (muxch* m) val) | |
894 | (swap! mults dissoc topic))) | |
895 | (recur))))) | |
896 | p))) | |
897 | ||
898 | (defn sub | |
899 | "Subscribes a channel to a topic of a pub. | |
900 | ||
901 | By default the channel will be closed when the source closes, | |
902 | but can be determined by the close? parameter." | |
903 | ([p topic ch] (sub p topic ch true)) | |
904 | ([p topic ch close?] (sub* p topic ch close?))) | |
905 | ||
906 | (defn unsub | |
907 | "Unsubscribes a channel from a topic of a pub" | |
908 | [p topic ch] | |
909 | (unsub* p topic ch)) | |
910 | ||
911 | (defn unsub-all | |
912 | "Unsubscribes all channels from a pub, or a topic of a pub" | |
913 | ([p] (unsub-all* p)) | |
914 | ([p topic] (unsub-all* p topic))) | |
915 | ||
916 | ;;; these are down here because they alias core fns, don't want accidents above | |
917 | ||
918 | (defn map | |
919 | "Takes a function and a collection of source channels, and returns a | |
920 | channel which contains the values produced by applying f to the set | |
921 | of first items taken from each source channel, followed by applying | |
922 | f to the set of second items from each channel, until any one of the | |
923 | channels is closed, at which point the output channel will be | |
924 | closed. The returned channel will be unbuffered by default, or a | |
925 | buf-or-n can be supplied" | |
926 | ([f chs] (map f chs nil)) | |
927 | ([f chs buf-or-n] | |
928 | (let [chs (vec chs) | |
929 | out (chan buf-or-n) | |
930 | cnt (count chs) | |
931 | rets (object-array cnt) | |
932 | dchan (chan 1) | |
933 | dctr (atom nil) | |
934 | done (mapv (fn [i] | |
935 | (fn [ret] | |
936 | (aset rets i ret) | |
937 | (when (zero? (swap! dctr dec)) | |
938 | (put! dchan (java.util.Arrays/copyOf rets cnt))))) | |
939 | (range cnt))] | |
940 | (go-loop [] | |
941 | (reset! dctr cnt) | |
942 | (dotimes [i cnt] | |
943 | (try | |
944 | (take! (chs i) (done i)) | |
945 | (catch Exception e | |
946 | (swap! dctr dec)))) | |
947 | (let [rets (<! dchan)] | |
948 | (if (some nil? rets) | |
949 | (close! out) | |
950 | (do (>! out (apply f rets)) | |
951 | (recur))))) | |
952 | out))) | |
953 | ||
954 | (defn merge | |
955 | "Takes a collection of source channels and returns a channel which | |
956 | contains all values taken from them. The returned channel will be | |
957 | unbuffered by default, or a buf-or-n can be supplied. The channel | |
958 | will close after all the source channels have closed." | |
959 | ([chs] (merge chs nil)) | |
960 | ([chs buf-or-n] | |
961 | (let [out (chan buf-or-n)] | |
962 | (go-loop [cs (vec chs)] | |
963 | (if (pos? (count cs)) | |
964 | (let [[v c] (alts! cs)] | |
965 | (if (nil? v) | |
966 | (recur (filterv #(not= c %) cs)) | |
967 | (do (>! out v) | |
968 | (recur cs)))) | |
969 | (close! out))) | |
970 | out))) | |
971 | ||
972 | (defn into | |
973 | "Returns a channel containing the single (collection) result of the | |
974 | items taken from the channel conjoined to the supplied | |
975 | collection. ch must close before into produces a result." | |
976 | [coll ch] | |
977 | (reduce conj coll ch)) | |
978 | ||
979 | ||
980 | (defn take | |
981 | "Returns a channel that will return, at most, n items from ch. After n items | |
982 | have been returned, or ch has been closed, the return channel will close. | |
983 | ||
984 | The output channel is unbuffered by default, unless buf-or-n is given." | |
985 | ([n ch] | |
986 | (take n ch nil)) | |
987 | ([n ch buf-or-n] | |
988 | (let [out (chan buf-or-n)] | |
989 | (go (loop [x 0] | |
990 | (when (< x n) | |
991 | (let [v (<! ch)] | |
992 | (when (not (nil? v)) | |
993 | (>! out v) | |
994 | (recur (inc x)))))) | |
995 | (close! out)) | |
996 | out))) | |
997 | ||
998 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; deprecated - do not use ;;;;;;;;;;;;;;;;;;;;;;;;; | |
999 | (defn map< | |
1000 | "Deprecated - this function will be removed. Use transducer instead" | |
1001 | {:deprecated "0.1.319.0-6b1aca-alpha"} | |
1002 | [f ch] | |
1003 | (reify | |
1004 | impl/Channel | |
1005 | (close! [_] (impl/close! ch)) | |
1006 | (closed? [_] (impl/closed? ch)) | |
1007 | ||
1008 | impl/ReadPort | |
1009 | (take! [_ fn1] | |
1010 | (let [ret | |
1011 | (impl/take! ch | |
1012 | (reify | |
1013 | Lock | |
1014 | (lock [_] (.lock ^Lock fn1)) | |
1015 | (unlock [_] (.unlock ^Lock fn1)) | |
1016 | ||
1017 | impl/Handler | |
1018 | (active? [_] (impl/active? fn1)) | |
1019 | (blockable? [_] true) | |
1020 | (lock-id [_] (impl/lock-id fn1)) | |
1021 | (commit [_] | |
1022 | (let [f1 (impl/commit fn1)] | |
1023 | #(f1 (if (nil? %) nil (f %)))))))] | |
1024 | (if (and ret (not (nil? @ret))) | |
1025 | (channels/box (f @ret)) | |
1026 | ret))) | |
1027 | ||
1028 | impl/WritePort | |
1029 | (put! [_ val fn1] (impl/put! ch val fn1)))) | |
1030 | ||
1031 | (defn map> | |
1032 | "Deprecated - this function will be removed. Use transducer instead" | |
1033 | {:deprecated "0.1.319.0-6b1aca-alpha"} | |
1034 | [f ch] | |
1035 | (reify | |
1036 | impl/Channel | |
1037 | (close! [_] (impl/close! ch)) | |
1038 | (closed? [_] (impl/closed? ch)) | |
1039 | ||
1040 | impl/ReadPort | |
1041 | (take! [_ fn1] (impl/take! ch fn1)) | |
1042 | ||
1043 | impl/WritePort | |
1044 | (put! [_ val fn1] | |
1045 | (impl/put! ch (f val) fn1)))) | |
1046 | ||
1047 | (defn filter> | |
1048 | "Deprecated - this function will be removed. Use transducer instead" | |
1049 | {:deprecated "0.1.319.0-6b1aca-alpha"} | |
1050 | [p ch] | |
1051 | (reify | |
1052 | impl/Channel | |
1053 | (close! [_] (impl/close! ch)) | |
1054 | (closed? [_] (impl/closed? ch)) | |
1055 | ||
1056 | impl/ReadPort | |
1057 | (take! [_ fn1] (impl/take! ch fn1)) | |
1058 | ||
1059 | impl/WritePort | |
1060 | (put! [_ val fn1] | |
1061 | (if (p val) | |
1062 | (impl/put! ch val fn1) | |
1063 | (channels/box (not (impl/closed? ch))))))) | |
1064 | ||
1065 | (defn remove> | |
1066 | "Deprecated - this function will be removed. Use transducer instead" | |
1067 | {:deprecated "0.1.319.0-6b1aca-alpha"} | |
1068 | [p ch] | |
1069 | (filter> (complement p) ch)) | |
1070 | ||
1071 | (defn filter< | |
1072 | "Deprecated - this function will be removed. Use transducer instead" | |
1073 | {:deprecated "0.1.319.0-6b1aca-alpha"} | |
1074 | ([p ch] (filter< p ch nil)) | |
1075 | ([p ch buf-or-n] | |
1076 | (let [out (chan buf-or-n)] | |
1077 | (go-loop [] | |
1078 | (let [val (<! ch)] | |
1079 | (if (nil? val) | |
1080 | (close! out) | |
1081 | (do (when (p val) | |
1082 | (>! out val)) | |
1083 | (recur))))) | |
1084 | out))) | |
1085 | ||
1086 | (defn remove< | |
1087 | "Deprecated - this function will be removed. Use transducer instead" | |
1088 | {:deprecated "0.1.319.0-6b1aca-alpha"} | |
1089 | ([p ch] (remove< p ch nil)) | |
1090 | ([p ch buf-or-n] (filter< (complement p) ch buf-or-n))) | |
1091 | ||
1092 | (defn- mapcat* [f in out] | |
1093 | (go-loop [] | |
1094 | (let [val (<! in)] | |
1095 | (if (nil? val) | |
1096 | (close! out) | |
1097 | (do (doseq [v (f val)] | |
1098 | (>! out v)) | |
1099 | (when-not (impl/closed? out) | |
1100 | (recur))))))) | |
1101 | ||
1102 | (defn mapcat< | |
1103 | "Deprecated - this function will be removed. Use transducer instead" | |
1104 | {:deprecated "0.1.319.0-6b1aca-alpha"} | |
1105 | ([f in] (mapcat< f in nil)) | |
1106 | ([f in buf-or-n] | |
1107 | (let [out (chan buf-or-n)] | |
1108 | (mapcat* f in out) | |
1109 | out))) | |
1110 | ||
1111 | (defn mapcat> | |
1112 | "Deprecated - this function will be removed. Use transducer instead" | |
1113 | {:deprecated "0.1.319.0-6b1aca-alpha"} | |
1114 | ([f out] (mapcat> f out nil)) | |
1115 | ([f out buf-or-n] | |
1116 | (let [in (chan buf-or-n)] | |
1117 | (mapcat* f in out) | |
1118 | in))) | |
1119 | ||
1120 | (defn unique | |
1121 | "Deprecated - this function will be removed. Use transducer instead" | |
1122 | {:deprecated "0.1.319.0-6b1aca-alpha"} | |
1123 | ([ch] | |
1124 | (unique ch nil)) | |
1125 | ([ch buf-or-n] | |
1126 | (let [out (chan buf-or-n)] | |
1127 | (go (loop [last nil] | |
1128 | (let [v (<! ch)] | |
1129 | (when (not (nil? v)) | |
1130 | (if (= v last) | |
1131 | (recur last) | |
1132 | (do (>! out v) | |
1133 | (recur v)))))) | |
1134 | (close! out)) | |
1135 | out))) | |
1136 | ||
1137 | ||
1138 | (defn partition | |
1139 | "Deprecated - this function will be removed. Use transducer instead" | |
1140 | {:deprecated "0.1.319.0-6b1aca-alpha"} | |
1141 | ([n ch] | |
1142 | (partition n ch nil)) | |
1143 | ([n ch buf-or-n] | |
1144 | (let [out (chan buf-or-n)] | |
1145 | (go (loop [arr (make-array Object n) | |
1146 | idx 0] | |
1147 | (let [v (<! ch)] | |
1148 | (if (not (nil? v)) | |
1149 | (do (aset ^objects arr idx v) | |
1150 | (let [new-idx (inc idx)] | |
1151 | (if (< new-idx n) | |
1152 | (recur arr new-idx) | |
1153 | (do (>! out (vec arr)) | |
1154 | (recur (make-array Object n) 0))))) | |
1155 | (do (when (> idx 0) | |
1156 | (let [narray (make-array Object idx)] | |
1157 | (System/arraycopy arr 0 narray 0 idx) | |
1158 | (>! out (vec narray)))) | |
1159 | (close! out)))))) | |
1160 | out))) | |
1161 | ||
1162 | ||
1163 | (defn partition-by | |
1164 | "Deprecated - this function will be removed. Use transducer instead" | |
1165 | {:deprecated "0.1.319.0-6b1aca-alpha"} | |
1166 | ([f ch] | |
1167 | (partition-by f ch nil)) | |
1168 | ([f ch buf-or-n] | |
1169 | (let [out (chan buf-or-n)] | |
1170 | (go (loop [lst (ArrayList.) | |
1171 | last ::nothing] | |
1172 | (let [v (<! ch)] | |
1173 | (if (not (nil? v)) | |
1174 | (let [new-itm (f v)] | |
1175 | (if (or (= new-itm last) | |
1176 | (identical? last ::nothing)) | |
1177 | (do (.add ^ArrayList lst v) | |
1178 | (recur lst new-itm)) | |
1179 | (do (>! out (vec lst)) | |
1180 | (let [new-lst (ArrayList.)] | |
1181 | (.add ^ArrayList new-lst v) | |
1182 | (recur new-lst new-itm))))) | |
1183 | (do (when (> (.size ^ArrayList lst) 0) | |
1184 | (>! out (vec lst))) | |
1185 | (close! out)))))) | |
1186 | out))) |
0 | /* | |
1 | Copyright (c) Rich Hickey and contributors. All rights reserved. | |
2 | The use and distribution terms for this software are covered by the | |
3 | Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
4 | which can be found in the file epl-v10.html at the root of this distribution. | |
5 | By using this software in any fashion, you are agreeing to be bound by | |
6 | the terms of this license. | |
7 | You must not remove this notice, or any other, from this software. | |
8 | */ | |
9 | ||
10 | package clojure.core.async; | |
11 | ||
12 | import java.util.concurrent.locks.AbstractQueuedSynchronizer; | |
13 | ||
14 | // non-recursive, non-reentrant mutex implementation based on example | |
15 | // from Doug Lea's "The java.util.concurrent Synchronizer Framework" | |
16 | // http://gee.cs.oswego.edu/dl/papers/aqs.pdf | |
17 | public class Mutex { | |
18 | private static class Sync extends AbstractQueuedSynchronizer { | |
19 | public boolean tryAcquire(int ignored) { | |
20 | return compareAndSetState(0, 1); | |
21 | } | |
22 | ||
23 | public boolean tryRelease(int ignored) { | |
24 | setState(0); | |
25 | return true; | |
26 | } | |
27 | } | |
28 | ||
29 | private final Sync sync = new Sync(); | |
30 | ||
31 | public Mutex() {} | |
32 | ||
33 | public void lock() { | |
34 | sync.acquire(1); | |
35 | } | |
36 | ||
37 | public void unlock() { | |
38 | sync.release(1); | |
39 | } | |
40 | } |
0 | /* | |
1 | Copyright (c) Rich Hickey and contributors. All rights reserved. | |
2 | The use and distribution terms for this software are covered by the | |
3 | Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
4 | which can be found in the file epl-v10.html at the root of this distribution. | |
5 | By using this software in any fashion, you are agreeing to be bound by | |
6 | the terms of this license. | |
7 | You must not remove this notice, or any other, from this software. | |
8 | */ | |
9 | ||
10 | package clojure.core.async; | |
11 | ||
12 | import java.util.Random; | |
13 | ||
14 | public class ThreadLocalRandom extends Random { | |
15 | ||
16 | private static final long serialVersionUID = -2599376724352996934L; | |
17 | ||
18 | private static ThreadLocal<ThreadLocalRandom> currentThreadLocalRandom = new ThreadLocal<ThreadLocalRandom>() { | |
19 | protected ThreadLocalRandom initialValue() { | |
20 | return new ThreadLocalRandom(); | |
21 | } | |
22 | }; | |
23 | ||
24 | ||
25 | /** | |
26 | * Returns the current ThreadLocalRandom for this thread. Clients must call current, | |
27 | * rather than constructing instances themselves. The ThreadLocalRandom instance will | |
28 | * be returned from a ThreadLocal variable. | |
29 | * | |
30 | * @return A ThreadLocalRandom for the current thread | |
31 | * | |
32 | * @see ThreadLocal | |
33 | * @see Random | |
34 | */ | |
35 | public static ThreadLocalRandom current() { | |
36 | return currentThreadLocalRandom.get(); | |
37 | } | |
38 | ||
39 | private ThreadLocalRandom() { | |
40 | super(); | |
41 | } | |
42 | ||
43 | private ThreadLocalRandom(long seed) { | |
44 | super(seed); | |
45 | } | |
46 | ||
47 | } |
0 | (ns cljs.core.async.buffer-tests | |
1 | (:require-macros [cljs.core.async.macros :as m :refer [go]]) | |
2 | (:require [cljs.core.async | |
3 | :refer [unblocking-buffer? buffer dropping-buffer sliding-buffer | |
4 | put! take! chan close!]] | |
5 | [cljs.core.async.impl.dispatch :as dispatch] | |
6 | [cljs.core.async.impl.buffers :as buff :refer [promise-buffer]] | |
7 | [cljs.core.async.impl.protocols | |
8 | :refer [full? add! remove! close-buf!]] | |
9 | [cljs.core.async.test-helpers :refer-macros [throws?]] | |
10 | [cljs.test :refer-macros [deftest testing is]])) | |
11 | ||
12 | (deftest unblocking-buffer-tests | |
13 | (testing "buffers" | |
14 | (is (not (unblocking-buffer? (buffer 1)))) | |
15 | (is (unblocking-buffer? (dropping-buffer 1))) | |
16 | (is (unblocking-buffer? (sliding-buffer 1))))) | |
17 | ||
18 | (deftest buffer-tests | |
19 | (testing "fixed-buffer" | |
20 | (let [fb (buffer 2)] | |
21 | (is (= 0 (count fb))) | |
22 | ||
23 | (add! fb :1) | |
24 | (is (= 1 (count fb))) | |
25 | ||
26 | (add! fb :2) | |
27 | (is (= 2 (count fb))) | |
28 | ||
29 | (is (full? fb)) | |
30 | #_(assert (throws? (add! fb :3))) | |
31 | ||
32 | (is (= :1 (remove! fb))) | |
33 | (is (not (full? fb))) | |
34 | ||
35 | (is (= 1 (count fb))) | |
36 | (is (= :2 (remove! fb))) | |
37 | ||
38 | (is (= 0 (count fb))) | |
39 | #_(is (helpers/throws? (remove! fb))))) | |
40 | ||
41 | (testing "dropping-buffer" | |
42 | (let [fb (dropping-buffer 2)] | |
43 | (is (= 0 (count fb))) | |
44 | ||
45 | (add! fb :1) | |
46 | (is (= 1 (count fb))) | |
47 | ||
48 | (add! fb :2) | |
49 | (is (= 2 (count fb))) | |
50 | ||
51 | (is (not (full? fb))) | |
52 | (add! fb :3) | |
53 | ||
54 | (is (= 2 (count fb))) | |
55 | ||
56 | (is (= :1 (remove! fb))) | |
57 | (is (not (full? fb))) | |
58 | ||
59 | (is (= 1 (count fb))) | |
60 | (is (= :2 (remove! fb))) | |
61 | ||
62 | (is (= 0 (count fb))) | |
63 | #_(is (throws? (remove! fb))))) | |
64 | ||
65 | (testing "sliding-buffer" | |
66 | (let [fb (sliding-buffer 2)] | |
67 | (is (= 0 (count fb))) | |
68 | ||
69 | (add! fb :1) | |
70 | (is (= 1 (count fb))) | |
71 | ||
72 | (add! fb :2) | |
73 | (is (= 2 (count fb))) | |
74 | ||
75 | (is (not (full? fb))) | |
76 | (add! fb :3) | |
77 | ||
78 | (is (= 2 (count fb))) | |
79 | ||
80 | (is (= :2 (remove! fb))) | |
81 | (is (not (full? fb))) | |
82 | ||
83 | (is (= 1 (count fb))) | |
84 | (is (= :3 (remove! fb))) | |
85 | ||
86 | (is (= 0 (count fb))) | |
87 | #_(is (throws? (remove! fb)))))) | |
88 | ||
89 | (deftest promise-buffer-tests | |
90 | (let [pb (promise-buffer)] | |
91 | (is (= 0 (count pb))) | |
92 | ||
93 | (add! pb :1) | |
94 | (is (= 1 (count pb))) | |
95 | ||
96 | (add! pb :2) | |
97 | (is (= 1 (count pb))) | |
98 | ||
99 | (is (not (full? pb))) | |
100 | (is (not (throws? (add! pb :3)))) | |
101 | (is (= 1 (count pb))) | |
102 | ||
103 | (is (= :1 (remove! pb))) | |
104 | (is (not (full? pb))) | |
105 | ||
106 | (is (= 1 (count pb))) | |
107 | (is (= :1 (remove! pb))) | |
108 | ||
109 | (is (= nil (close-buf! pb))) | |
110 | (is (= :1 (remove! pb))))) |
0 | (ns cljs.core.async.pipeline-test | |
1 | (:require-macros [cljs.core.async.macros :as m :refer [go go-loop]]) | |
2 | (:require [cljs.core.async.test-helpers :refer [latch inc!]] | |
3 | [cljs.core.async :as a | |
4 | :refer [<! >! chan close! to-chan pipeline-async pipeline put!]] | |
5 | [cljs.test :refer-macros [deftest is testing async]])) | |
6 | ||
7 | (defn pipeline-tester [pipeline-fn n inputs xf] | |
8 | (let [cin (to-chan inputs) | |
9 | cout (chan 1)] | |
10 | (pipeline-fn n cout xf cin) | |
11 | (go-loop [acc []] | |
12 | (let [val (<! cout)] | |
13 | (if (not (nil? val)) | |
14 | (recur (conj acc val)) | |
15 | acc))))) | |
16 | ||
17 | (defn identity-async [v ch] | |
18 | (go (>! ch v) (close! ch))) | |
19 | ||
20 | (defn test-size-async [n size] | |
21 | (let [r (range size)] | |
22 | (go (is (= r (<! (pipeline-tester pipeline-async n r identity-async))))))) | |
23 | ||
24 | (defn test-size-compute [n size] | |
25 | (let [r (range size)] | |
26 | (go (is (= r (<! (pipeline-tester pipeline n r (map identity)))))))) | |
27 | ||
28 | (deftest pipeline-test-sizes | |
29 | (async done | |
30 | (let [l (latch 2 done)] | |
31 | (testing "pipeline async test sizes" | |
32 | (go | |
33 | (<! (test-size-async 1 0)) | |
34 | (<! (test-size-async 1 10)) | |
35 | (<! (test-size-async 10 10)) | |
36 | (<! (test-size-async 20 10)) | |
37 | (<! (test-size-async 5 1000)) | |
38 | (inc! l))) | |
39 | (testing "pipeline compute test sizes" | |
40 | (go | |
41 | (<! (test-size-compute 1 0)) | |
42 | (<! (test-size-compute 1 10)) | |
43 | (<! (test-size-compute 10 10)) | |
44 | (<! (test-size-compute 20 10)) | |
45 | (<! (test-size-compute 5 1000)) | |
46 | (inc! l)))))) | |
47 | ||
48 | (deftest test-close? | |
49 | (async done | |
50 | (go | |
51 | (let [cout (chan 1)] | |
52 | (pipeline 5 cout (map identity) (to-chan [1]) true) | |
53 | (is (= 1 (<! cout))) | |
54 | (is (= nil (<! cout)))) | |
55 | (let [cout (chan 1)] | |
56 | (pipeline 5 cout (map identity) (to-chan [1]) false) | |
57 | (is (= 1 (<! cout))) | |
58 | (>! cout :more) | |
59 | (is (= :more (<! cout)))) | |
60 | (let [cout (chan 1)] | |
61 | (pipeline 5 cout (map identity) (to-chan [1]) nil) | |
62 | (is (= 1 (<! cout))) | |
63 | (>! cout :more) | |
64 | (is (= :more (<! cout)))) | |
65 | (done)))) | |
66 | ||
67 | (deftest test-ex-handler | |
68 | (async done | |
69 | (go | |
70 | (let [cout (chan 1) | |
71 | chex (chan 1) | |
72 | ex-mapping (map (fn [x] (if (= x 3) (throw (ex-info "err" {:data x})) x))) | |
73 | ex-handler (fn [e] (do (put! chex e) :err))] | |
74 | (pipeline 5 cout ex-mapping (to-chan [1 2 3 4]) true ex-handler) | |
75 | (is (= 1 (<! cout))) | |
76 | (is (= 2 (<! cout))) | |
77 | (is (= :err (<! cout))) | |
78 | (is (= 4 (<! cout))) | |
79 | (is (= {:data 3} (ex-data (<! chex))))) | |
80 | (done)))) | |
81 | ||
82 | (defn multiplier-async [v ch] | |
83 | (go | |
84 | (dotimes [i v] | |
85 | (>! ch i)) | |
86 | (close! ch))) | |
87 | ||
88 | (deftest async-pipelines-af-multiplier | |
89 | (async done | |
90 | (go | |
91 | (is (= [0 0 1 0 1 2 0 1 2 3] | |
92 | (<! (pipeline-tester pipeline-async 2 (range 1 5) multiplier-async)))) | |
93 | (done)))) | |
94 | ||
95 | (defn incrementer-async [v ch] | |
96 | (go | |
97 | (>! ch (inc v)) | |
98 | (close! ch))) | |
99 | ||
100 | (deftest pipelines-async | |
101 | (async done | |
102 | (go | |
103 | (is (= (range 1 101) | |
104 | (<! (pipeline-tester pipeline-async 1 (range 100) incrementer-async)))) | |
105 | (done)))) | |
106 | ||
107 | (defn slow-fib [n] | |
108 | (if (< n 2) n (+ (slow-fib (- n 1)) (slow-fib (- n 2))))) | |
109 | ||
110 | (deftest pipelines-compute | |
111 | (async done | |
112 | (let [input (take 50 (cycle (range 15 38)))] | |
113 | (go | |
114 | (is (= (slow-fib (last input)) | |
115 | (last (<! (pipeline-tester pipeline 8 input (map slow-fib)))))) | |
116 | (done))))) |
0 | (ns cljs.core.async.runner-tests | |
1 | (:require [cljs.core.async :refer [buffer dropping-buffer sliding-buffer put! take! chan close!]] | |
2 | [cljs.core.async.impl.dispatch :as dispatch] | |
3 | [cljs.core.async.impl.buffers :as buff] | |
4 | [cljs.core.async.impl.protocols :refer [full? add! remove!]] | |
5 | [cljs.core.async.impl.ioc-helpers :as ioch]) | |
6 | (:require-macros [cljs.core.async.test-helpers :as h :refer [is= is deftest testing runner locals-test]] | |
7 | [cljs.core.async.macros :as m :refer [go]] | |
8 | [cljs.core.async.impl.ioc-macros :as ioc])) | |
9 | ||
10 | (defn pause [state blk val] | |
11 | (ioc/aset-all! state ioch/STATE-IDX blk ioch/VALUE-IDX val) | |
12 | :recur) | |
13 | ||
14 | (deftest runner-tests | |
15 | (testing "macros add locals to the env" | |
16 | (is= :pass | |
17 | (runner (let [x 42] | |
18 | (pause (locals-test)))))) | |
19 | (testing "do blocks" | |
20 | (is= 42 | |
21 | (runner (do (pause 42)))) | |
22 | (is= 42 | |
23 | (runner (do (pause 44) | |
24 | (pause 42))))) | |
25 | (testing "if expressions" | |
26 | (is= true | |
27 | (runner (if (pause true) | |
28 | (pause true) | |
29 | (pause false)))) | |
30 | (is= false | |
31 | (runner (if (pause false) | |
32 | (pause true) | |
33 | (pause false)))) | |
34 | (is= true | |
35 | (runner (when (pause true) | |
36 | (pause true)))) | |
37 | (is= nil | |
38 | (runner (when (pause false) | |
39 | (pause true))))) | |
40 | ||
41 | (testing "loop expressions" | |
42 | (is= 100 | |
43 | (runner (loop [x 0] | |
44 | (if (< x 100) | |
45 | (recur (inc (pause x))) | |
46 | (pause x))))) | |
47 | (is= [:b :a] | |
48 | (runner (loop [a :a b :b n 1] | |
49 | (if (pos? n) | |
50 | (recur b a (dec n)) ;; swap bindings | |
51 | [a b])))) | |
52 | (is= 1 | |
53 | (runner (loop [x 0 | |
54 | y (inc x)] | |
55 | y)))) | |
56 | ||
57 | (testing "let expressions" | |
58 | (is= 3 | |
59 | (runner (let [x 1 y 2] | |
60 | (+ x y))))) | |
61 | ||
62 | (testing "vector destructuring" | |
63 | (is= 3 | |
64 | (runner (let [[x y] [1 2]] | |
65 | (+ x y))))) | |
66 | ||
67 | (testing "hash-map destructuring" | |
68 | (is= 3 | |
69 | (runner (let [{:keys [x y] x2 :x y2 :y :as foo} {:x 1 :y 2}] | |
70 | (assert (and foo (pause x) y x2 y2 foo)) | |
71 | (+ x y))))) | |
72 | ||
73 | (testing "hash-map literals" | |
74 | (is= {:1 1 :2 2 :3 3} | |
75 | (runner {:1 (pause 1) | |
76 | :2 (pause 2) | |
77 | :3 (pause 3)}))) | |
78 | (testing "hash-set literals" | |
79 | (is= #{1 2 3} | |
80 | (runner #{(pause 1) | |
81 | (pause 2) | |
82 | (pause 3)}))) | |
83 | (testing "vector literals" | |
84 | (is= [1 2 3] | |
85 | (runner [(pause 1) | |
86 | (pause 2) | |
87 | (pause 3)]))) | |
88 | (testing "dotimes" | |
89 | (is= 42 (runner | |
90 | (dotimes [x 10] | |
91 | (pause x)) | |
92 | 42))) | |
93 | ||
94 | (testing "set! with field" | |
95 | (let [x (js-obj)] | |
96 | (runner (set! (.-foo x) "bar") | |
97 | (is= (.-foo x) "bar")) | |
98 | (is= (.-foo x) "bar"))) | |
99 | ||
100 | (testing "set! with var" | |
101 | (def test-target 0) | |
102 | (runner (set! test-target 42)) | |
103 | (is= test-target 42)) | |
104 | ||
105 | (testing "keywords as functions" | |
106 | (is (= :bar | |
107 | (runner (:foo (pause {:foo :bar})))))) | |
108 | ||
109 | (testing "vectors as functions" | |
110 | (is (= 2 | |
111 | (runner ([1 2] 1))))) | |
112 | ||
113 | (testing "dot forms" | |
114 | (is (= 8 (runner (. js/Math (pow 2 3))))) | |
115 | (is (= 8 (runner (. js/Math pow 2 3))))) | |
116 | ||
117 | (testing "quote" | |
118 | (is= '(1 2 3) | |
119 | (runner (pause '(1 2 3))))) | |
120 | ||
121 | (testing "fn closures" | |
122 | (is= 42 | |
123 | (runner | |
124 | (let [x 42 | |
125 | _ (pause x) | |
126 | f (fn [] x)] | |
127 | (f))))) | |
128 | ||
129 | (testing "case" | |
130 | (is= 43 | |
131 | (runner | |
132 | (let [value :bar] | |
133 | (case value | |
134 | :foo (pause 42) | |
135 | :bar (pause 43) | |
136 | :baz (pause 44))))) | |
137 | (is= :default | |
138 | (runner | |
139 | (case :baz | |
140 | :foo 44 | |
141 | :default))) | |
142 | (is= nil | |
143 | (runner | |
144 | (case true | |
145 | false false | |
146 | nil))) | |
147 | (is= 42 | |
148 | (runner | |
149 | (loop [x 0] | |
150 | (case (int x) | |
151 | 0 (recur (inc x)) | |
152 | 1 42))))) | |
153 | ||
154 | (testing "try" | |
155 | (is= 42 | |
156 | (runner | |
157 | (try 42 | |
158 | (catch js/Error ex ex)))) | |
159 | (is= 42 | |
160 | (runner | |
161 | (try | |
162 | (assert false) | |
163 | (catch js/Error ex 42)))) | |
164 | ||
165 | (is= 42 | |
166 | (runner | |
167 | (try | |
168 | (assert false) | |
169 | (catch :default ex 42)))) | |
170 | ||
171 | (let [a (atom false) | |
172 | v (runner | |
173 | (try | |
174 | true | |
175 | (catch js/Error ex false) | |
176 | (finally (pause (reset! a true)))))] | |
177 | (is (and @a v))) | |
178 | ||
179 | (let [a (atom false) | |
180 | v (runner | |
181 | (try | |
182 | (assert false) | |
183 | (catch js/Error ex true) | |
184 | (finally (reset! a true))))] | |
185 | (is (and @a v))) | |
186 | ||
187 | ||
188 | (let [a (atom false) | |
189 | v (try (runner | |
190 | (try | |
191 | (assert false) | |
192 | (finally (reset! a true)))) | |
193 | (catch js/Error ex ex))] | |
194 | (is (and @a v))) | |
195 | ||
196 | ||
197 | (let [a (atom 0) | |
198 | v (runner | |
199 | (try | |
200 | (try | |
201 | 42 | |
202 | (finally (swap! a inc))) | |
203 | (finally (swap! a inc))))] | |
204 | (is (= @a 2))) | |
205 | ||
206 | (let [a (atom 0) | |
207 | v (try (runner | |
208 | (try | |
209 | (try | |
210 | (assert false) | |
211 | (finally (swap! a inc))) | |
212 | (finally (swap! a inc)))) | |
213 | (catch js/Error ex ex))] | |
214 | (is (= @a 2))) | |
215 | ||
216 | (let [a (atom 0) | |
217 | v (try (runner | |
218 | (try | |
219 | (try | |
220 | (assert false) | |
221 | (catch js/Error ex (throw ex)) | |
222 | (finally (swap! a inc))) | |
223 | (catch js/Error ex (throw ex)) | |
224 | (finally (swap! a inc)))) | |
225 | (catch js/Error ex ex))] | |
226 | (is (= @a 2))) | |
227 | ||
228 | (let [a (atom 0) | |
229 | v (try (runner | |
230 | (try | |
231 | (try | |
232 | (assert false) | |
233 | (catch js/Error ex (pause (throw ex))) | |
234 | (finally (pause (swap! a inc)))) | |
235 | (catch js/Error ex (pause (throw ex))) | |
236 | (finally (pause (swap! a inc))))) | |
237 | (catch js/Error ex ex))] | |
238 | (is (= @a 2))))) |
0 | (ns cljs.core.async.test-helpers | |
1 | (:require [cljs.core.async.impl.ioc-macros :as ioc])) | |
2 | ||
3 | (defmacro runner | |
4 | "Creates a runner block. The code inside the body of this macro will be translated | |
5 | into a state machine. At run time the body will be run as normal. This transform is | |
6 | only really useful for testing." | |
7 | [& body] | |
8 | (let [terminators {'pause 'cljs.core.async.runner-tests/pause}] | |
9 | `(let [state# (~(ioc/state-machine body 0 &env terminators))] | |
10 | (cljs.core.async.impl.ioc-helpers/run-state-machine state#) | |
11 | (assert (cljs.core.async.impl.ioc-helpers/finished? state#) "state did not return finished") | |
12 | (aget state# ~ioc/VALUE-IDX)))) | |
13 | ||
14 | (defmacro assert-go-block-completes | |
15 | [nm & body] | |
16 | `(let [body-chan# (do ~@body) | |
17 | timeout# (fn [] (let [c# (cljs.core.async/chan)] | |
18 | (cljs.core.async.macros/go | |
19 | (cljs.core.async/<! (cljs.core.async/timeout 10000)) | |
20 | (cljs.core.async/>! c# ::timeout) | |
21 | (cljs.core.async/close! c#)) | |
22 | c#))] | |
23 | (when (satisfies? cljs.core.async.impl.protocols.Channel body-chan#) | |
24 | (cljs.core.async.macros/go | |
25 | (let [[v# _] (cljs.core.async/alts! [body-chan# (timeout#)] :priority true)] | |
26 | (assert (not= ::timeout v#) | |
27 | (str "test timed out: " ~nm )))) | |
28 | true))) | |
29 | ||
30 | (defmacro deftest | |
31 | [nm & body] | |
32 | `(do (.log js/console (str "Testing: " ~(str nm) "...")) | |
33 | (assert-go-block-completes ~(str nm) ~@body))) | |
34 | ||
35 | (defmacro throws? | |
36 | [& exprs] | |
37 | `(try ~@exprs false | |
38 | (catch ~'js/Object e# true))) | |
39 | ||
40 | (defmacro testing | |
41 | [nm & body] | |
42 | `(do (.log js/console (str " " ~nm "...")) | |
43 | (assert-go-block-completes ~(str nm) ~@body))) | |
44 | ||
45 | (defmacro is= | |
46 | [a b] | |
47 | `(let [a# ~a | |
48 | b# ~b] | |
49 | (assert (= a# b#) (str a# " != " b#)))) | |
50 | ||
51 | (defmacro is | |
52 | [a] | |
53 | `(assert ~a)) | |
54 | ||
55 | (defmacro locals-test [] | |
56 | (if (get-in &env [:locals] 'x) | |
57 | :pass | |
58 | :fail)) |
0 | (ns cljs.core.async.test-helpers) | |
1 | ||
2 | (defn latch [m f] | |
3 | (let [r (atom 0)] | |
4 | (add-watch r :latch | |
5 | (fn [_ _ o n] | |
6 | (when (== n m) (f)))) | |
7 | r)) | |
8 | ||
9 | (defn inc! [r] | |
10 | (swap! r inc)) |
0 | (ns cljs.core.async.test-runner | |
1 | (:require [cljs.test :refer-macros [run-tests]] | |
2 | [cljs.core.async.buffer-tests] | |
3 | [cljs.core.async.pipeline-test] | |
4 | [cljs.core.async.tests])) | |
5 | ||
6 | (run-tests | |
7 | 'cljs.core.async.pipeline-test | |
8 | 'cljs.core.async.buffer-tests | |
9 | 'cljs.core.async.tests) |
0 | (ns cljs.core.async.tests | |
1 | (:require-macros | |
2 | [cljs.core.async.macros :as m :refer [go alt!]]) | |
3 | (:require | |
4 | [cljs.core.async :refer | |
5 | [buffer dropping-buffer sliding-buffer put! take! chan promise-chan | |
6 | close! take partition-by offer! poll! <! >! alts!] :as async] | |
7 | [cljs.core.async.impl.dispatch :as dispatch] | |
8 | [cljs.core.async.impl.buffers :as buff] | |
9 | [cljs.core.async.impl.timers :as timers :refer [timeout]] | |
10 | [cljs.core.async.impl.protocols :refer [full? add! remove!]] | |
11 | [cljs.core.async.test-helpers :refer [latch inc!]] | |
12 | [cljs.test :as test :refer-macros [deftest is run-tests async testing]])) | |
13 | ||
14 | (enable-console-print!) | |
15 | ||
16 | (deftest test-put-take-chan-1 | |
17 | (async done | |
18 | (let [c (chan 1) | |
19 | l (latch 2 done)] | |
20 | (put! c 42 #(do (is true) (inc! l))) | |
21 | (take! c #(do (is (= 42 %))) (inc! l))))) | |
22 | ||
23 | (deftest test-put-take-chan | |
24 | (async done | |
25 | (let [c (chan) | |
26 | l (latch 2 done)] | |
27 | (put! c 42 #(do (is true) (inc! l))) | |
28 | (take! c #(do (is (= 42 %))) (inc! l))))) | |
29 | ||
30 | (defn identity-chan | |
31 | [x] | |
32 | (let [c (chan 1)] | |
33 | (go (>! c x) | |
34 | (close! c)) | |
35 | c)) | |
36 | ||
37 | (defn debug [x] | |
38 | (.log js/console x) | |
39 | x) | |
40 | ||
41 | (deftest test-identity-chan | |
42 | (async done | |
43 | (go | |
44 | (is (= (<! (identity-chan 42)) 42)) | |
45 | (done)))) | |
46 | ||
47 | (deftest test-identity-chan-alts! | |
48 | (async done | |
49 | (let [c (identity-chan 42)] | |
50 | (go | |
51 | (is (= [42 c] (alts! [c]))) | |
52 | (done))))) | |
53 | ||
54 | (deftest alt-tests | |
55 | (async done | |
56 | (testing "alts! works at all" | |
57 | (let [c (identity-chan 42)] | |
58 | (go | |
59 | (is (= [42 c] (alts! [c]))) | |
60 | (done)))))) | |
61 | ||
62 | (deftest test-alt!-and-alts! | |
63 | (async done | |
64 | (let [l (latch 2 done)] | |
65 | (testing "alt! works" | |
66 | (go | |
67 | (is (= [42 :foo] (alt! (identity-chan 42) ([v] [v :foo])))) | |
68 | (inc! l))) | |
69 | (testing "alts! can use default" | |
70 | (go | |
71 | (is | |
72 | (= [42 :default] | |
73 | (alts! [(chan 1)] :default 42))) | |
74 | (inc! l)))))) | |
75 | ||
76 | #_(deftest timeout-tests | |
77 | (async done | |
78 | (let [l (latch 2 done)] | |
79 | (testing "timeout will return same channel if within delay" | |
80 | (is (= (timeout 10) (timeout 10))) | |
81 | (is (= 1 (count (seq timers/timeouts-map))))) | |
82 | (testing "timeout map is empty after timeout expires" | |
83 | (go | |
84 | (<! (timeout 300)) | |
85 | (is (= 0 (count (seq timers/timeouts-map)))) | |
86 | (inc! l))) | |
87 | (testing "timeout map is empty after timeout expires with namespaced take" | |
88 | (go | |
89 | (async/<! (timeout 300)) | |
90 | (is (= 0 (count (seq timers/timeouts-map)))) | |
91 | (inc! l)))))) | |
92 | ||
93 | (deftest queue-limits | |
94 | (testing "async put!s are limited" | |
95 | (let [c (chan)] | |
96 | (dotimes [x 1024] | |
97 | (put! c x)) | |
98 | (is (thrown? js/Error (put! c 42))) | |
99 | (take! c (fn [x] (is (= x 0)))))) | |
100 | (testing "async take!s are limited" | |
101 | (let [c (chan)] | |
102 | (dotimes [x 1024] | |
103 | (take! c (fn [x]))) | |
104 | (is (thrown? js/Error (take! c (fn [x])))) | |
105 | (put! c 42)))) | |
106 | ||
107 | (deftest close-on-exception-tests | |
108 | (async done | |
109 | (let [l (latch 2 done)] | |
110 | (testing "go blocks" | |
111 | (go | |
112 | (alt! (go (assert false "This exception is expected")) | |
113 | ([v] (is (nil? v)) (inc! l)) | |
114 | ;; if this fails, channel did not close | |
115 | (timeout 500) ([v] (is false) (inc! l))) | |
116 | (alt! (go (alts! [(identity-chan 42)]) | |
117 | (assert false "This exception is expected")) | |
118 | ([v] (is (nil? v)) (inc! l)) | |
119 | ;; if this fails, channel did not close | |
120 | (timeout 500) ([v] (is false) (inc! l)))))))) | |
121 | ||
122 | (deftest cleanup | |
123 | (async done | |
124 | (let [l (latch 2 done)] | |
125 | (testing "alt handlers are removed from put!" | |
126 | (go | |
127 | (let [c (chan)] | |
128 | (dotimes [x 1024] | |
129 | (alts! [[c x]] :default 42)) | |
130 | (put! c 42)) | |
131 | (inc! l))) | |
132 | (testing "alt handlers are removed from take!" | |
133 | (go | |
134 | (let [c (chan)] | |
135 | (dotimes [x 1024] | |
136 | (alts! [c] :default 42)) | |
137 | (take! c (fn [x] nil))) | |
138 | (inc! l)))))) | |
139 | ||
140 | (deftest test-map< | |
141 | (async done | |
142 | (go | |
143 | (is (= [2 3 4 5] | |
144 | (<! (async/into [] (async/map< inc (async/to-chan [1 2 3 4])))))) | |
145 | (done)))) | |
146 | ||
147 | (deftest test-map> | |
148 | (async done | |
149 | (go | |
150 | (is (= [2 3 4 5] | |
151 | (let [out (chan) | |
152 | in (async/map> inc out)] | |
153 | (async/onto-chan in [1 2 3 4]) | |
154 | (<! (async/into [] out))))) | |
155 | (done)))) | |
156 | ||
157 | (deftest test-filter< | |
158 | (async done | |
159 | (go | |
160 | (is (= [2 4 6] | |
161 | (<! (async/into [] (async/filter< even? (async/to-chan [1 2 3 4 5 6])))))) | |
162 | (done)))) | |
163 | ||
164 | (deftest test-remoev< | |
165 | (async done | |
166 | (go | |
167 | (is (= [1 3 5] | |
168 | (<! (async/into [] (async/remove< even? (async/to-chan [1 2 3 4 5 6])))))) | |
169 | (done)))) | |
170 | ||
171 | (deftest test-filter> | |
172 | (async done | |
173 | (go | |
174 | (is (= [2 4 6] | |
175 | (let [out (chan) | |
176 | in (async/filter> even? out)] | |
177 | (async/onto-chan in [1 2 3 4 5 6]) | |
178 | (<! (async/into [] out))))) | |
179 | (done)))) | |
180 | ||
181 | (deftest test-remove> | |
182 | (async done | |
183 | (go | |
184 | (is (= [1 3 5] | |
185 | (let [out (chan) | |
186 | in (async/remove> even? out)] | |
187 | (async/onto-chan in [1 2 3 4 5 6]) | |
188 | (<! (async/into [] out))))) | |
189 | (done)))) | |
190 | ||
191 | (deftest test-mapcat< | |
192 | (async done | |
193 | (go | |
194 | (is (= [0 0 1 0 1 2] | |
195 | (<! (async/into [] (async/mapcat< range (async/to-chan [1 2 3])))))) | |
196 | (done)))) | |
197 | ||
198 | (deftest test-mapcat> | |
199 | (async done | |
200 | (go | |
201 | (is (= [0 0 1 0 1 2] | |
202 | (let [out (chan) | |
203 | in (async/mapcat> range out)] | |
204 | (async/onto-chan in [1 2 3]) | |
205 | (<! (async/into [] out))))) | |
206 | (done)))) | |
207 | ||
208 | (deftest test-pipe | |
209 | (async done | |
210 | (go | |
211 | (is (= [1 2 3 4 5] | |
212 | (let [out (chan)] | |
213 | (async/pipe (async/to-chan [1 2 3 4 5]) | |
214 | out) | |
215 | (<! (async/into [] out))))) | |
216 | (done)))) | |
217 | ||
218 | (deftest test-split | |
219 | (async done | |
220 | ;; Must provide buffers for channels else the tests won't complete | |
221 | (go | |
222 | (let [[even odd] (async/split even? (async/to-chan [1 2 3 4 5 6]) 5 5)] | |
223 | (is (= [2 4 6] (<! (async/into [] even)))) | |
224 | (is (= [1 3 5] (<! (async/into [] odd))))) | |
225 | (done)))) | |
226 | ||
227 | (deftest test-map | |
228 | (async done | |
229 | (go | |
230 | (is (= [0 4 8 12] | |
231 | (<! (async/into [] | |
232 | (async/map + | |
233 | [(async/to-chan (range 4)) | |
234 | (async/to-chan (range 4)) | |
235 | (async/to-chan (range 4)) | |
236 | (async/to-chan (range 4))]))))) | |
237 | (done)))) | |
238 | ||
239 | (deftest test-merge | |
240 | (async done | |
241 | ;; merge uses alt, so results can be in any order, we're using | |
242 | ;; frequencies as a way to make sure we get the right result. | |
243 | (go | |
244 | (is (= {0 4, 1 4, 2 4, 3 4} | |
245 | (frequencies | |
246 | (<! (async/into [] | |
247 | (async/merge | |
248 | [(async/to-chan (range 4)) | |
249 | (async/to-chan (range 4)) | |
250 | (async/to-chan (range 4)) | |
251 | (async/to-chan (range 4))])))))) | |
252 | (done)))) | |
253 | ||
254 | (deftest test-mult | |
255 | (async done | |
256 | (go | |
257 | (let [a (chan 4) | |
258 | b (chan 4) | |
259 | src (chan) | |
260 | m (async/mult src)] | |
261 | (async/tap m a) | |
262 | (async/tap m b) | |
263 | (async/pipe (async/to-chan (range 4)) src) | |
264 | (is (= [0 1 2 3] (<! (async/into [] a)))) | |
265 | (is (= [0 1 2 3] (<! (async/into [] b)))) | |
266 | (done))))) | |
267 | ||
268 | (deftest test-mix | |
269 | (async done | |
270 | (go | |
271 | (let [out (chan) | |
272 | mx (async/mix out) | |
273 | take-out (chan) | |
274 | take6 (go (dotimes [x 6] | |
275 | (>! take-out (<! out))) | |
276 | (close! take-out))] | |
277 | (async/admix mx (async/to-chan [1 2 3])) | |
278 | (async/admix mx (async/to-chan [4 5 6])) | |
279 | (is (= #{1 2 3 4 5 6} (<! (async/into #{} take-out)))) | |
280 | (done))))) | |
281 | ||
282 | (deftest test-pub-sub | |
283 | (async done | |
284 | (go | |
285 | (let [a-ints (chan 5) | |
286 | a-strs (chan 5) | |
287 | b-ints (chan 5) | |
288 | b-strs (chan 5) | |
289 | src (chan) | |
290 | p (async/pub src (fn [x] | |
291 | (if (string? x) | |
292 | :string | |
293 | :int)))] | |
294 | (async/sub p :string a-strs) | |
295 | (async/sub p :string b-strs) | |
296 | (async/sub p :int a-ints) | |
297 | (async/sub p :int b-ints) | |
298 | (async/pipe (async/to-chan [1 "a" 2 "b" 3 "c"]) src) | |
299 | (is (= [1 2 3] | |
300 | (<! (async/into [] a-ints)))) | |
301 | (is (= [1 2 3] | |
302 | (<! (async/into [] b-ints)))) | |
303 | (is (= ["a" "b" "c"] | |
304 | (<! (async/into [] a-strs)))) | |
305 | (is (= ["a" "b" "c"] | |
306 | (<! (async/into [] b-strs))))) | |
307 | (done)))) | |
308 | ||
309 | (deftest test-unique | |
310 | (async done | |
311 | (go | |
312 | (is (= [1 2 3 4] | |
313 | (<! (async/into [] (async/unique (async/to-chan [1 1 2 2 3 3 3 3 4])))))) | |
314 | (done)))) | |
315 | ||
316 | (deftest test-partition | |
317 | (async done | |
318 | (go | |
319 | (is (= [[1 2] [2 3]] | |
320 | (<! (async/into [] (async/partition 2 (async/to-chan [1 2 2 3])))))) | |
321 | (done)))) | |
322 | ||
323 | ||
324 | (deftest test-partition-by | |
325 | (async done | |
326 | (go | |
327 | (is (= [["a" "b"] [1 :2 3] ["c"]] | |
328 | (<! (async/into [] (async/partition-by string? (async/to-chan ["a" "b" 1 :2 3 "c"])))))) | |
329 | (done)))) | |
330 | ||
331 | (deftest test-reduce | |
332 | (async done | |
333 | (let [l (latch 3 done)] | |
334 | (go (is (= 0 (<! (async/reduce + 0 (async/to-chan []))))) | |
335 | (inc! l)) | |
336 | (go (is (= 45 (<! (async/reduce + 0 (async/to-chan (range 10)))))) | |
337 | (inc! l)) | |
338 | (go (is (= :foo (<! (async/reduce #(if (= %2 2) (reduced :foo) %1) 0 | |
339 | (async/to-chan (range 10)))))) | |
340 | (inc! l))))) | |
341 | ||
342 | (deftest dispatch-bugs | |
343 | (async done | |
344 | (testing "puts are moved to buffers" | |
345 | (let [c (chan 1) | |
346 | a (atom 0)] | |
347 | (put! c 42 (fn [_] (swap! a inc))) ;; Goes into buffer | |
348 | (put! c 42 (fn [_] (swap! a inc))) ;; Goes into puts | |
349 | (take! c | |
350 | (fn [_] | |
351 | ;; Should release the iten in the puts and | |
352 | ;; put its value into the buffer, dispatching the callback | |
353 | (go | |
354 | (<! (timeout 500)) | |
355 | ;; Thus this should be 2 | |
356 | (is (= @a 2)) | |
357 | (done)))))))) | |
358 | ||
359 | (defn integer-chan | |
360 | "Returns a channel upon which will be placed integers from 0 to n (exclusive) at 10 ms intervals, using the provided xform" | |
361 | [n xform] | |
362 | (let [c (chan 1 xform)] | |
363 | (go | |
364 | (loop [i 0] | |
365 | (if (< i n) | |
366 | (do | |
367 | (<! (timeout 10)) | |
368 | (>! c i) | |
369 | (recur (inc i))) | |
370 | (close! c)))) | |
371 | c)) | |
372 | ||
373 | (deftest test-transducers | |
374 | (async done | |
375 | (let [l (latch 6 done)] | |
376 | (testing "base case without transducer" | |
377 | (go (is (= (range 10) | |
378 | (<! (async/into [] (integer-chan 10 nil))))) | |
379 | (inc! l))) | |
380 | (testing "mapping transducer" | |
381 | (go (is (= (map str (range 10)) | |
382 | (<! (async/into [] (integer-chan 10 (map str)))))) | |
383 | (inc! l))) | |
384 | (testing "filtering transducer" | |
385 | (go (is (= (filter even? (range 10)) | |
386 | (<! (async/into [] (integer-chan 10 (filter even?)))))) | |
387 | (inc! l))) | |
388 | (testing "flatpmapping transducer" | |
389 | (let [pair-of (fn [x] [x x])] | |
390 | (go (is (= (mapcat pair-of (range 10)) | |
391 | (<! (async/into [] (integer-chan 10 (mapcat pair-of)))))) | |
392 | (inc! l)))) | |
393 | (testing "partitioning transducer" | |
394 | (go (is (= [[0 1 2 3 4] [5 6 7]] | |
395 | (<! (async/into [] (integer-chan 8 (partition-all 5)))))) | |
396 | (inc! l)) | |
397 | (go (is (= [[0 1 2 3 4] [5 6 7 8 9]] | |
398 | (<! (async/into [] (integer-chan 10 (partition-all 5)))))) | |
399 | (inc! l)))))) | |
400 | ||
401 | (deftest test-bufferless | |
402 | (async done | |
403 | (let [c (chan) | |
404 | l (latch 2 done)] | |
405 | (go | |
406 | (is (= [:value c] (async/alts! [c (async/timeout 6000)] :priority true))) | |
407 | (inc! l)) | |
408 | (go | |
409 | (is (= [true c] (async/alts! [[c :value] (async/timeout 6000)] :priority true))) | |
410 | (inc! l))))) | |
411 | ||
412 | (deftest test-promise-chan | |
413 | (async done | |
414 | (let [l (latch 3 done)] | |
415 | (testing "put on promise-chan fulfills all pending takers" | |
416 | (let [c (promise-chan) | |
417 | t1 (go (<! c)) | |
418 | t2 (go (<! c))] | |
419 | (go | |
420 | (>! c :val) | |
421 | (is (= :val (<! t1) (<! t2))) | |
422 | (testing "then puts succeed but are dropped" | |
423 | (go (>! c :LOST)) | |
424 | (is (= :val (<! c)))) | |
425 | (testing "then takes succeed with the original value" | |
426 | (is (= :val (<! c) (<! c) (<! c)))) | |
427 | (testing "then after close takes continue returning val" | |
428 | (close! c) | |
429 | (is (= :val (<! c) (<! c)))) | |
430 | (inc! l)))) | |
431 | (testing "close on promise-chan fulfills all pending takers" | |
432 | (go | |
433 | (let [c (promise-chan) | |
434 | t1 (go (<! c)) | |
435 | t2 (go (<! c))] | |
436 | (close! c) | |
437 | (is (= nil (<! t1) (<! t2))) | |
438 | (testing "then takes return nil" | |
439 | (is (= nil (<! t1) (<! t1) (<! t2) (<! t2))))) | |
440 | (inc! l))) | |
441 | (testing "close after put on promise-chan continues delivering promised value" | |
442 | (go | |
443 | (let [c (promise-chan)] | |
444 | (>! c :val) ;; deliver | |
445 | (is (= :val (<! c) (<! c))) | |
446 | (close! c) | |
447 | (is (= :val (<! c) (<! c)))) | |
448 | (inc! l)))))) | |
449 | ||
450 | (deftest test-offer-poll-go | |
451 | (let [c (chan 2)] | |
452 | (is (= [true true 5 6 nil] | |
453 | [(offer! c 5) (offer! c 6) (poll! c) (poll! c) (poll! c)]))) | |
454 | (let [c (chan 2)] | |
455 | (is (true? (offer! c 1))) | |
456 | (is (true? (offer! c 2))) | |
457 | (is (nil? (offer! c 3))) | |
458 | (is (= 1 (poll! c))) | |
459 | (is (= 2 (poll! c))) | |
460 | (is (nil? (poll! c)))) | |
461 | (let [c (chan)] | |
462 | (is (nil? (offer! c 1))) | |
463 | (is (nil? (poll! c))))) | |
464 | ||
465 | (deftest test-transduce | |
466 | (go | |
467 | (= [1 2 3 4 5] | |
468 | (<! (async/transduce (map inc) conj [] (async/to-chan (range 5))))))) |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns clojure.core.async.buffers-test | |
9 | (:require [clojure.test :refer :all] | |
10 | [clojure.core.async.impl.buffers :refer :all] | |
11 | [clojure.core.async.impl.protocols :refer [full? add! remove! close-buf!]])) | |
12 | ||
13 | (defmacro throws? [expr] | |
14 | `(try | |
15 | ~expr | |
16 | false | |
17 | (catch Throwable _# true))) | |
18 | ||
19 | (deftest fixed-buffer-tests | |
20 | (let [fb (fixed-buffer 2)] | |
21 | (is (= 0 (count fb))) | |
22 | ||
23 | (add! fb :1) | |
24 | (is (= 1 (count fb))) | |
25 | ||
26 | (add! fb :2) | |
27 | (is (= 2 (count fb))) | |
28 | ||
29 | (is (= :1 (remove! fb))) | |
30 | (is (not (full? fb))) | |
31 | ||
32 | (is (= 1 (count fb))) | |
33 | (is (= :2 (remove! fb))) | |
34 | ||
35 | (is (= 0 (count fb))) | |
36 | (is (throws? (remove! fb))))) | |
37 | ||
38 | (deftest dropping-buffer-tests | |
39 | (let [fb (dropping-buffer 2)] | |
40 | (is (= 0 (count fb))) | |
41 | ||
42 | (add! fb :1) | |
43 | (is (= 1 (count fb))) | |
44 | ||
45 | (add! fb :2) | |
46 | (is (= 2 (count fb))) | |
47 | ||
48 | (is (not (full? fb))) | |
49 | (is (not (throws? (add! fb :3)))) | |
50 | (is (= 2 (count fb))) | |
51 | ||
52 | (is (= :1 (remove! fb))) | |
53 | (is (not (full? fb))) | |
54 | ||
55 | (is (= 1 (count fb))) | |
56 | (is (= :2 (remove! fb))) | |
57 | ||
58 | (is (= 0 (count fb))) | |
59 | (is (throws? (remove! fb))))) | |
60 | ||
61 | (deftest sliding-buffer-tests | |
62 | (let [fb (sliding-buffer 2)] | |
63 | (is (= 0 (count fb))) | |
64 | ||
65 | (add! fb :1) | |
66 | (is (= 1 (count fb))) | |
67 | ||
68 | (add! fb :2) | |
69 | (is (= 2 (count fb))) | |
70 | ||
71 | (is (not (full? fb))) | |
72 | (is (not (throws? (add! fb :3)))) | |
73 | (is (= 2 (count fb))) | |
74 | ||
75 | (is (= :2 (remove! fb))) | |
76 | (is (not (full? fb))) | |
77 | ||
78 | (is (= 1 (count fb))) | |
79 | (is (= :3 (remove! fb))) | |
80 | ||
81 | (is (= 0 (count fb))) | |
82 | (is (throws? (remove! fb))))) | |
83 | ||
84 | (deftest promise-buffer-tests | |
85 | (let [pb (promise-buffer)] | |
86 | (is (= 0 (count pb))) | |
87 | ||
88 | (add! pb :1) | |
89 | (is (= 1 (count pb))) | |
90 | ||
91 | (add! pb :2) | |
92 | (is (= 1 (count pb))) | |
93 | ||
94 | (is (not (full? pb))) | |
95 | (is (not (throws? (add! pb :3)))) | |
96 | (is (= 1 (count pb))) | |
97 | ||
98 | (is (= :1 (remove! pb))) | |
99 | (is (not (full? pb))) | |
100 | ||
101 | (is (= 1 (count pb))) | |
102 | (is (= :1 (remove! pb))) | |
103 | ||
104 | (is (= nil (close-buf! pb))) | |
105 | (is (= :1 (remove! pb))))) |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns clojure.core.async.concurrent-test | |
9 | (:require [clojure.test :refer :all] | |
10 | [clojure.core.async.impl.concurrent :as conc]) | |
11 | (:import [java.util.concurrent ThreadFactory])) | |
12 | ||
13 | (deftest test-counted-thread-factory | |
14 | (testing "Creates numbered threads" | |
15 | (let [^ThreadFactory factory (conc/counted-thread-factory "foo-%d" true) | |
16 | threads (repeatedly 3 #(.newThread factory (constantly nil)))] | |
17 | (is (= ["foo-1" "foo-2" "foo-3"] (map #(.getName ^Thread %) threads)))))) | |
18 |
0 | ;; Copyright (c) Rich Hickey and contributors. All rights reserved. | |
1 | ;; The use and distribution terms for this software are covered by the | |
2 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) | |
3 | ;; which can be found in the file epl-v10.html at the root of this distribution. | |
4 | ;; By using this software in any fashion, you are agreeing to be bound by | |
5 | ;; the terms of this license. | |
6 | ;; You must not remove this notice, or any other, from this software. | |
7 | ||
8 | (ns clojure.core.async.exceptions-test | |
9 | "Verify that exceptions thrown on a thread pool managed by | |
10 | core.async will propagate out to the JVM's default uncaught | |
11 | exception handler." | |
12 | (:require [clojure.test :refer [deftest is]] | |
13 | [clojure.stacktrace :refer [root-cause]] | |
14 | [clojure.core.async :refer [chan go thread put! take! <!! >!!]])) | |
15 | ||
16 | (defn with-default-uncaught-exception-handler [handler f] | |
17 | (let [old-handler (Thread/getDefaultUncaughtExceptionHandler)] | |
18 | (Thread/setDefaultUncaughtExceptionHandler | |
19 | (reify Thread$UncaughtExceptionHandler | |
20 | (uncaughtException [_ thread throwable] | |
21 | (handler thread throwable)))) | |
22 | (f) | |
23 | (Thread/setDefaultUncaughtExceptionHandler old-handler))) | |
24 | ||
25 | (deftest exception-in-go | |
26 | (let [log (promise)] | |
27 | (with-default-uncaught-exception-handler | |
28 | (fn [_ throwable] (deliver log throwable)) | |
29 | #(let [ex (Exception. "This exception is expected") | |
30 | ret (go (throw ex))] | |
31 | (<!! ret) | |
32 | (is (identical? ex (root-cause @log))))))) | |
33 | ||
34 | (deftest exception-in-thread | |
35 | (let [log (promise)] | |
36 | (with-default-uncaught-exception-handler | |
37 | (fn [_ throwable] (deliver log throwable)) | |
38 | #(let [ex (Exception. "This exception is expected") | |
39 | ret (thread (throw ex))] | |
40 | (<!! ret) | |
41 | (is (identical? ex (root-cause @log))))))) | |
42 | ||
43 | (deftest exception-in-put-callback | |
44 | (let [log (promise)] | |
45 | (with-default-uncaught-exception-handler | |
46 | (fn [_ throwable] (deliver log throwable)) | |
47 | #(let [ex (Exception. "This exception is expected") | |
48 | c (chan)] | |
49 | (put! c :foo (fn [_] (throw ex))) | |
50 | (<!! c) | |
51 | (is (identical? ex (root-cause @log))))))) | |
52 | ||
53 | (deftest exception-in-take-callback | |
54 | (let [log (promise)] | |
55 | (with-default-uncaught-exception-handler | |
56 | (fn [_ throwable] (deliver log throwable)) | |
57 | #(let [ex (Exception. "This exception is expected") | |
58 | c (chan)] | |
59 | (take! c (fn [_] (throw ex))) | |
60 | (>!! c :foo) | |
61 | (is (identical? ex (root-cause @log))))))) |
0 | (ns clojure.core.async.ioc-macros-test | |
1 | (:refer-clojure :exclude [map into reduce transduce merge take partition | |
2 | partition-by]) | |
3 | (:require [clojure.core.async.impl.ioc-macros :as ioc] | |
4 | [clojure.core.async :refer :all :as async] | |
5 | [clojure.test :refer :all]) | |
6 | (:import [java.io FileInputStream ByteArrayOutputStream File])) | |
7 | ||
8 | (defn pause [x] | |
9 | x) | |
10 | ||
11 | (defn pause-run [state blk val] | |
12 | (ioc/aset-all! state ioc/STATE-IDX blk ioc/VALUE-IDX val) | |
13 | :recur) | |
14 | ||
15 | ||
16 | (defmacro runner | |
17 | "Creates a runner block. The code inside the body of this macro will be translated | |
18 | into a state machine. At run time the body will be run as normal. This transform is | |
19 | only really useful for testing." | |
20 | [& body] | |
21 | (let [terminators {`pause `pause-run} | |
22 | crossing-env (zipmap (keys &env) (repeatedly gensym))] | |
23 | `(let [captured-bindings# (clojure.lang.Var/getThreadBindingFrame) | |
24 | ~@(mapcat (fn [[l sym]] [sym `(^:once fn* [] ~l)]) crossing-env) | |
25 | state# (~(ioc/state-machine `(do ~@body) 0 [crossing-env &env] terminators))] | |
26 | (ioc/aset-all! state# | |
27 | ~ioc/BINDINGS-IDX | |
28 | captured-bindings#) | |
29 | (ioc/run-state-machine state#) | |
30 | (ioc/aget-object state# ioc/VALUE-IDX)))) | |
31 | ||
32 | (deftest test-try-catch-finally | |
33 | (testing "Don't endlessly loop when exceptions are thrown" | |
34 | (is (thrown? Exception | |
35 | (runner | |
36 | (loop [] | |
37 | (try | |
38 | (pause (throw (Exception. "Ex"))) | |
39 | (catch clojure.lang.ExceptionInfo ei | |
40 | :retry)))))) | |
41 | (is (thrown? Throwable | |
42 | (runner | |
43 | (loop [] | |
44 | (try | |
45 | (pause (throw (Throwable. "Ex"))) | |
46 | (catch clojure.lang.ExceptionInfo ei | |
47 | :retry)))))) | |
48 | ;; (is (try ((fn [] (println "Hello") (pause 5))) (catch Exception e))) | |
49 | (is (= :Throwable | |
50 | (runner | |
51 | (try | |
52 | (pause 5) | |
53 | (throw (new Throwable)) | |
54 | (catch Exception re | |
55 | :Exception) | |
56 | (catch Throwable t | |
57 | :Throwable)))))) | |
58 | (testing "finally shouldn't change the return value" | |
59 | (is (= 1 (runner (try 1 (finally (pause 2))))))) | |
60 | (testing "exception handlers stack" | |
61 | (is (= "eee" | |
62 | (runner | |
63 | (try | |
64 | (try | |
65 | (try | |
66 | (throw (pause (Exception. "e"))) | |
67 | (catch Exception e | |
68 | (pause (throw (Exception. (str (.getMessage e) "e")))))) | |
69 | (catch Exception e | |
70 | (throw (throw (Exception. (str (.getMessage e) "e")))))) | |
71 | (catch Exception e | |
72 | (.getMessage e))))))) | |
73 | (testing "exception handlers and the class hierarchy" | |
74 | (is | |
75 | (runner | |
76 | (try | |
77 | (pause 10) | |
78 | (throw (RuntimeException.)) | |
79 | (catch RuntimeException r | |
80 | (pause true)) | |
81 | (catch Exception e | |
82 | (pause false))))) | |
83 | (is | |
84 | (runner | |
85 | (try | |
86 | (pause 10) | |
87 | (throw (RuntimeException.)) | |
88 | (catch Exception e | |
89 | (pause true)))))) | |
90 | (testing "don't explode trying to compile this" | |
91 | (is | |
92 | (runner | |
93 | (try | |
94 | true | |
95 | (catch Exception e | |
96 | (pause 1) | |
97 | e)))))) | |
98 | ||
99 | ||
100 | (defmacro locals-test [] | |
101 | (if (if (contains? &env :locals) | |
102 | (get (:locals &env) 'x) | |
103 | (get &env 'x)) | |
104 | :pass | |
105 | :fail)) | |
106 | ||
107 | ||
108 | (deftest runner-tests | |
109 | (testing "macros add locals to the env" | |
110 | (is (= :pass | |
111 | (runner (let [x 42] | |
112 | (pause (locals-test))))))) | |
113 | (testing "fn as first arg in sexpr" | |
114 | (is (= 42 | |
115 | (runner ((fn [] 42)))))) | |
116 | (testing "do blocks" | |
117 | (is (= 42 | |
118 | (runner (do (pause 42))))) | |
119 | (is (= 42 | |
120 | (runner (do (pause 44) | |
121 | (pause 42)))))) | |
122 | (testing "if expressions" | |
123 | (is (= true | |
124 | (runner (if (pause true) | |
125 | (pause true) | |
126 | (pause false))))) | |
127 | (is (= false | |
128 | (runner (if (pause false) | |
129 | (pause true) | |
130 | (pause false))))) | |
131 | (is (= true | |
132 | (runner (when (pause true) | |
133 | (pause true))))) | |
134 | (is (= nil | |
135 | (runner (when (pause false) | |
136 | (pause true)))))) | |
137 | ||
138 | (testing "dot forms" | |
139 | (is (= 42 (runner (. Long (parseLong "42"))))) | |
140 | (is (= 42 (runner (. Long parseLong "42"))))) | |
141 | ||
142 | (testing "quote" | |
143 | (is (= '(1 2 3) | |
144 | (runner (pause '(1 2 3)))))) | |
145 | ||
146 | (testing "loop expressions" | |
147 | (is (= 100 | |
148 | (runner (loop [x 0] | |
149 | (if (< x 100) | |
150 | (recur (inc (pause x))) | |
151 | (pause x)))))) | |
152 | (is (= 100 | |
153 | (runner (loop [x (pause 0)] | |
154 | (if (< x 100) | |
155 | (recur (inc (pause x))) | |
156 | (pause x)))))) | |
157 | (is (= [:b :a] | |
158 | (runner (loop [a :a b :b n 1] | |
159 | (if (pos? n) | |
160 | (recur b a (dec n)) ;; swap bindings | |
161 | [a b]))))) | |
162 | (is (= 1 | |
163 | (runner (loop [x 0 | |
164 | y (inc x)] | |
165 | y))))) | |
166 | ||
167 | (testing "let expressions" | |
168 | (is (= 3 | |
169 | (runner (let [x 1 y 2] | |
170 | (+ x y)))))) | |
171 | ||
172 | (testing "vector destructuring" | |
173 | (is (= 3 | |
174 | (runner (let [[x y] [1 2]] | |
175 | (+ x y)))))) | |
176 | ||
177 | (testing "hash-map destructuring" | |
178 | (is (= 3 | |
179 | (runner (let [{:keys [x y] x2 :x y2 :y :as foo} {:x 1 :y 2}] | |
180 | (assert (and foo (pause x) y x2 y2 foo)) | |
181 | (+ x y)))))) | |
182 | ||
183 | (testing "hash-map literals" | |
184 | (is (= {:1 1 :2 2 :3 3} | |
185 | (runner {:1 (pause 1) | |
186 | :2 (pause 2) | |
187 | :3 (pause 3)})))) | |
188 | (testing "hash-set literals" | |
189 | (is (= #{1 2 3} | |
190 | (runner #{(pause 1) | |
191 | (pause 2) | |
192 | (pause 3)})))) | |
193 | (testing "vector literals" | |
194 | (is (= [1 2 3] | |
195 | (runner [(pause 1) | |
196 | (pause 2) | |
197 | (pause 3)])))) | |
198 | ||
199 | (testing "keywords as functions" | |
200 | (is (= :bar | |
201 | (runner (:foo (pause {:foo :bar})))))) | |
202 | ||
203 | (testing "vectors as functions" | |
204 | (is (= 2 | |
205 | (runner ([1 2] 1))))) | |
206 | ||
207 | (testing "dotimes" | |
208 | (is (= 42 (runner | |
209 | (dotimes [x 10] | |
210 | (pause x)) | |
211 | 42)))) | |
212 | ||
213 | (testing "fn closures" | |
214 | (is (= 42 | |
215 | (runner | |
216 | (let [x 42 | |
217 | _ (pause x) | |
218 | f (fn [] x)] | |
219 | (f)))))) | |
220 | ||
221 | (testing "lazy-seqs in bodies" | |
222 | (is (= nil | |
223 | (runner | |
224 | (loop [] | |
225 | (when-let [x (pause 10)] | |
226 | (pause (vec (for [i (range x)] | |
227 | i))) | |
228 | (if-not x | |
229 | (recur)))))))) | |
230 | ||
231 | (testing "specials cannot be shadowed" | |
232 | (is (= 3 | |
233 | (let [let* :foo] (runner (let* [x 3] x)))))) | |
234 | ||
235 | (testing "case" | |
236 | (is (= 43 | |
237 | (runner | |
238 | (let [value :bar] | |
239 | (case value | |
240 | :foo (pause 42) | |
241 | :bar (pause 43) | |
242 | :baz (pause 44)))))) | |
243 | (is (= :default | |
244 | (runner | |
245 | (case :baz | |
246 | :foo 44 | |
247 | :default)))) | |
248 | (is (= nil | |
249 | (runner | |
250 | (case true | |
251 | false false | |
252 | nil)))) | |
253 | (is (= 42 | |
254 | (runner | |
255 | (loop [x 0] | |
256 | (case (int x) | |
257 | 0 (recur (inc x)) | |
258 | 1 42)))))) | |
259 | ||
260 | (testing "try" | |
261 | (is (= 42 | |
262 | (runner | |
263 | (try 42 | |
264 | (catch Throwable ex ex))))) | |
265 | (is (= 42 | |
266 | (runner | |
267 | (try | |
268 | (assert false) | |
269 | (catch Throwable ex 42))))) | |
270 | ||
271 | (let [a (atom false) | |
272 | v (runner | |
273 | (try | |
274 | true | |
275 | (catch Throwable ex false) | |
276 | (finally (pause (reset! a true)))))] | |
277 | (is (and @a v))) | |
278 | ||
279 | (let [a (atom false) | |
280 | v (runner | |
281 | (try | |
282 | (assert false) | |
283 | (catch Throwable ex true) | |
284 | (finally (reset! a true))))] | |
285 | (is (and @a v))) | |
286 | ||
287 | (let [a (atom false) | |
288 | v (try (runner | |
289 | (try | |
290 | (assert false) | |
291 | (finally (reset! a true)))) | |
292 | (catch Throwable ex ex))] | |
293 | (is (and @a v))) | |
294 | ||
295 | ||
296 | (let [a (atom 0) | |
297 | v (runner | |
298 | (try | |
299 | (try | |
300 | 42 | |
301 | (finally (swap! a inc))) | |
302 | (finally (swap! a inc))))] | |
303 | (is (= @a 2))) | |
304 | ||
305 | (let [a (atom 0) | |
306 | v (try (runner | |
307 | (try | |
308 | (try | |
309 | (throw (AssertionError. 42)) | |
310 | (finally (swap! a inc))) | |
311 | (finally (swap! a inc)))) | |
312 | (catch AssertionError ex ex))] | |
313 | (is (= @a 2))) | |
314 | ||
315 | (let [a (atom 0) | |
316 | v (try (runner | |
317 | (try | |
318 | (try | |
319 | (throw (AssertionError. 42)) | |
320 | (catch Throwable ex (throw ex)) | |
321 | (finally (swap! a inc))) | |
322 | (catch Throwable ex (throw ex)) | |
323 | (finally (swap! a inc)))) | |
324 | (catch AssertionError ex ex))] | |
325 | (is (= @a 2))) | |
326 | ||
327 | (let [a (atom 0) | |
328 | v (try (runner | |
329 | (try | |
330 | (try | |
331 | (throw (AssertionError. (pause 42))) | |
332 | (catch Throwable ex (pause (throw ex))) | |
333 | (finally (pause (swap! a inc)))) | |
334 | (catch Throwable ex (pause (throw ex))) | |
335 | (finally (pause (swap! a inc))))) | |
336 | (catch AssertionError ex ex))] | |
337 | (is (= @a 2))))) | |
338 | ||
339 | ||
340 | (defn identity-chan | |
341 | "Defines a channel that instantly writes the given value" | |
342 | [x] | |
343 | (let [c (chan 1)] | |
344 | (>!! c x) | |
345 | (close! c) | |
346 | c)) | |
347 | ||
348 | (deftest async-test | |
349 | (testing "values are returned correctly" | |
350 | (is (= 10 | |
351 | (<!! (go (<! (identity-chan 10))))))) | |
352 | (testing "writes work" | |
353 | (is (= 11 | |
354 | (<!! (go (let [c (chan 1)] | |
355 | (>! c (<! (identity-chan 11))) | |
356 | (<! c))))))) | |
357 | ||
358 | (testing "case with go" | |
359 | (is (= :1 | |
360 | (<!! (go (case (name :1) | |
361 | "0" :0 | |
362 | "1" :1 | |
363 | :3)))))) | |
364 | ||
365 | (testing "nil result of go" | |
366 | (is (= nil | |
367 | (<!! (go nil))))) | |
368 | ||
369 | (testing "take inside binding of loop" | |
370 | (is (= 42 | |
371 | (<!! (go (loop [x (<! (identity-chan 42))] | |
372 | x)))))) | |
373 | ||
374 | (testing "can get from a catch" | |
375 | (let [c (identity-chan 42)] | |
376 | (is (= 42 | |
377 | (<!! (go (try | |
378 | (assert false) | |
379 | (catch Throwable ex (<! c)))))))))) | |
380 | ||
381 | (deftest offer-poll | |
382 | (let [c (chan 2)] | |
383 | (is (= [true true 5 6 nil] | |
384 | (<!! (go [(offer! c 5) (offer! c 6) (poll! c) (poll! c) (poll! c)])))))) | |
385 | ||
386 | (deftest enqueued-chan-ops | |
387 | (testing "enqueued channel puts re-enter async properly" | |
388 | (is (= [:foo 42] | |
389 | (let [c (chan) | |
390 | result-chan (go (>! c :foo) 42)] | |
391 | [(<!! c) (<!! result-chan)])))) | |
392 | (testing "enqueued channel takes re-enter async properly" | |
393 | (is (= :foo | |
394 | (let [c (chan) | |
395 | async-chan (go (<! c))] | |
396 | (>!! c :foo) | |
397 | (<!! async-chan))))) | |
398 | (testing "puts into channels with full buffers re-enter async properly" | |
399 | (is (= #{:foo :bar :baz :boz} | |
400 | (let [c (chan 1) | |
401 | async-chan (go | |
402 | (>! c :foo) | |
403 | (>! c :bar) | |
404 | (>! c :baz) | |
405 | ||
406 | (>! c :boz) | |
407 | (<! c))] | |
408 | (set [(<!! c) | |
409 | (<!! c) | |
410 | (<!! c) | |
411 | (<!! async-chan)])))))) | |
412 | ||
413 | (defn rand-timeout [x] | |
414 | (timeout (rand-int x))) | |
415 | ||
416 | (deftest alt-tests | |
417 | (testing "alts works at all" | |
418 | (let [c (identity-chan 42)] | |
419 | (is (= [42 c] | |
420 | (<!! (go (alts! | |
421 | [c]))))))) | |
422 | (testing "alt works" | |
423 | (is (= [42 :foo] | |
424 | (<!! (go (alt! | |
425 | (identity-chan 42) ([v] [v :foo]))))))) | |
426 | ||
427 | (testing "alts can use default" | |
428 | (is (= [42 :default] | |
429 | (<!! (go (alts! | |
430 | [(chan 1)] :default 42)))))) | |
431 | ||
432 | (testing "alt can use default" | |
433 | (is (= 42 | |
434 | (<!! (go (alt! | |
435 | (chan) ([v] :failed) | |
436 | :default 42)))))) | |
437 | ||
438 | (testing "alt obeys its random-array initialization" | |
439 | (is (= #{:two} | |
440 | (with-redefs [clojure.core.async/random-array | |
441 | (constantly (int-array [1 2 0]))] | |
442 | (<!! (go (loop [acc #{} | |
443 | cnt 0] | |
444 | (if (< cnt 10) | |
445 | (let [label (alt! | |
446 | (identity-chan :one) ([v] v) | |
447 | (identity-chan :two) ([v] v) | |
448 | (identity-chan :three) ([v] v))] | |
449 | (recur (conj acc label) (inc cnt))) | |
450 | acc))))))))) | |
451 | ||
452 | (deftest close-on-exception-tests | |
453 | (testing "threads" | |
454 | (is (nil? (<!! (thread (assert false "This exception is expected"))))) | |
455 | (is (nil? (<!! (thread (alts!! [(identity-chan 42)]) | |
456 | (assert false "This exception is expected")))))) | |
457 | (testing "go blocks" | |
458 | (is (nil? (<!! (go (assert false "This exception is expected"))))) | |
459 | (is (nil? (<!! (go (alts! [(identity-chan 42)]) | |
460 | (assert false "This exception is expected"))))))) | |
461 | ||
462 | (deftest resolution-tests | |
463 | (let [<! (constantly 42)] | |
464 | (is (= 42 (<!! (go (<! (identity-chan 0))))) | |
465 | "symbol translations do not apply to locals outside go")) | |
466 | ||
467 | (is (= 42 (<!! (go (let [<! (constantly 42)] | |
468 | (<! (identity-chan 0)))))) | |
469 | "symbol translations do not apply to locals inside go") | |
470 | ||
471 | (let [for vector x 3] | |
472 | (is (= [[3 [0 1]] 3] | |
473 | (<!! (go (for [x (range 2)] x)))) | |
474 | "locals outside go are protected from macroexpansion")) | |
475 | ||
476 | (is (= [[3 [0 1]] 3] | |
477 | (<!! (go (let [for vector x 3] | |
478 | (for [x (range 2)] x))))) | |
479 | "locals inside go are protected from macroexpansion") | |
480 | ||
481 | (let [c (identity-chan 42)] | |
482 | (is (= [42 c] (<!! (go (async/alts! [c])))) | |
483 | "symbol translations apply to resolved symbols"))) | |
484 | ||
485 | (deftest go-nests | |
486 | (is (= [23 42] (<!! (<!! (go (let [let* 1 a 23] (go (let* [b 42] [a b]))))))))) | |
487 | ||
488 | (defprotocol P | |
489 | (x [p])) | |
490 | ||
491 | (defrecord R [z] | |
492 | P | |
493 | (x [this] | |
494 | (go | |
495 | (loop [] | |
496 | (if (zero? (rand-int 3)) | |
497 | [z (.z this)] | |
498 | (recur)))))) | |
499 | ||
500 | (deftest go-propagates-primitive-hints | |
501 | (is (= "asd" (<!! (let [a (int 1)] (go (.substring "fasd" a)))))) | |
502 | (is (= 1 (<!! (let [a (int 1)] (go (Integer/valueOf a)))))) | |
503 | (is (= [1 1] (<!! (x (R. 1)))))) | |
504 | ||
505 | (deftest ASYNC-186 | |
506 | (is (let [y nil] (go)))) |
0 | (ns clojure.core.async.lab-test | |
1 | (:use clojure.test | |
2 | clojure.core.async.lab) | |
3 | (:require [clojure.core.async :as async])) | |
4 | ||
5 | (deftest multiplex-test | |
6 | (is (apply = (let [even-chan (async/chan) | |
7 | odd-chan (async/chan) | |
8 | muxer (multiplex even-chan odd-chan) | |
9 | odds (filter odd? (range 10)) | |
10 | evens (filter even? (range 10)) | |
11 | odd-pusher (doto (Thread. #(doseq [odd odds] | |
12 | (async/>!! odd-chan odd))) | |
13 | (.start)) | |
14 | even-pusher (doto (Thread. #(doseq [even evens] | |
15 | (async/>!! even-chan even))) | |
16 | (.start)) | |
17 | expected (set (range 10)) | |
18 | observed (set (for [_ (range 10)] (async/<!! muxer)))] | |
19 | [expected observed])) | |
20 | "Multiplexing multiple channels returns a channel which returns | |
21 | the values written to each.") | |
22 | (is (let [short-chan (async/chan) | |
23 | long-chan (async/chan) | |
24 | muxer (multiplex short-chan long-chan) | |
25 | semaphore (promise) | |
26 | long-pusher (doto (Thread. #(do (dotimes [i 10000] | |
27 | (async/>!! long-chan i)) | |
28 | (async/close! short-chan))) | |
29 | (.start)) | |
30 | short-pusher (doto (Thread. #(do (dotimes [i 10] | |
31 | (async/>!! short-chan i)) | |
32 | (async/close! short-chan))) | |
33 | (.start)) | |
34 | observed (for [_ (range 10010)] (async/<!! muxer))] | |
35 | (every? identity observed)) | |
36 | "A closed channel will deliver nil, but the multiplexed channel | |
37 | will never deliver nil until all channels are closed.") | |
38 | (is (apply = (let [chans (take 5 (repeatedly #(async/chan))) | |
39 | muxer (apply multiplex chans)] | |
40 | (doseq [chan chans] | |
41 | (async/close! chan)) | |
42 | [nil (async/<!! muxer)])) | |
43 | "When all of a multiplexer's channels are closed, it behaves | |
44 | like a closed channel on read.")) | |
45 | ||
46 | (deftest broadcast-test | |
47 | (is (apply = (let [broadcast-receivers (repeatedly 5 #(async/chan 1)) | |
48 | broadcaster (apply broadcast broadcast-receivers) | |
49 | broadcast-result (async/>!! broadcaster :foo) | |
50 | expected (repeat 5 :foo) | |
51 | observed (doall (map async/<!! broadcast-receivers))] | |
52 | [expected observed])) | |
53 | "Broadcasting to multiple channels returns a channel which will | |
54 | write to all the target channels.") | |
55 | (is (apply = (let [broadcast-receivers (repeatedly 5 async/chan) | |
56 | broadcaster (apply broadcast broadcast-receivers) | |
57 | read-channels (take 4 broadcast-receivers) | |
58 | broadcast-future (future (async/>!! broadcaster :foo) | |
59 | (async/>!! broadcaster :bar)) | |
60 | first-reads (doall (map async/<!! read-channels)) | |
61 | timeout-channel (async/timeout 500) | |
62 | alt-read (async/alts!! (conj read-channels timeout-channel)) | |
63 | expected [(repeat 4 :foo) [nil timeout-channel]] | |
64 | observed [first-reads alt-read]] | |
65 | (async/<!! (last broadcast-receivers)) | |
66 | (doseq [channel broadcast-receivers] | |
67 | (async/<!! channel)) | |
68 | [expected observed])) | |
69 | "Broadcasts block further writes if one of the channels cannot | |
70 | complete its write.") | |
71 | (is (apply = (let [broadcast-receivers (repeatedly 5 #(async/chan 100)) | |
72 | broadcaster (apply broadcast broadcast-receivers) | |
73 | broadcast-future (future (dotimes [i 100] | |
74 | (async/>!! broadcaster i))) | |
75 | observed (for [i (range 100)] | |
76 | (async/<!! (first broadcast-receivers))) | |
77 | expected (range 100)] | |
78 | [expected observed])) "When all channels are sufficiently buffered, reads on one channel are not throttled by reads from other channels.")) |
0 | (ns clojure.core.async.mutex-test | |
1 | (:use clojure.test) | |
2 | (:import (clojure.core.async Mutex))) | |
3 | ||
4 | (deftest mutex-test | |
5 | (let [lock (Mutex.)] | |
6 | (.lock lock) | |
7 | (try | |
8 | ;; do stuff | |
9 | (finally | |
10 | (.unlock lock))))) |
0 | (ns clojure.core.async.timers-test | |
1 | (:require [clojure.test :refer :all] | |
2 | [clojure.core.async.impl.timers :refer :all] | |
3 | [clojure.core.async :as async])) | |
4 | ||
5 | (deftest timeout-interval-test | |
6 | (let [start-stamp (System/currentTimeMillis) | |
7 | test-timeout (timeout 500)] | |
8 | (is (<= (+ start-stamp 500) | |
9 | (do (async/<!! test-timeout) | |
10 | (System/currentTimeMillis))) | |
11 | "Reading from a timeout channel does not complete until the specified milliseconds have elapsed."))) | |
12 | ||
13 | (deftest timeout-ordering-test | |
14 | (let [test-atom (atom []) | |
15 | timeout-channels [(timeout 800) | |
16 | (timeout 600) | |
17 | (timeout 700) | |
18 | (timeout 500)] | |
19 | threads (doall (for [i (range 4)] | |
20 | (doto (Thread. #(do (async/<!! (timeout-channels i)) | |
21 | (swap! test-atom conj i))) | |
22 | (.start))))] | |
23 | (doseq [thread threads] | |
24 | (.join ^Thread thread)) | |
25 | (is (= @test-atom [3 1 2 0]) | |
26 | "Timeouts close in order determined by their delays, not in order determined by their creation."))) |
0 | (ns clojure.core.async-test | |
1 | (:refer-clojure :exclude [map into reduce transduce merge take partition partition-by]) | |
2 | (:require [clojure.core.async.impl.buffers :as b] | |
3 | [clojure.core.async :refer :all :as a] | |
4 | [clojure.test :refer :all])) | |
5 | ||
6 | ||
7 | (defn default-chan [] | |
8 | (chan 1)) | |
9 | ||
10 | (deftest buffers-tests | |
11 | (is (not (unblocking-buffer? (buffer 1)))) | |
12 | (is (unblocking-buffer? (dropping-buffer 1))) | |
13 | (is (unblocking-buffer? (sliding-buffer 1))) | |
14 | (is (unblocking-buffer? (b/promise-buffer)))) | |
15 | ||
16 | (deftest basic-channel-test | |
17 | (let [c (default-chan) | |
18 | f (future (<!! c))] | |
19 | (>!! c 42) | |
20 | (is (= @f 42)))) | |
21 | ||
22 | (def DEREF_WAIT 20) | |
23 | ||
24 | (deftest writes-block-on-full-buffer | |
25 | (let [c (default-chan) | |
26 | _ (>!! c 42) | |
27 | blocking (deref (future (>!! c 43)) DEREF_WAIT :blocked)] | |
28 | (is (= blocking :blocked)))) | |
29 | ||
30 | (deftest unfulfilled-readers-block | |
31 | (let [c (default-chan) | |
32 | r1 (future (<!! c)) | |
33 | r2 (future (<!! c)) | |
34 | _ (>!! c 42) | |
35 | r1v (deref r1 DEREF_WAIT :blocked) | |
36 | r2v (deref r2 DEREF_WAIT :blocked)] | |
37 | (is (and (or (= r1v :blocked) (= r2v :blocked)) | |
38 | (or (= 42 r1v) (= 42 r2v)))))) | |
39 | ||
40 | (deftest test-<!!-and-put! | |
41 | (let [executed (promise) | |
42 | test-channel (chan nil)] | |
43 | (put! test-channel :test-val (fn [_] (deliver executed true))) | |
44 | (is (not (realized? executed)) "The provided callback does not execute until | |
45 | a reader can consume the written value.") | |
46 | (is (= :test-val (<!! test-channel)) | |
47 | "The written value is provided over the channel when a reader arrives.") | |
48 | (is @executed "The provided callback executes once the reader has arrived."))) | |
49 | ||
50 | (deftest test->!!-and-take! | |
51 | (is (= :test-val (let [read-promise (promise) | |
52 | test-channel (chan nil)] | |
53 | (take! test-channel #(deliver read-promise %)) | |
54 | (is (not (realized? read-promise)) | |
55 | "The read waits until a writer provides a value.") | |
56 | (>!! test-channel :test-val) | |
57 | (deref read-promise 1000 false))) | |
58 | "The written value is the value provided to the read callback.")) | |
59 | ||
60 | (deftest take!-on-caller? | |
61 | (is (apply not= (let [starting-thread (Thread/currentThread) | |
62 | test-channel (chan nil) | |
63 | read-promise (promise)] | |
64 | (take! test-channel (fn [_] (deliver read-promise (Thread/currentThread))) true) | |
65 | (>!! test-channel :foo) | |
66 | [starting-thread @read-promise])) | |
67 | "When on-caller? requested, but no value is immediately | |
68 | available, take!'s callback executes on another thread.") | |
69 | (is (apply = (let [starting-thread (Thread/currentThread) | |
70 | test-channel (chan nil) | |
71 | read-promise (promise)] | |
72 | (put! test-channel :foo (constantly nil)) | |
73 | (take! test-channel (fn [_] (deliver read-promise (Thread/currentThread))) true) | |
74 | [starting-thread @read-promise])) | |
75 | "When on-caller? requested, and a value is ready to read, | |
76 | take!'s callback executes on the same thread.") | |
77 | (is (apply not= (let [starting-thread (Thread/currentThread) | |
78 | test-channel (chan nil) | |
79 | read-promise (promise)] | |
80 | (put! test-channel :foo (constantly nil)) | |
81 | (take! test-channel (fn [_] (deliver read-promise (Thread/currentThread))) false) | |
82 | [starting-thread @read-promise])) | |
83 | "When on-caller? is false, and a value is ready to read, | |
84 | take!'s callback executes on a different thread.")) | |
85 | ||
86 | (deftest put!-on-caller? | |
87 | (is (apply = (let [starting-thread (Thread/currentThread) | |
88 | test-channel (chan nil) | |
89 | write-promise (promise)] | |
90 | (take! test-channel (fn [_] nil)) | |
91 | (put! test-channel :foo (fn [_] (deliver write-promise (Thread/currentThread))) true) | |
92 | [starting-thread @write-promise])) | |
93 | "When on-caller? requested, and a reader can consume the value, | |
94 | put!'s callback executes on the same thread.") | |
95 | (is (apply not= (let [starting-thread (Thread/currentThread) | |
96 | test-channel (chan nil) | |
97 | write-promise (promise)] | |
98 | (take! test-channel (fn [_] nil)) | |
99 | (put! test-channel :foo (fn [_] (deliver write-promise (Thread/currentThread))) false) | |
100 | [starting-thread @write-promise])) | |
101 | "When on-caller? is false, but a reader can consume the value, | |
102 | put!'s callback executes on a different thread.") | |
103 | (is (apply not= (let [starting-thread (Thread/currentThread) | |
104 | test-channel (chan nil) | |
105 | write-promise (promise)] | |
106 | (put! test-channel :foo (fn [_] (deliver write-promise (Thread/currentThread))) true) | |
107 | (take! test-channel (fn [_] nil)) | |
108 | [starting-thread @write-promise])) | |
109 | "When on-caller? requested, but no reader can consume the value, | |
110 | put!'s callback executes on a different thread.")) | |
111 | ||
112 | ||
113 | (deftest limit-async-take!-put! | |
114 | (testing "async put! limit" | |
115 | (let [c (chan)] | |
116 | (dotimes [x 1024] | |
117 | (put! c x)) | |
118 | (is (thrown? AssertionError | |
119 | (put! c 42))) | |
120 | (is (= (<!! c) 0)))) ;; make sure the channel unlocks | |
121 | (testing "async take! limit" | |
122 | (let [c (chan)] | |
123 | (dotimes [x 1024] | |
124 | (take! c (fn [x]))) | |
125 | (is (thrown? AssertionError | |
126 | (take! c (fn [x])))) | |
127 | (is (true? (>!! c 42)))))) ;; make sure the channel unlocks | |
128 | ||
129 | (deftest puts-fulfill-when-buffer-available | |
130 | (is (= :proceeded | |
131 | (let [c (chan 1) | |
132 | p (promise)] | |
133 | (>!! c :full) ;; fill up the channel | |
134 | (put! c :enqueues (fn [_] (deliver p :proceeded))) ;; enqueue a put | |
135 | (<!! c) ;; make room in the buffer | |
136 | (deref p 250 :timeout))))) | |
137 | ||
138 | (deftest offer-poll | |
139 | (let [c (chan 2)] | |
140 | (is (true? (offer! c 1))) | |
141 | (is (true? (offer! c 2))) | |
142 | (is (nil? (offer! c 3))) | |
143 | (is (= 1 (<!! c))) | |
144 | (is (= 2 (poll! c))) | |
145 | (is (nil? (poll! c)))) | |
146 | (let [c (chan)] | |
147 | (is (nil? (offer! c 1))) | |
148 | (is (nil? (poll! c))))) | |
149 | ||
150 | (deftest test-promise-chan | |
151 | (testing "put on promise-chan fulfills all pending takers" | |
152 | (let [c (promise-chan) | |
153 | t1 (thread (<!! c)) | |
154 | t2 (thread (<!! c))] | |
155 | (>!! c :val) | |
156 | (is (= :val (<!! t1) (<!! t2))) | |
157 | (testing "then puts succeed but are dropped" | |
158 | (>!! c :LOST) | |
159 | (is (= :val (<!! c)))) | |
160 | (testing "then takes succeed with the original value" | |
161 | (is (= :val (<!! c) (<!! c) (<!! c)))) | |
162 | (testing "then after close takes continue returning value" | |
163 | (close! c) | |
164 | (is (= :val (<!! c) (<!! c)))))) | |
165 | (testing "close on promise-chan fulfills all pending takers" | |
166 | (let [c (promise-chan) | |
167 | t1 (thread (<!! c)) | |
168 | t2 (thread (<!! c))] | |
169 | (close! c) | |
170 | (is (= nil (<!! t1) (<!! t2))) | |
171 | (testing "then takes return nil" | |
172 | (is (= nil (<!! t1) (<!! t1) (<!! t2) (<!! t2)))))) | |
173 | (testing "close after put on promise-chan continues delivering promised value" | |
174 | (let [c (promise-chan)] | |
175 | (>!! c :val) ;; deliver | |
176 | (is (= :val (<!! c) (<!! c))) | |
177 | (close! c) | |
178 | (is (= :val (<!! c) (<!! c)))))) | |
179 | ||
180 | (def ^:dynamic test-dyn false) | |
181 | ||
182 | (deftest thread-tests | |
183 | (testing "bindings" | |
184 | (binding [test-dyn true] | |
185 | (is (<!! (thread test-dyn)))))) | |
186 | ||
187 | ||
188 | (deftest ops-tests | |
189 | (testing "map<" | |
190 | (is (= [2 3 4 5] | |
191 | (<!! (a/into [] (a/map< inc (a/to-chan [1 2 3 4]))))))) | |
192 | (testing "map>" | |
193 | (is (= [2 3 4 5] | |
194 | (let [out (chan) | |
195 | in (a/map> inc out)] | |
196 | (a/onto-chan in [1 2 3 4]) | |
197 | (<!! (a/into [] out)))))) | |
198 | (testing "filter<" | |
199 | (is (= [2 4 6] | |
200 | (<!! (a/into [] (a/filter< even? (a/to-chan [1 2 3 4 5 6]))))))) | |
201 | (testing "remove<" | |
202 | (is (= [1 3 5] | |
203 | (<!! (a/into [] (a/remove< even? (a/to-chan [1 2 3 4 5 6]))))))) | |
204 | ||
205 | (testing "onto-chan" | |
206 | (is (= (range 10) | |
207 | (<!! (a/into [] (a/to-chan (range 10))))))) | |
208 | ||
209 | (testing "filter>" | |
210 | (is (= [2 4 6] | |
211 | (let [out (chan) | |
212 | in (filter> even? out)] | |
213 | (a/onto-chan in [1 2 3 4 5 6]) | |
214 | (<!! (a/into [] out)))))) | |
215 | (testing "remove>" | |
216 | (is (= [1 3 5] | |
217 | (let [out (chan) | |
218 | in (remove> even? out)] | |
219 | (a/onto-chan in [1 2 3 4 5 6]) | |
220 | (<!! (a/into [] out)))))) | |
221 | (testing "mapcat<" | |
222 | (is (= [0 0 1 0 1 2] | |
223 | (<!! (a/into [] (mapcat< range | |
224 | (a/to-chan [1 2 3]))))))) | |
225 | (testing "mapcat>" | |
226 | (is (= [0 0 1 0 1 2] | |
227 | (let [out (chan) | |
228 | in (mapcat> range out)] | |
229 | (a/onto-chan in [1 2 3]) | |
230 | (<!! (a/into [] out)))))) | |
231 | ||
232 | ||
233 | (testing "pipe" | |
234 | (is (= [1 2 3 4 5] | |
235 | (let [out (chan)] | |
236 | (pipe (a/to-chan [1 2 3 4 5]) | |
237 | out) | |
238 | (<!! (a/into [] out)))))) | |
239 | (testing "split" | |
240 | ;; Must provide buffers for channels else the tests won't complete | |
241 | (let [[even odd] (a/split even? (a/to-chan [1 2 3 4 5 6]) 5 5)] | |
242 | (is (= [2 4 6] | |
243 | (<!! (a/into [] even)))) | |
244 | (is (= [1 3 5] | |
245 | (<!! (a/into [] odd)))))) | |
246 | (testing "map" | |
247 | (is (= [0 4 8 12] | |
248 | (<!! (a/into [] (a/map + [(a/to-chan (range 4)) | |
249 | (a/to-chan (range 4)) | |
250 | (a/to-chan (range 4)) | |
251 | (a/to-chan (range 4))])))))) | |
252 | (testing "merge" | |
253 | ;; merge uses alt, so results can be in any order, we're using | |
254 | ;; frequencies as a way to make sure we get the right result. | |
255 | (is (= {0 4 | |
256 | 1 4 | |
257 | 2 4 | |
258 | 3 4} | |
259 | (frequencies (<!! (a/into [] (a/merge [(a/to-chan (range 4)) | |
260 | (a/to-chan (range 4)) | |
261 | (a/to-chan (range 4)) | |
262 | (a/to-chan (range 4))]))))))) | |
263 | ||
264 | (testing "mult" | |
265 | (let [a (chan 4) | |
266 | b (chan 4) | |
267 | src (chan) | |
268 | m (mult src)] | |
269 | (tap m a) | |
270 | (tap m b) | |
271 | (pipe (a/to-chan (range 4)) src) | |
272 | (is (= [0 1 2 3] | |
273 | (<!! (a/into [] a)))) | |
274 | (is (= [0 1 2 3] | |
275 | (<!! (a/into [] b)))))) | |
276 | ||
277 | ||
278 | (testing "mix" | |
279 | (let [out (chan) | |
280 | mx (mix out)] | |
281 | (admix mx (a/to-chan [1 2 3])) | |
282 | (admix mx (a/to-chan [4 5 6])) | |
283 | ||
284 | (is (= #{1 2 3 4 5 6} | |
285 | (<!! (a/into #{} (a/take 6 out))))))) | |
286 | ||
287 | (testing "pub-sub" | |
288 | (let [a-ints (chan 5) | |
289 | a-strs (chan 5) | |
290 | b-ints (chan 5) | |
291 | b-strs (chan 5) | |
292 | src (chan) | |
293 | p (pub src (fn [x] | |
294 | (if (string? x) | |
295 | :string | |
296 | :int)))] | |
297 | (sub p :string a-strs) | |
298 | (sub p :string b-strs) | |
299 | (sub p :int a-ints) | |
300 | (sub p :int b-ints) | |
301 | (pipe (a/to-chan [1 "a" 2 "b" 3 "c"]) src) | |
302 | (is (= [1 2 3] | |
303 | (<!! (a/into [] a-ints)))) | |
304 | (is (= [1 2 3] | |
305 | (<!! (a/into [] b-ints)))) | |
306 | (is (= ["a" "b" "c"] | |
307 | (<!! (a/into [] a-strs)))) | |
308 | (is (= ["a" "b" "c"] | |
309 | (<!! (a/into [] b-strs)))))) | |
310 | ||
311 | (testing "unique" | |
312 | (is (= [1 2 3 4] | |
313 | (<!! (a/into [] (a/unique (a/to-chan [1 1 2 2 3 3 3 3 4]))))))) | |
314 | ||
315 | (testing "partition" | |
316 | (is (= [[1 2] [2 3]] | |
317 | (<!! (a/into [] (a/partition 2 (a/to-chan [1 2 2 3]))))))) | |
318 | (testing "partition-by" | |
319 | (is (= [["a" "b"] [1 :2 3] ["c"]] | |
320 | (<!! (a/into [] (a/partition-by string? (a/to-chan ["a" "b" 1 :2 3 "c"]))))))) | |
321 | ||
322 | (testing "reduce" | |
323 | (is (= 0 (<!! (a/reduce + 0 (a/to-chan []))))) | |
324 | (is (= 45 (<!! (a/reduce + 0 (a/to-chan (range 10)))))) | |
325 | (is (= :foo (<!! (a/reduce #(if (= %2 2) (reduced :foo) %1) 0 (a/to-chan (range 10))))))) | |
326 | ) | |
327 | ||
328 | ;; transducer yielding n copies of each input value | |
329 | ;; (into [] (xerox 2) [1 2 3]) => [1 1 2 2 3 3] | |
330 | (defn xerox [n] | |
331 | (fn [f1] | |
332 | (fn | |
333 | ([] (f1)) | |
334 | ([result] (f1 result)) | |
335 | ([result input] | |
336 | (loop [res result | |
337 | i n] | |
338 | (if (pos? i) | |
339 | (let [a (f1 result input)] | |
340 | (if (reduced? a) | |
341 | a | |
342 | (recur a (dec i)))) | |
343 | res)))))) | |
344 | ||
345 | (defn check-expanding-transducer [buffer-size in multiplier takers] | |
346 | (let [input (range in) | |
347 | xf (xerox multiplier) | |
348 | expected (apply interleave (repeat multiplier input)) | |
349 | counter (atom 0) | |
350 | res (atom []) | |
351 | c (chan buffer-size xf)] | |
352 | (dotimes [x takers] | |
353 | (take! c #(do | |
354 | (when (some? %) (swap! res conj %)) | |
355 | (swap! counter inc)))) | |
356 | (onto-chan c input) | |
357 | ||
358 | ;; wait for all takers to report | |
359 | (while (< @counter takers) | |
360 | (Thread/sleep 50)) | |
361 | ||
362 | ;; check expected results | |
363 | (is (= (sort (clojure.core/take takers expected)) | |
364 | (sort @res))))) | |
365 | ||
366 | (deftest expanding-transducer-delivers-to-multiple-pending | |
367 | (doseq [b (range 1 10) | |
368 | t (range 1 10)] | |
369 | (check-expanding-transducer b 3 3 t))) | |
370 | ||
371 | ;; in 1.7+, use (map f) | |
372 | (defn mapping [f] | |
373 | (fn [f1] | |
374 | (fn | |
375 | ([] (f1)) | |
376 | ([result] (f1 result)) | |
377 | ([result input] | |
378 | (f1 result (f input))) | |
379 | ([result input & inputs] | |
380 | (f1 result (apply f input inputs)))))) | |
381 | ||
382 | (deftest test-transduce | |
383 | (is (= [1 2 3 4 5] | |
384 | (<!! (a/transduce (mapping inc) conj [] (a/to-chan (range 5)))))))⏎ |
0 | (ns clojure.core.pipeline-test | |
1 | (:require [clojure.test :refer (deftest is are)] | |
2 | [clojure.core.async :as a :refer [<! >! <!! >!! go go-loop thread chan close! to-chan | |
3 | pipeline pipeline-blocking pipeline-async]])) | |
4 | ||
5 | ;; in Clojure 1.7, use (map f) instead of this | |
6 | (defn mapping [f] | |
7 | (fn [f1] | |
8 | (fn | |
9 | ([] (f1)) | |
10 | ([result] (f1 result)) | |
11 | ([result input] | |
12 | (f1 result (f input))) | |
13 | ([result input & inputs] | |
14 | (f1 result (apply f input inputs)))))) | |
15 | ||
16 | (defn pipeline-tester [pipeline-fn n inputs xf] | |
17 | (let [cin (to-chan inputs) | |
18 | cout (chan 1)] | |
19 | (pipeline-fn n cout xf cin) | |
20 | (<!! (go-loop [acc []] | |
21 | (let [val (<! cout)] | |
22 | (if (not (nil? val)) | |
23 | (recur (conj acc val)) | |
24 | acc)))))) | |
25 | ||
26 | (def identity-mapping (mapping identity)) | |
27 | (defn identity-async [v ch] (thread (>!! ch v) (close! ch))) | |
28 | ||
29 | (deftest test-sizes | |
30 | (are [n size] | |
31 | (let [r (range size)] | |
32 | (and | |
33 | (= r (pipeline-tester pipeline n r identity-mapping)) | |
34 | (= r (pipeline-tester pipeline-blocking n r identity-mapping)) | |
35 | (= r (pipeline-tester pipeline-async n r identity-async)))) | |
36 | 1 0 | |
37 | 1 10 | |
38 | 10 10 | |
39 | 20 10 | |
40 | 5 1000)) | |
41 | ||
42 | (deftest test-close? | |
43 | (doseq [pf [pipeline pipeline-blocking]] | |
44 | (let [cout (chan 1)] | |
45 | (pf 5 cout identity-mapping (to-chan [1]) true) | |
46 | (is (= 1 (<!! cout))) | |
47 | (is (= nil (<!! cout)))) | |
48 | (let [cout (chan 1)] | |
49 | (pf 5 cout identity-mapping (to-chan [1]) false) | |
50 | (is (= 1 (<!! cout))) | |
51 | (>!! cout :more) | |
52 | (is (= :more (<!! cout)))) | |
53 | (let [cout (chan 1)] | |
54 | (pf 5 cout identity-mapping (to-chan [1]) nil) | |
55 | (is (= 1 (<!! cout))) | |
56 | (>!! cout :more) | |
57 | (is (= :more (<!! cout)))))) | |
58 | ||
59 | (deftest test-ex-handler | |
60 | (doseq [pf [pipeline pipeline-blocking]] | |
61 | (let [cout (chan 1) | |
62 | chex (chan 1) | |
63 | ex-mapping (mapping (fn [x] (if (= x 3) (throw (ex-info "err" {:data x})) x))) | |
64 | ex-handler (fn [e] (do (>!! chex e) :err))] | |
65 | (pf 5 cout ex-mapping (to-chan [1 2 3 4]) true ex-handler) | |
66 | (is (= 1 (<!! cout))) | |
67 | (is (= 2 (<!! cout))) | |
68 | (is (= :err (<!! cout))) | |
69 | (is (= 4 (<!! cout))) | |
70 | (is (= {:data 3} (ex-data (<!! chex))))))) | |
71 | ||
72 | (defn multiplier-async [v ch] | |
73 | (thread | |
74 | (dotimes [i v] | |
75 | (>!! ch i)) | |
76 | (close! ch))) | |
77 | ||
78 | (deftest test-af-multiplier | |
79 | (is (= [0 0 1 0 1 2 0 1 2 3] | |
80 | (pipeline-tester pipeline-async 2 (range 1 5) multiplier-async)))) | |
81 | ||
82 | (def sleep-mapping (mapping #(do (Thread/sleep %) %))) | |
83 | ||
84 | (deftest test-blocking | |
85 | (let [times [2000 50 1000 100]] | |
86 | (is (= times (pipeline-tester pipeline-blocking 2 times sleep-mapping))))) | |
87 | ||
88 | (defn slow-fib [n] | |
89 | (if (< n 2) n (+ (slow-fib (- n 1)) (slow-fib (- n 2))))) | |
90 | ||
91 | (deftest test-compute | |
92 | (let [input (take 50 (cycle (range 15 38)))] | |
93 | (is (= (slow-fib (last input)) | |
94 | (last (pipeline-tester pipeline 8 input (mapping slow-fib))))))) | |
95 | ||
96 | (deftest test-async | |
97 | (is (= (range 1 101) | |
98 | (pipeline-tester pipeline-async 1 (range 100) | |
99 | (fn [v ch] (future (>!! ch (inc v)) (close! ch))))))) |