├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── doc └── intro.md ├── project.clj ├── src └── dom_top │ └── core.clj └── test └── dom_top └── core_test.clj /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /classes 3 | /checkouts 4 | pom.xml 5 | pom.xml.asc 6 | *.jar 7 | *.class 8 | /.lein-* 9 | /.nrepl-port 10 | .hgignore 11 | .hg/ 12 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Change Log 2 | All notable changes to this project will be documented in this file. This change log follows the conventions of [keepachangelog.com](http://keepachangelog.com/). 3 | 4 | ## [Unreleased] 5 | ### Changed 6 | - Add a new arity to `make-widget-async` to provide a different widget shape. 7 | 8 | ## [0.1.1] - 2017-01-19 9 | ### Changed 10 | - Documentation on how to make the widgets. 11 | 12 | ### Removed 13 | - `make-widget-sync` - we're all async, all the time. 14 | 15 | ### Fixed 16 | - Fixed widget maker to keep working when daylight savings switches over. 17 | 18 | ## 0.1.0 - 2017-01-19 19 | ### Added 20 | - Files from the new template. 21 | - Widget maker public API - `make-widget-sync`. 22 | 23 | [Unreleased]: https://github.com/your-name/dom-top/compare/0.1.1...HEAD 24 | [0.1.1]: https://github.com/your-name/dom-top/compare/0.1.0...0.1.1 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC 2 | LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM 3 | CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 4 | 5 | 1. DEFINITIONS 6 | 7 | "Contribution" means: 8 | 9 | a) in the case of the initial Contributor, the initial code and 10 | documentation distributed under this Agreement, and 11 | 12 | b) in the case of each subsequent Contributor: 13 | 14 | i) changes to the Program, and 15 | 16 | ii) additions to the Program; 17 | 18 | where such changes and/or additions to the Program originate from and are 19 | distributed by that particular Contributor. A Contribution 'originates' from 20 | a Contributor if it was added to the Program by such Contributor itself or 21 | anyone acting on such Contributor's behalf. Contributions do not include 22 | additions to the Program which: (i) are separate modules of software 23 | distributed in conjunction with the Program under their own license 24 | agreement, and (ii) are not derivative works of the Program. 25 | 26 | "Contributor" means any person or entity that distributes the Program. 27 | 28 | "Licensed Patents" mean patent claims licensable by a Contributor which are 29 | necessarily infringed by the use or sale of its Contribution alone or when 30 | combined with the Program. 31 | 32 | "Program" means the Contributions distributed in accordance with this 33 | Agreement. 34 | 35 | "Recipient" means anyone who receives the Program under this Agreement, 36 | including all Contributors. 37 | 38 | 2. GRANT OF RIGHTS 39 | 40 | a) Subject to the terms of this Agreement, each Contributor hereby grants 41 | Recipient a non-exclusive, worldwide, royalty-free copyright license to 42 | reproduce, prepare derivative works of, publicly display, publicly perform, 43 | distribute and sublicense the Contribution of such Contributor, if any, and 44 | such derivative works, in source code and object code form. 45 | 46 | b) Subject to the terms of this Agreement, each Contributor hereby grants 47 | Recipient a non-exclusive, worldwide, royalty-free patent license under 48 | Licensed Patents to make, use, sell, offer to sell, import and otherwise 49 | transfer the Contribution of such Contributor, if any, in source code and 50 | object code form. This patent license shall apply to the combination of the 51 | Contribution and the Program if, at the time the Contribution is added by the 52 | Contributor, such addition of the Contribution causes such combination to be 53 | covered by the Licensed Patents. The patent license shall not apply to any 54 | other combinations which include the Contribution. No hardware per se is 55 | licensed hereunder. 56 | 57 | c) Recipient understands that although each Contributor grants the licenses 58 | to its Contributions set forth herein, no assurances are provided by any 59 | Contributor that the Program does not infringe the patent or other 60 | intellectual property rights of any other entity. Each Contributor disclaims 61 | any liability to Recipient for claims brought by any other entity based on 62 | infringement of intellectual property rights or otherwise. As a condition to 63 | exercising the rights and licenses granted hereunder, each Recipient hereby 64 | assumes sole responsibility to secure any other intellectual property rights 65 | needed, if any. For example, if a third party patent license is required to 66 | allow Recipient to distribute the Program, it is Recipient's responsibility 67 | to acquire that license before distributing the Program. 68 | 69 | d) Each Contributor represents that to its knowledge it has sufficient 70 | copyright rights in its Contribution, if any, to grant the copyright license 71 | set forth in this Agreement. 72 | 73 | 3. REQUIREMENTS 74 | 75 | A Contributor may choose to distribute the Program in object code form under 76 | its own license agreement, provided that: 77 | 78 | a) it complies with the terms and conditions of this Agreement; and 79 | 80 | b) its license agreement: 81 | 82 | i) effectively disclaims on behalf of all Contributors all warranties and 83 | conditions, express and implied, including warranties or conditions of title 84 | and non-infringement, and implied warranties or conditions of merchantability 85 | and fitness for a particular purpose; 86 | 87 | ii) effectively excludes on behalf of all Contributors all liability for 88 | damages, including direct, indirect, special, incidental and consequential 89 | damages, such as lost profits; 90 | 91 | iii) states that any provisions which differ from this Agreement are offered 92 | by that Contributor alone and not by any other party; and 93 | 94 | iv) states that source code for the Program is available from such 95 | Contributor, and informs licensees how to obtain it in a reasonable manner on 96 | or through a medium customarily used for software exchange. 97 | 98 | When the Program is made available in source code form: 99 | 100 | a) it must be made available under this Agreement; and 101 | 102 | b) a copy of this Agreement must be included with each copy of the Program. 103 | 104 | Contributors may not remove or alter any copyright notices contained within 105 | the Program. 106 | 107 | Each Contributor must identify itself as the originator of its Contribution, 108 | if any, in a manner that reasonably allows subsequent Recipients to identify 109 | the originator of the Contribution. 110 | 111 | 4. COMMERCIAL DISTRIBUTION 112 | 113 | Commercial distributors of software may accept certain responsibilities with 114 | respect to end users, business partners and the like. While this license is 115 | intended to facilitate the commercial use of the Program, the Contributor who 116 | includes the Program in a commercial product offering should do so in a 117 | manner which does not create potential liability for other Contributors. 118 | Therefore, if a Contributor includes the Program in a commercial product 119 | offering, such Contributor ("Commercial Contributor") hereby agrees to defend 120 | and indemnify every other Contributor ("Indemnified Contributor") against any 121 | losses, damages and costs (collectively "Losses") arising from claims, 122 | lawsuits and other legal actions brought by a third party against the 123 | Indemnified Contributor to the extent caused by the acts or omissions of such 124 | Commercial Contributor in connection with its distribution of the Program in 125 | a commercial product offering. The obligations in this section do not apply 126 | to any claims or Losses relating to any actual or alleged intellectual 127 | property infringement. In order to qualify, an Indemnified Contributor must: 128 | a) promptly notify the Commercial Contributor in writing of such claim, and 129 | b) allow the Commercial Contributor tocontrol, and cooperate with the 130 | Commercial Contributor in, the defense and any related settlement 131 | negotiations. The Indemnified Contributor may participate in any such claim 132 | at its own expense. 133 | 134 | For example, a Contributor might include the Program in a commercial product 135 | offering, Product X. That Contributor is then a Commercial Contributor. If 136 | that Commercial Contributor then makes performance claims, or offers 137 | warranties related to Product X, those performance claims and warranties are 138 | such Commercial Contributor's responsibility alone. Under this section, the 139 | Commercial Contributor would have to defend claims against the other 140 | Contributors related to those performance claims and warranties, and if a 141 | court requires any other Contributor to pay any damages as a result, the 142 | Commercial Contributor must pay those damages. 143 | 144 | 5. NO WARRANTY 145 | 146 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON 147 | AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER 148 | EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR 149 | CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A 150 | PARTICULAR PURPOSE. Each Recipient is solely responsible for determining the 151 | appropriateness of using and distributing the Program and assumes all risks 152 | associated with its exercise of rights under this Agreement , including but 153 | not limited to the risks and costs of program errors, compliance with 154 | applicable laws, damage to or loss of data, programs or equipment, and 155 | unavailability or interruption of operations. 156 | 157 | 6. DISCLAIMER OF LIABILITY 158 | 159 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY 160 | CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, 161 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION 162 | LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 163 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 164 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 165 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY 166 | OF SUCH DAMAGES. 167 | 168 | 7. GENERAL 169 | 170 | If any provision of this Agreement is invalid or unenforceable under 171 | applicable law, it shall not affect the validity or enforceability of the 172 | remainder of the terms of this Agreement, and without further action by the 173 | parties hereto, such provision shall be reformed to the minimum extent 174 | necessary to make such provision valid and enforceable. 175 | 176 | If Recipient institutes patent litigation against any entity (including a 177 | cross-claim or counterclaim in a lawsuit) alleging that the Program itself 178 | (excluding combinations of the Program with other software or hardware) 179 | infringes such Recipient's patent(s), then such Recipient's rights granted 180 | under Section 2(b) shall terminate as of the date such litigation is filed. 181 | 182 | All Recipient's rights under this Agreement shall terminate if it fails to 183 | comply with any of the material terms or conditions of this Agreement and 184 | does not cure such failure in a reasonable period of time after becoming 185 | aware of such noncompliance. If all Recipient's rights under this Agreement 186 | terminate, Recipient agrees to cease use and distribution of the Program as 187 | soon as reasonably practicable. However, Recipient's obligations under this 188 | Agreement and any licenses granted by Recipient relating to the Program shall 189 | continue and survive. 190 | 191 | Everyone is permitted to copy and distribute copies of this Agreement, but in 192 | order to avoid inconsistency the Agreement is copyrighted and may only be 193 | modified in the following manner. The Agreement Steward reserves the right to 194 | publish new versions (including revisions) of this Agreement from time to 195 | time. No one other than the Agreement Steward has the right to modify this 196 | Agreement. The Eclipse Foundation is the initial Agreement Steward. The 197 | Eclipse Foundation may assign the responsibility to serve as the Agreement 198 | Steward to a suitable separate entity. Each new version of the Agreement will 199 | be given a distinguishing version number. The Program (including 200 | Contributions) may always be distributed subject to the version of the 201 | Agreement under which it was received. In addition, after a new version of 202 | the Agreement is published, Contributor may elect to distribute the Program 203 | (including its Contributions) under the new version. Except as expressly 204 | stated in Sections 2(a) and 2(b) above, Recipient receives no rights or 205 | licenses to the intellectual property of any Contributor under this 206 | Agreement, whether expressly, by implication, estoppel or otherwise. All 207 | rights in the Program not expressly granted under this Agreement are 208 | reserved. 209 | 210 | This Agreement is governed by the laws of the State of New York and the 211 | intellectual property laws of the United States of America. No party to this 212 | Agreement will bring a legal action under this Agreement more than one year 213 | after the cause of action arose. Each party waives its rights to a jury trial 214 | in any resulting litigation. 215 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Dom Top 2 | 3 | Unorthodox control flow, for Clojurists with masochistic sensibilities. 4 | Available via [clojars](https://clojars.org/dom-top). 5 | 6 | ## Tour 7 | 8 | See [dom-top.core](src/dom_top/core.clj) for comprehensive documentation with 9 | examples. 10 | 11 | - `assert+` works like `assert`, but returns truthy values being tested, and 12 | throws other types of exceptions (including maps, via ex-info!) 13 | - `bounded-future` is just like `future`, but for CPU-bound tasks. 14 | - `bounded-pmap`, by contrast, puts a global limit on parallelism for CPU-bound 15 | tasks. 16 | - `disorderly` is a `do` block that evaluates statements in a new, random order 17 | every time, instead of sequentially. 18 | - `fcatch` lifts functions that throw exceptions into functions that *return* 19 | exceptions. 20 | - `letr` provides let bindings with early return; particular useful for 21 | aborting early on failure cases. 22 | - `loopr` expresses reductions with multiple accumulators over multiple 23 | dimensions. It combines the nested iteration of `for`, the multiple 24 | accumulators/dimensions of `loop`, and the concise iteration/accumulation 25 | structure of `reduce`. Also, it's fast. 26 | - `reducer` builds a reducing function for multiple accumulators, carrying 27 | state in a dynamically-compiled, primitive-aware, mutable accumulator 28 | datatype. For simple reductions it's about twice as fast as an idiomatic 29 | vector accumulator. 30 | - `real-pmap` provides a fully parallel version of `map`, which spawns one 31 | thread per element, instead of running on a limited threadpool. 32 | - `with-retry` provides `recur` that works through `try/catch` blocks; 33 | particularly useful for retrying network operations. 34 | 35 | ## Why would you WANT this? 36 | 37 | Look, this is a judgement-free zone, OK? We all have our reasons. 38 | 39 | ## Thanks 40 | 41 | [Justin Conklin](https://github.com/jgpc42) offered advice on ASM and wrote the 42 | core of dom-top's generator of mutable accumulators. 43 | 44 | ## License 45 | 46 | Copyright © 2017--2023 Kyle Kingsbury 47 | 48 | Distributed under the Eclipse Public License either version 1.0 or (at 49 | your option) any later version. 50 | -------------------------------------------------------------------------------- /doc/intro.md: -------------------------------------------------------------------------------- 1 | # Introduction to dom-top 2 | 3 | TODO: write [great documentation](http://jacobian.org/writing/what-to-write/) 4 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject dom-top "1.0.10-SNAPSHOT" 2 | :description "Unorthodox control flow for Clojurists with masochistic sensibilities" 3 | :url "http://github.com/aphyr/dom-top" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [[riddley "0.2.0"]] ; For code-walking 7 | :profiles {:dev {:dependencies [[org.clojure/clojure "1.12.0"] 8 | [org.clj-commons/primitive-math "1.0.1"] 9 | [criterium "0.4.6"]]}} 10 | :test-selectors {:perf :perf 11 | :focus :focus 12 | :default (fn [m] (not (or (:perf m))))}) 13 | -------------------------------------------------------------------------------- /src/dom_top/core.clj: -------------------------------------------------------------------------------- 1 | (ns dom-top.core 2 | "Unorthodox control flow." 3 | (:require [clojure [pprint :refer [pprint]] 4 | [string :as str] 5 | [walk :as walk]] 6 | [clojure.java.io :as io] 7 | [riddley.walk :refer [macroexpand-all walk-exprs]]) 8 | (:import (java.lang Iterable) 9 | (java.util Iterator) 10 | (java.io File 11 | FileOutputStream) 12 | ; oh no 13 | (clojure.asm ClassVisitor 14 | ClassWriter 15 | Opcodes 16 | Type) 17 | (clojure.lang DynamicClassLoader 18 | RT))) 19 | 20 | (defmacro assert+ 21 | "Like Clojure assert, but throws customizable exceptions (by default, 22 | IllegalArgumentException), and returns the value it checks, instead of nil. 23 | 24 | Clojure assertions are a little weird. Syntactically, they're a great 25 | candidate for runtime validation of state--making sure you got an int instead 26 | of a map, or that an object you looked up was present. However, they don't 27 | *return* the thing you pass them, which makes it a bit akward to use them in 28 | nested expressions. You typically have to do a let binding and then assert. 29 | So... let's return truthy values! Now you can 30 | 31 | (assert+ (fetch-person-from-db :liu) 32 | \"Couldn't fetch Liu!\") 33 | 34 | Moreover, Clojure assertions sensibly throw AssertionError. However, 35 | AssertionError is an error that \"should never occur\" and \"a reasonable 36 | application should not try to catch.\" There are LOTS of cases where you DO 37 | expect assertions to fail sometimes and intend to catch them: for instance, 38 | validating user input, or bounds checks. So we're going to throw 39 | customizable exceptions. 40 | 41 | Oh, and you can throw maps too. Those become ex-infos. 42 | 43 | (assert+ (thing? that) 44 | {:type :wasn't-a-thing 45 | :I'm [:so :sorry]})" 46 | ([x] 47 | `(assert+ ~x "Assert failed")) 48 | ([x message] 49 | `(assert+ ~x IllegalArgumentException ~message)) 50 | ([x ex-type message] 51 | `(or ~x (throw (let [m# ~message] 52 | (if (map? m#) 53 | (ex-info (str "Assert failed:\n" 54 | (with-out-str (pprint m#))) 55 | m#) 56 | (new ~ex-type ^String m#))))))) 57 | 58 | (defmacro disorderly 59 | "This is a chaotic do expression. Like `do`, takes any number of forms. Where 60 | `do` evaluates forms in order, `disorderly` evaluates them in a random order. 61 | Where `do` returns the result of evaluating the final form, `disorderly` 62 | returns a sequence of the results of each form, in lexical (as opposed to 63 | execution) order, making it suitable for binding results. 64 | 65 | This is particularly helpful when you want side effects, but you're not 66 | exactly sure how. Consider, for instance, testing that several mutations of 67 | an object all commute. 68 | 69 | (disorderly (do (prn 1) :a) 70 | (do (prn 2) :b)) 71 | 72 | ... prints either 1 then 2, or 2 then 1, but always returns (:a :b). Note 73 | that `disorderly` is *not* concurrent: branches evaluate in some order; it's 74 | just not a deterministic one." 75 | ([a] 76 | (list a)) 77 | ([a b] 78 | `(if (< (rand) 0.5) 79 | (let [a# ~a 80 | b# ~b] 81 | (list a# b#)) 82 | (let [b# ~b 83 | a# ~a] 84 | (list a# b#)))) 85 | ([a b & more] 86 | ; With six branches, it makes more sense to use fns and pay the invocation 87 | ; overhead, I think. We'll make a bunch of fns and update a mutable object 88 | ; array when each fn is called 89 | (let [results (gensym 'results) 90 | forms (->> (cons a (cons b more)) 91 | (map-indexed (fn [i form] 92 | `(fn [] (aset ~results ~i ~form)))) 93 | vec)] 94 | `(let [~results (object-array ~(count forms))] 95 | (doseq [f# (shuffle ~forms)] 96 | (f#)) 97 | (seq ~results))))) 98 | 99 | (defn fcatch 100 | "Takes a function and returns a version of it which returns, rather than 101 | throws, exceptions. 102 | 103 | ; returns RuntimeException 104 | ((fcatch #(throw (RuntimeException. \"hi\"))))" 105 | [f] 106 | (fn wrapper [& args] 107 | (try (apply f args) 108 | (catch Exception e e)))) 109 | 110 | (defn bounded-future-call 111 | "Like clojure.core/future-call, but runs on the bounded agent executor 112 | instead of the unbounded one. Useful for CPU-bound futures." 113 | [f] 114 | ; Adapted from clojure.core/future-call 115 | (let [f (#'clojure.core/binding-conveyor-fn f) 116 | fut (.submit clojure.lang.Agent/pooledExecutor ^Callable f)] 117 | (reify 118 | clojure.lang.IDeref 119 | (deref [_] (#'clojure.core/deref-future fut)) 120 | clojure.lang.IBlockingDeref 121 | (deref 122 | [_ timeout-ms timeout-val] 123 | (#'clojure.core/deref-future fut timeout-ms timeout-val)) 124 | clojure.lang.IPending 125 | (isRealized [_] (.isDone fut)) 126 | java.util.concurrent.Future 127 | (get [_] (.get fut)) 128 | (get [_ timeout unit] (.get fut timeout unit)) 129 | (isCancelled [_] (.isCancelled fut)) 130 | (isDone [_] (.isDone fut)) 131 | (cancel [_ interrupt?] (.cancel fut interrupt?))))) 132 | 133 | (defmacro bounded-future 134 | "Like future, but runs on the bounded agent executor. Useful for CPU-bound 135 | futures." 136 | [& body] 137 | `(bounded-future-call (^{:once true} fn* [] ~@body))) 138 | 139 | (defn bounded-pmap 140 | "Like pmap, but spawns tasks immediately, and uses the global bounded agent 141 | threadpool. Ideal for computationally bound tasks, especially when you might 142 | want to, say, pmap *inside* each of several parallel tasks without spawning 143 | eight gazillion threads." 144 | [f coll] 145 | (->> coll 146 | (map (fn launcher [x] (bounded-future (f x)))) 147 | doall 148 | (map deref))) 149 | 150 | (defn real-pmap-helper 151 | "Helper for real-pmap. Maps f over coll, collecting results and exceptions. 152 | Returns a tuple of [results, exceptions], where results is a sequence of 153 | results from calling `f` on each element (`nil` if f throws); and exceptions 154 | is a sequence of exceptions thrown by f, in roughly time order." 155 | [f coll] 156 | (let [exceptions (atom []) 157 | thread-group (ThreadGroup. "real-pmap") 158 | results (vec (take (count coll) (repeatedly promise))) 159 | threads (mapv (fn build-thread [i x result] 160 | (Thread. 161 | thread-group 162 | (bound-fn [] 163 | (try (deliver result (f x)) 164 | (catch Throwable t 165 | ; Note that we're not necessarily guaranteed 166 | ; to execute this code. If our call of (f x) 167 | ; throws, we could wind up here, and then 168 | ; another thread with a failure could 169 | ; interrupt us, causing us to jump out of 170 | ; this catch block. However, so long as 171 | ; nobody *outside* this thread group 172 | ; interrupts us, the first interrupt (or any 173 | ; throwable) we get from calling (f x) will 174 | ; be stored in `exception`. If someone 175 | ; outside this thread group interrupts us, 176 | ; chances are it was via interrupting the 177 | ; coordinator thread, and that has its own 178 | ; mechanism for cleaning up and throwing. 179 | (swap! exceptions conj t) 180 | (.interrupt thread-group)))) 181 | (str "real-pmap " i))) 182 | (range) 183 | coll 184 | results)] 185 | ; Launch threads 186 | (doseq [^Thread t threads] (.start t)) 187 | 188 | ; Wait for completion. Normally I'd await a barrier, but because of the way 189 | ; we interrupt threads, I don't think there's any point where we *could* 190 | ; update a barrier safely. What we *can* do reliably, though, is join the 191 | ; thread. That can throw InterruptedException, so we catch that, check that 192 | ; it's really dead, and if so, move on. If we get interrupted and the 193 | ; thread *isn't* dead, then it's probably that someone interrupted this 194 | ; real-pmap call, rather than the underlying thread, and 195 | ; we interrupt the thread group (just in case), and rethrow our own 196 | ; interrupt. 197 | (doseq [^Thread t threads] 198 | (try 199 | (.join t) 200 | (catch InterruptedException e 201 | (when (.isAlive t) 202 | ; We were interrupted by an outside force, not the thread we 203 | ; were joining. Clean up our thread group and rethrow. 204 | (.interrupt thread-group) 205 | (throw e))))) 206 | 207 | ; OK, all threads are now dead. Return! 208 | [(mapv (fn [result] 209 | (if (realized? result) 210 | @result 211 | (if (seq @exceptions) 212 | ; OK, we know what might have caused this. 213 | ::crashed 214 | ; Oh shoot, we actually have NO exceptions recorded, which 215 | ; might have happened if a thread caught an exception, then 216 | ; was interrupted before it could store that exception's cause 217 | ; in the exceptions atom. In that case, we'll throw an 218 | ; IllegalStateException here. 219 | (throw (IllegalStateException. "A real-pmap worker thread crashed *during* exception handling and was unable to record what that exception was."))))) 220 | results) 221 | @exceptions])) 222 | 223 | (defn real-pmap 224 | "Like pmap, but spawns tasks immediately, and launches real Threads instead 225 | of using a bounded threadpool. Useful when your tasks might block on each 226 | other, and you don't want to deadlock by exhausting the default clojure 227 | worker threadpool halfway through the collection. For instance, 228 | 229 | (let [n 1000 230 | b (CyclicBarrier. n)] 231 | (pmap (fn [i] [i (.await b)]) (range n))) 232 | 233 | ... deadlocks, but replacing `pmap` with `real-pmap` works fine. 234 | 235 | If any thread throws an exception, all mapping threads are interrupted, and 236 | the original exception is rethrown. This prevents deadlock issues where 237 | mapping threads synchronize on some resource (like a cyclicbarrier or 238 | countdownlatch), but one crashes, causing other threads to block indefinitely 239 | on the barrier. Note that we do not include a ConcurrentExecutionException 240 | wrapper. 241 | 242 | All pmap threads should terminate before real-pmap returns or throws. This 243 | prevents race conditions where mapping threads continue doing work 244 | concurrently with, say, clean-up code intended to run after the call to 245 | (pmap). 246 | 247 | If the thread calling (pmap) itself is interrupted, all bets are off." 248 | [f coll] 249 | (let [[results exceptions] (real-pmap-helper f coll)] 250 | (when (seq exceptions) 251 | ; We'll take the first one as our canonical exception. 252 | (throw (first exceptions))) 253 | results)) 254 | 255 | (defrecord Retry [bindings]) 256 | 257 | (defmacro with-retry 258 | "It's really fucking inconvenient not being able to recur from within (catch) 259 | expressions. This macro wraps its body in a (loop [bindings] (try ...)). 260 | Provides a (retry & new bindings) form which is usable within (catch) blocks: 261 | when this form is returned by the body, the body will be retried with the new 262 | bindings. For instance, 263 | 264 | (with-retry [attempts 5] 265 | (network-request...) 266 | (catch RequestFailed e 267 | (if (< 1 attempts) 268 | (retry (dec attempts)) 269 | (throw e))))" 270 | [initial-bindings & body] 271 | (assert (vector? initial-bindings)) 272 | (assert (even? (count initial-bindings))) 273 | (let [bindings-count (/ (count initial-bindings) 2) 274 | body (walk/prewalk (fn [form] 275 | (if (and (seq? form) 276 | (= 'retry (first form))) 277 | (do (assert (= bindings-count 278 | (count (rest form)))) 279 | `(Retry. [~@(rest form)])) 280 | form)) 281 | body) 282 | retval (gensym 'retval)] 283 | `(loop [~@initial-bindings] 284 | (let [~retval (try ~@body)] 285 | (if (instance? Retry ~retval) 286 | (recur ~@(map (fn [i] (let [retval (vary-meta retval 287 | assoc :tag `Retry)] 288 | `(nth (.bindings ~retval) ~i))) 289 | (range bindings-count))) 290 | ~retval))))) 291 | 292 | (deftype Return [value] 293 | Object 294 | (toString [this] 295 | (str "(Return. " (pr-str value) ")"))) 296 | 297 | (defmethod print-method Return 298 | [^Return ret ^java.io.Writer w] 299 | (.write w (.toString ret))) 300 | 301 | (defn letr-rewrite-return 302 | "Rewrites (return x) to (Return. x) in expr. Returns a pair of [changed? 303 | expr], where changed is whether the expression contained a return." 304 | [expr] 305 | (let [return? (atom false) 306 | expr (walk/prewalk 307 | (fn [form] 308 | (if (and (seq? form) 309 | (= 'return (first form))) 310 | (do (assert 311 | (= 2 (count form)) 312 | (str (pr-str form) " should have one argument")) 313 | (reset! return? true) 314 | `(Return. ~(second form))) 315 | form)) 316 | expr)] 317 | [@return? expr])) 318 | 319 | (defn letr-partition-bindings 320 | "Takes a vector of bindings [sym expr, sym' expr, ...]. Returns 321 | binding-groups: a sequence of vectors of bindgs, where the final binding in 322 | each group has an early return. The final group (possibly empty!) contains no 323 | early return." 324 | [bindings] 325 | (->> bindings 326 | (partition 2) 327 | (reduce (fn [groups [sym expr]] 328 | (let [[return? expr] (letr-rewrite-return expr) 329 | groups (assoc groups 330 | (dec (count groups)) 331 | (-> (peek groups) (conj sym) (conj expr)))] 332 | (if return? 333 | (do (assert (symbol? sym) 334 | (str (pr-str sym " must be a symbol"))) 335 | (conj groups [])) 336 | groups))) 337 | [[]]))) 338 | 339 | (defn letr-let-if 340 | "Takes a sequence of binding groups and a body expression, and emits a let 341 | for the first group, an if statement checking for a return, and recurses; 342 | ending with body." 343 | [groups body] 344 | (assert (pos? (count groups))) 345 | (if (= 1 (count groups)) 346 | ; Final group with no returns 347 | `(let ~(first groups) ~@body) 348 | 349 | ; Group ending in a return 350 | (let [bindings (first groups) 351 | final-sym (nth bindings (- (count bindings) 2))] 352 | `(let ~bindings 353 | (if (instance? Return ~final-sym) 354 | (.value ~final-sym) 355 | ~(letr-let-if (rest groups) body)))))) 356 | 357 | (defmacro letr 358 | "Let bindings, plus early return. 359 | 360 | You want to do some complicated, multi-stage operation assigning lots of 361 | variables--but at different points in the let binding, you need to perform 362 | some conditional check to make sure you can proceed to the next step. 363 | Ordinarily, you'd intersperse let and if statements, like so: 364 | 365 | (let [res (network-call)] 366 | (if-not (:ok? res) 367 | :failed-network-call 368 | 369 | (let [people (:people (:body res))] 370 | (if (zero? (count people)) 371 | :no-people 372 | 373 | (let [res2 (network-call-2 people)] 374 | ... 375 | 376 | This is a linear chain of operations, but we're forced to nest deeply because 377 | we have no early-return construct. In ruby, we might write 378 | 379 | res = network_call 380 | return :failed_network_call if not x.ok? 381 | 382 | people = res[:body][:people] 383 | return :no-people if people.empty? 384 | 385 | res2 = network_call_2 people 386 | ... 387 | 388 | which reads the same, but requires no nesting thanks to Ruby's early return. 389 | Clojure's single-return is *usually* a boon to understandability, but deep 390 | linear branching usually means something like 391 | 392 | - Deep nesting (readability issues) 393 | - Function chaining (lots of arguments for bound variables) 394 | - Throw/catch (awkward exception wrappers) 395 | - Monadic interpreter (slow, indirect) 396 | 397 | This macro lets you write: 398 | 399 | (letr [res (network-call) 400 | _ (when-not (:ok? res) (return :failed-network-call)) 401 | people (:people (:body res)) 402 | _ (when (zero? (count people)) (return :no-people)) 403 | res2 (network-call-2 people)] 404 | ...) 405 | 406 | letr works like let, but if (return x) is ever returned from a binding, letr 407 | returns x, and does not evaluate subsequent expressions. 408 | 409 | If something other than (return x) is returned from evaluating a binding, 410 | letr binds the corresponding variable as normal. Here, we use _ to indicate 411 | that we're not using the results of (when ...), but this is not mandatory. 412 | You cannot use a destructuring bind for a return expression. 413 | 414 | letr is not a *true* early return--(return x) must be a *terminal* expression 415 | for it to work--like (recur). For example, 416 | 417 | (letr [x (do (return 2) 1)] 418 | x) 419 | 420 | returns 1, not 2, because (return 2) was not the terminal expression. Someone 421 | clever should fix this. 422 | 423 | (return ...) only works within letr's bindings, not its body." 424 | [bindings & body] 425 | (assert (vector? bindings)) 426 | (assert (even? (count bindings))) 427 | (let [groups (letr-partition-bindings bindings)] 428 | (letr-let-if (letr-partition-bindings bindings) body))) 429 | 430 | (defn rewrite-tails* 431 | "Helper for rewrite-tails which doesn't macroexpand." 432 | [f form] 433 | (if-not (seq? form) 434 | (f form) 435 | (case (first form) 436 | (do let* letfn*) 437 | (list* (concat (butlast form) [(rewrite-tails* f (last form))])) 438 | 439 | if 440 | (let [[_ test t-branch f-branch] form] 441 | (list 'if test (rewrite-tails* f t-branch) (rewrite-tails* f f-branch))) 442 | 443 | case* 444 | (let [[a b c d default clauses & more] form] 445 | (list* a b c d (rewrite-tails* f default) 446 | (->> clauses 447 | (map (fn [[index [test expr]]] 448 | [index [test (rewrite-tails* f expr)]])) 449 | (into (sorted-map))) 450 | more)) 451 | 452 | (f form)))) 453 | 454 | (defn rewrite-tails 455 | "Takes a Clojure form and invokes f on each of its tail forms--the final 456 | expression in a do or let, both branches of an if, values of a case, etc." 457 | [f form] 458 | (rewrite-tails* f (macroexpand-all form))) 459 | 460 | (declare loopr-helper) 461 | 462 | (defn loopr-iterator 463 | "A single loopr layer specialized for traversal using a mutable iterator. 464 | Builds a form which returns a single accumulator, or a vector of 465 | accumulators, or a Return, after traversing each x in xs (and more element 466 | bindings within)." 467 | [accumulator-bindings [{:keys [lhs rhs] :as eb} & more-element-bindings] 468 | body {:keys [acc-count] :as opts}] 469 | (let [accs (map first (partition 2 accumulator-bindings)) 470 | bname (:name eb) 471 | iter (gensym (str bname "-iter-")) 472 | res (gensym (str bname "-res-")) 473 | rhs (vary-meta rhs assoc :tag `Iterable)] 474 | `(let [~iter ^Iterator (.iterator ~rhs)] 475 | ; Bind each accumulator to itself initially 476 | (loop [~@(mapcat (juxt identity identity) accs)] 477 | (if-not (.hasNext ~iter) 478 | ; We're done iterating 479 | ~(case (int acc-count) 480 | 0 nil 481 | 1 (first accs) 482 | `[~@accs]) 483 | (let [~lhs (.next ~iter)] 484 | ~(if more-element-bindings 485 | ; More iteration to do within. Descend, come back, recur. 486 | `(let [~res ~(loopr-helper accumulator-bindings 487 | more-element-bindings 488 | body opts)] 489 | (if (instance? Return ~res) 490 | ; Early return! 491 | ~res 492 | (recur ~@(case (int acc-count) 493 | 0 [] 494 | 1 [res] 495 | (map-indexed (fn [i acc] `(nth ~res ~i)) 496 | accs))))) 497 | ; This is the deepest level; use body directly. It'll contain a 498 | ; compatible recur form. We need to rewrite the body: 499 | ; (recur x y) -> (recur x y) 500 | ; x -> (Return. x) 501 | (rewrite-tails (fn rewrite-tail [form] 502 | (if (and (seq? form) (= 'recur (first form))) 503 | form 504 | `(Return. ~form))) 505 | body)))))))) 506 | 507 | (defn loopr-reduce 508 | "A single loopr layer specialized for traversal using `reduce`. Builds a form 509 | which returns a single accumulator, or a vector of accumulators, or a Return, 510 | after traversing each x in xs (and more element bindings within). Reduce is 511 | often faster over Clojure data structures than an iterator." 512 | [accumulator-bindings [{:keys [lhs rhs] :as eb} & more-element-bindings] 513 | body {:keys [acc-count] :as opts}] 514 | (let [accs (map first (partition 2 accumulator-bindings)) 515 | res (gensym (str (:name eb) "-res-")) 516 | acc (case (int acc-count) 517 | 0 '_ 518 | 1 (first accs) 519 | (vec accs)) 520 | ; The first accumulator we encode in the function arg 521 | first-acc (case (int acc-count) 522 | 0 '_ 523 | (first accs)) 524 | ; Remaining accumulators are stored in volatiles, which we bind to 525 | ; these expressions each round 526 | rest-accs (next accs) 527 | ; The names of each volatile 528 | rest-acc-volatiles (map-indexed (fn [i acc] 529 | (gensym 530 | (if (symbol? acc) 531 | (str acc "-vol-") 532 | (str i "-vol-")))) 533 | (next accs)) 534 | ; A let binding vector for the initial values of our volatiles 535 | rest-acc-init-binding (when rest-accs 536 | (mapcat (fn [volatile acc] 537 | [volatile `(volatile! ~acc)]) 538 | rest-acc-volatiles 539 | rest-accs)) 540 | ; Stores the result of the inner loop 541 | inner-res (gensym 'inner-res-) 542 | ; Stores the result of our reduce 543 | reduce-res (gensym 'res-)] 544 | `(let [~@rest-acc-init-binding 545 | ~reduce-res 546 | (reduce (fn ~(symbol (str "reduce-" (:name eb))) [~first-acc ~lhs] 547 | ; Fetch our current volatiles 548 | (let [~@(->> rest-acc-volatiles 549 | (map (partial list `deref)) 550 | (mapcat vector rest-accs))] 551 | ~(if more-element-bindings 552 | ; More iteration! 553 | `(let [~inner-res ~(loopr-helper accumulator-bindings 554 | more-element-bindings 555 | body opts)] 556 | ; Early return? 557 | (if (instance? Return ~inner-res) 558 | (reduced ~inner-res) 559 | ~(if (< acc-count 2) 560 | inner-res 561 | ; Update our volatiles and pull out the first acc 562 | `(do ~@(map-indexed 563 | (fn [i volatile] 564 | `(vreset! ~volatile 565 | (nth ~inner-res ~(inc i)))) 566 | rest-acc-volatiles) 567 | (first ~inner-res))))) 568 | ; This is the deepest level. Rewrite body to replace 569 | ; terminal expressions: 570 | ; (recur x) -> x 571 | ; (recur x y) -> [x y] 572 | ; x -> (reduced (Return. x)) 573 | (rewrite-tails 574 | (fn rewrite-tail [form] 575 | (if (and (seq? form) (= 'recur (first form))) 576 | ; Recur 577 | (case (int acc-count) 578 | 0 nil 579 | 1 (do (assert (= 1 (count (rest form)))) 580 | (first (rest form))) 581 | ; For multiple accumulators, we want to set the 582 | ; rest accs as a side effect, and return the 583 | ; first acc. 584 | (let [[recur_ first-acc-value & rest-acc-values] 585 | form] 586 | `(do ~@(map (fn [volatile value] 587 | `(vreset! ~volatile ~value)) 588 | rest-acc-volatiles 589 | rest-acc-values) 590 | ~first-acc-value))) 591 | ; Early return 592 | `(reduced (Return. ~form)))) 593 | body)))) 594 | ~(if (zero? acc-count) nil first-acc) 595 | ~rhs)] 596 | ~(case (int acc-count) 597 | ; For 0 or single accs, return the reduce value itself 598 | (0, 1) reduce-res 599 | ; With multiple accs, return a vector of their values. 600 | `(if (instance? Return ~reduce-res) 601 | ; Early return 602 | ~reduce-res 603 | ; Multiple return 604 | [~reduce-res 605 | ~@(map (partial list `deref) rest-acc-volatiles)]))))) 606 | 607 | 608 | (defn loopr-array 609 | "A single loopr layer specialized for traversal over arrays. Builds a form 610 | which returns a single accumulator, or a vector of accumulators, or a Return, 611 | after traversing each x in xs using `aget`." 612 | [accumulator-bindings [{:keys [lhs rhs] :as eb} & more-element-bindings] 613 | body {:keys [acc-count] :as opts}] 614 | (let [accs (map first (partition 2 accumulator-bindings)) 615 | bname (:name eb) 616 | i (gensym (str bname "-i-")) 617 | i-max (gensym (str bname "-i-max-")) 618 | res (gensym (str bname "-res-"))] 619 | `(let [~i-max (alength ~rhs)] 620 | (loop [; Our index into the array 621 | ~i (int 0) 622 | ; Initialize each accumulator to itself. 623 | ~@(mapcat (juxt identity identity) accs)] 624 | (if (= ~i ~i-max) 625 | ; Done 626 | ~(case (int acc-count) 627 | 0 nil 628 | 1 (first accs) 629 | `[~@accs]) 630 | ; Get an x 631 | (let [~lhs (aget ~rhs ~i)] 632 | ~(if more-element-bindings 633 | ; Descend into inner loop 634 | `(let [~res ~(loopr-helper accumulator-bindings 635 | more-element-bindings 636 | body opts)] 637 | (if (instance? Return ~res) 638 | ~res 639 | (recur (unchecked-inc-int ~i) 640 | ~@(case (int acc-count) 641 | 0 [] 642 | 1 [res] 643 | (map-indexed (fn [i acc] `(nth ~res ~i)) 644 | accs))))) 645 | ; This is the deepest level. Evaluate body, but with early 646 | ; return for non-recur tails. 647 | (rewrite-tails (fn rewrite-tail [form] 648 | (if (and (seq? form) (= 'recur (first form))) 649 | `(recur (unchecked-inc-int ~i) 650 | ~@(rest form)) 651 | `(Return. ~form))) 652 | body)))))))) 653 | 654 | (defn loopr-helper 655 | "Helper for building each stage of a nested loopr. Takes an accumulator 656 | binding vector, a vector of element bindings maps {:lhs, :rhs, :name}, a 657 | body expression, and an option map with 658 | 659 | :acc-count - The number of accumulators" 660 | [accumulator-bindings element-bindings body opts] 661 | (if (empty? element-bindings) 662 | ; Done! 663 | body 664 | ; Generate an iterator loop around the top-level element bindings. 665 | (let [strategy (case (:via (first element-bindings)) 666 | :array loopr-array 667 | :iterator loopr-iterator 668 | :reduce loopr-reduce 669 | ; With multiple accumulators, vector destructuring can 670 | ; make reduce more expensive. 671 | nil (if (< 2 (count accumulator-bindings)) 672 | loopr-iterator 673 | ; With single accumulators, Clojure's internal 674 | ; reduce is usually more efficient 675 | loopr-reduce))] 676 | (strategy accumulator-bindings element-bindings body opts)))) 677 | 678 | (defmacro loopr 679 | "Like `loop`, but for reducing over (possibly nested) collections. Compared to 680 | `loop`, makes iteration implicit. Compared to reduce, eliminates the need for 681 | nested reductions, fn wrappers, and destructuring multiple accumulators. 682 | Compared to `for`, loopr is eager, and lets you carry accumulators. 683 | 684 | Takes an initial binding vector for accumulator variables, (like `loop`); 685 | then a binding vector of loop variables to collections (like `for`); then a 686 | body form, then an optional final form. Iterates over each element of the 687 | collections, like `for` would, and evaluates body with that combination of 688 | elements bound. 689 | 690 | Like `loop`, the body should generally contain one or more (recur ...) forms 691 | with new values for each accumulator. Any non-recur form in tail position 692 | causes loopr to return that value immediately. 693 | 694 | When the loop completes normally, loopr returns: 695 | 696 | - The value of the final expression, which has access to the accumulators, or 697 | - If no `final` is given... 698 | - With zero accumulators, returns `nil` 699 | - With one accumulator, returns that accumulator 700 | - With multiple accumulators, returns a vector of each. 701 | 702 | For example, 703 | 704 | (loopr [sum 0] 705 | [x [1 2 3]] 706 | (recur (+ sum x))) 707 | 708 | returns 6: the sum of 1, 2 and 3. 709 | 710 | This would typically be written as `(reduce + [1 2 3])`, and for single 711 | accumulators or single loops using `reduce` or `loop` is often more concise. 712 | Loopred's power comes from its ability to carry multiple accumulators and to 713 | traverse multiple dimensions. For instance, to get the mean of all elements 714 | in a matrix: 715 | 716 | (loopr [count 0 717 | sum 0] 718 | [row [[1 2 3] [4 5 6] [7 8 9]] 719 | x row] 720 | (recur (inc count) (+ sum x)) 721 | (/ sum count)) 722 | ; returns 45/9 = 5 723 | 724 | Here, we have a body which recurs, and a final expression `(/ sum count)`, 725 | which is evaluated with the final value of the accumulators. Compare this to 726 | the equivalent nested reduce: 727 | 728 | (let [[sum count] (reduce (fn [[count sum] row] 729 | (reduce (fn [[count sum] x] 730 | [(inc count) (+ sum x)]) 731 | [count sum] 732 | row)) 733 | [0 0] 734 | [[1 2 3] [4 5 6] [7 8 9]])] 735 | (/ sum count)) 736 | 737 | This requires an enclosing `let` binding to transform the loop results, two 738 | calls to reduce, each with their own function, creating and destructuring 739 | vectors at each level, and keeping track of accumulator initial values far 740 | from their point of use. The structure of accumulators is encoded in five 741 | places instead of two, which makes it harder to change accumulators later. 742 | It also requires deeper indentation. Here's the same loop expressed as a 743 | flat `loop` over seqs: 744 | 745 | (loop [count 0 746 | sum 0 747 | rows [[1 2 3] [4 5 6] [7 8 9]] 748 | row (first rows)] 749 | (if-not (seq rows) 750 | (/ sum count) ; Done with iteration 751 | (if-not (seq row) ; Done with row; move on to next row 752 | (recur count sum (next rows) (first (next rows))) 753 | (let [[x & row'] row] 754 | (recur (inc count) (+ sum x) rows row'))))) 755 | 756 | This version is less indented but also considerably longer, and the 757 | interweaving of traversal machinery and accumulation logic makes it 758 | difficult to understand. It is also significantly slower than the nested 759 | `reduce`, on account of seq allocation--vectors can more efficiently reduce 760 | over their internal structure. 761 | 762 | Depending on how many accumulators are at play, and which data structures are 763 | being traversed, it may be faster to use `loop` with an iterator, `loop` with 764 | `aget`, or `reduce` with a function. loopr compiles to (possibly nested) 765 | `reduce` when given a single accumulator, and to (possibly nested) `loop` 766 | with mutable iterators when given multiple accumulators. You can also control 767 | the iteration tactic for each collection explicitly: 768 | 769 | (loopr [count 0 770 | sum 0] 771 | [row [[1 2 3] [4 5 6] [7 8 9]] :via :reduce 772 | x row :via :iterator] 773 | (recur (inc count) (+ sum x)) 774 | (/ sum count)) 775 | 776 | This compiles into a `reduce` over rows, and a `loop` over each row using an 777 | iterators. For array iteration, use `:via :array`: 778 | 779 | (loopr [sum 0] 780 | [x (long-array (range 10000)) :via :array] 781 | (recur (+ sum x))) 782 | ; => 49995000 783 | 784 | Note that alength/aget are *very* sensitive to type hints; use `lein check` 785 | to ensure that you're not using reflection, and add type hints as necessary. 786 | On my older xeon, this is roughly an order of magnitude faster than (reduce + 787 | longs). For nested array reduction, make sure to hint inner collections, like 788 | so: 789 | 790 | (loopr [sum 0] 791 | [row matrix :via :array 792 | x ^\"[Ljava.lang.Long;\" row :via :array] 793 | (recur (+ sum x))))) 794 | 795 | Like `loop`, `loopr` supports early return. Any non `(recur ...)` form in 796 | tail position in the body is returned immediately, without visiting any other 797 | elements in the collection(s). To search for the first odd number in 798 | collection, returning that number and its index: 799 | 800 | (loopr [i 0] 801 | [x [0 3 4 5]] 802 | (if (odd? x) 803 | {:i i, :x x} 804 | (recur (inc i)))) 805 | ; => {:i 1, :x 3} 806 | 807 | When no accumulators are provided, loopr still iterates, returning any 808 | early-returned value, or the final expression when iteration completes, or 809 | `nil` otherwise. Here we find an key in a map by value. Note that we can also 810 | destructure in iterator bindings. 811 | 812 | (loopr [] 813 | [[k v] {:x 1, :y 2}] 814 | (if (= v 2) 815 | k 816 | (recur)) 817 | :not-found) 818 | ; => :y" 819 | [accumulator-bindings element-bindings body & [final :as final-forms]] 820 | (assert (<= 2 (count element-bindings))) ; TODO: determine semantics for this? 821 | (assert (even? (count accumulator-bindings))) 822 | (assert (even? (count element-bindings))) 823 | (assert (<= (count final-forms) 1)) 824 | ; Parse element bindings into a vector of maps 825 | (let [element-bindings 826 | (loop [forms element-bindings 827 | bindings []] 828 | (if-not (seq forms) 829 | bindings 830 | (let [[f1 f2 & fs] forms 831 | i (count bindings)] 832 | (if (keyword? f1) 833 | ; Options for last binding 834 | (case f1 835 | :via (recur fs (update bindings (dec i) assoc :via f2)) 836 | (throw (IllegalArgumentException. 837 | (str "Unrecognized element binding option: " 838 | (pr-str f1) 839 | " - expected :via")))) 840 | ; New binding 841 | (let [; Choose a friendly name for this binding. 842 | binding-name (if (symbol? f1) 843 | f1 844 | (symbol (str "iter-" i))) 845 | binding {:name binding-name 846 | :lhs f1 847 | :rhs f2}] 848 | (recur fs (conj bindings binding))))))) 849 | acc-names (map first (partition 2 accumulator-bindings)) 850 | acc-count (count acc-names) 851 | acc (case acc-count 852 | 0 (gensym 'res-) 853 | 1 (first acc-names) 854 | (vec acc-names)) 855 | opts {:acc-count acc-count} 856 | res (gensym 'res-)] 857 | `(let [~@accumulator-bindings 858 | ~res ~(loopr-helper accumulator-bindings element-bindings body opts)] 859 | (if (instance? Return ~res) 860 | (.value ~(vary-meta res assoc :tag `Return)) 861 | ~(if (= 1 (count final-forms)) ; final could be present and nil 862 | `(let [~acc ~res] ~final) 863 | res))))) 864 | 865 | (defonce 866 | ^{:doc "The classloader we use to load mutable acc-types. We store this to 867 | prevent it from being GCed and rendering types unusable." 868 | :tag 'clojure.lang.DynamicClassLoader} 869 | mutable-acc-class-loader 870 | (RT/makeClassLoader)) 871 | 872 | (defonce 873 | ^{:doc "A mutable cache of mutable accumulator types we've generated. Stores 874 | a map of type hints (e.g. ['long 'Object]) to classes (e.g. 875 | MutableAcc-long-Object)."} 876 | mutable-acc-cache* 877 | (atom {})) 878 | 879 | (defn type->desc 880 | "Takes a type (e.g. 'int, 'objects, 'longs, 'Foo) and converts it to a JVM 881 | type descriptor like \"I\"." 882 | [t] 883 | (.getDescriptor 884 | (case t 885 | byte Type/BYTE_TYPE 886 | short Type/SHORT_TYPE 887 | int Type/INT_TYPE 888 | long Type/LONG_TYPE 889 | float Type/FLOAT_TYPE 890 | double Type/DOUBLE_TYPE 891 | bytes (Type/getType "[B") 892 | shorts (Type/getType "[S") 893 | ints (Type/getType "[I") 894 | longs (Type/getType "[J") 895 | floats (Type/getType "[F") 896 | doubles (Type/getType "[D") 897 | objects (Type/getType "[Ljava/lang/Object;") 898 | ; Everything else is an Object for us 899 | (Type/getType Object)))) 900 | 901 | (defn load-class! 902 | "Takes a class name as a string (e.g. foo.bar.Baz) and bytes for its class 903 | file. Loads the class dynamically, and also emits those bytes to 904 | *compile-path*, for AOT. Returns class." 905 | [^String class-name ^bytes class-bytes] 906 | (let [klass (.defineClass mutable-acc-class-loader class-name class-bytes nil) 907 | ; Spit out bytes to compile-path as well 908 | class-file (io/file *compile-path* 909 | (str (str/replace class-name "." File/separator) 910 | ".class"))] 911 | (io/make-parents class-file) 912 | (with-open [out (FileOutputStream. class-file)] 913 | (.write out class-bytes)) 914 | klass)) 915 | 916 | (defn mutable-acc-type 917 | "Takes a list of types as symbols and returns the class of a mutable 918 | accumulator which can store those types. May compile new classes on the fly, 919 | or re-use a cached class. 920 | 921 | This method largely courtesy of Justin Conklin! *hat tip*" 922 | [types] 923 | (let [; All objects are the same as far as we're concerned. 924 | types (mapv (fn [type] 925 | (if (and type (re-find #"^[a-z]" (name type))) 926 | type 927 | 'Object)) 928 | types)] 929 | (or (get @mutable-acc-cache* types) 930 | (let [class-name (str "dom_top.core.MutableAcc-" 931 | (str/join "-" (map name types))) 932 | base-type "java/lang/Object" 933 | ; Construct class bytecode 934 | cv (doto (ClassWriter. ClassWriter/COMPUTE_FRAMES) 935 | (.visit Opcodes/V1_7 936 | (bit-or Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL) 937 | (.replace class-name \. \/) 938 | nil base-type nil))] 939 | ; Constructor 940 | (doto (.visitMethod cv Opcodes/ACC_PUBLIC "" "()V" nil nil) 941 | (.visitCode) 942 | (.visitVarInsn Opcodes/ALOAD 0) 943 | ; Super 944 | (.visitMethodInsn Opcodes/INVOKESPECIAL base-type 945 | "" "()V" false) 946 | (.visitInsn Opcodes/RETURN) 947 | (.visitMaxs -1 -1) 948 | (.visitEnd)) 949 | ; Fields 950 | (doseq [[i t] (map vector (range) types)] 951 | (doto (.visitField cv Opcodes/ACC_PUBLIC (str "x" i) 952 | (type->desc t) nil nil) 953 | (.visitEnd))) 954 | ; And load 955 | (let [klass (load-class! class-name (.toByteArray cv))] 956 | ; Cache class for reuse 957 | (swap! mutable-acc-cache* assoc types klass) 958 | klass))))) 959 | 960 | (defmacro reducer 961 | "Syntactic sugar for writing reducing/transducing functions with multiple 962 | accumulators. Much like `loopr`, this takes a binding vector of loop 963 | variables and their initial values, a single binding vector for an element of 964 | the collection, a body which calls (recur) with new values of the 965 | accumulators (or doesn't recur, for early return), and a final expression, 966 | which is evaluated with the accumulators and returned at the end of the 967 | reduction. Returns a function with 0, 1, and 2-arity forms suitable for use 968 | with `transduce`. 969 | 970 | (transduce identity 971 | (reducer [sum 0, count 0] 972 | [x] 973 | (recur (+ sum x) (inc count)) 974 | (/ sum count)) 975 | [1 2 2]) 976 | ; => 5/3 977 | 978 | This is logically equivalent to: 979 | 980 | (transduce identity 981 | (fn ([] [0 0]) 982 | ([[sum count]] (/ sum count)) 983 | ([[sum count] x] 984 | [(+ sum x) (inc count)])) 985 | [1 2 2]) 986 | 987 | For zero and one-accumulator forms, these are equivalent. However, `reducer` 988 | is faster for reducers with more than one accumulator. Its identity arity 989 | creates unsynchronized mutable accumulators (including primitive types, if 990 | you hint your accumulator variables), and the reduction arity mutates that 991 | state in-place to skip the need for vector creation & destructuring on each 992 | reduction step. This makes it about twice as fast as a plain old reducer fn. 993 | 994 | These functions also work out-of-the-box with Tesser, clojure.core.reducers, 995 | and other Clojure fold libraries. 996 | 997 | If you want to use a final expression with a `reduced` form *and* multiple 998 | accumulators, add an `:as foo` to your accumulator binding vector. This 999 | symbol will be available in the final expression, bound to a vector of 1000 | accumulators if the reduction completes normally, or bound to whatever was 1001 | returned early. Using `:as foo` signals that you intend to use early return 1002 | and may not *have* accumulators any more--hence the accumulator bindings will 1003 | not be available in the final expression. 1004 | 1005 | (transduce identity 1006 | (reducer [sum 0, count 0 :as acc] 1007 | [x] 1008 | (if (= count 2) 1009 | [:early sum] 1010 | (recur (+ sum x) (inc count))) 1011 | [:final acc]) 1012 | [4 1 9 9 9]) 1013 | ; => [:early 5]" 1014 | [accumulator-bindings element-bindings body & [final :as final-forms]] 1015 | (assert (even? (count accumulator-bindings))) 1016 | (assert (= 1 (count element-bindings))) 1017 | (assert (<= (count final-forms) 1)) 1018 | (let [element-name (first element-bindings) 1019 | [acc-bindings [_ acc-as-name]] (split-with (complement #{:as}) 1020 | accumulator-bindings) 1021 | acc-pairs (partition 2 acc-bindings) 1022 | acc-names (mapv first acc-pairs) 1023 | acc-inits (mapv second acc-pairs) 1024 | acc-count (count acc-names)] 1025 | (if (< acc-count 2) 1026 | ; Construct a plain old reducer 1027 | (let [acc-name (or (first acc-names) '_)] 1028 | `(fn ~(symbol (str "reduce-" element-name)) 1029 | ([] ~(first acc-inits)) 1030 | ([~acc-name] ~(if final final acc-name)) 1031 | ([~acc-name ~element-name] 1032 | ~(rewrite-tails 1033 | (fn rewrite-tail [form] 1034 | (if (and (seq? form) (= 'recur (first form))) 1035 | ; We have a 0 or 1-arity recur form 1036 | (let [[_ acc-value] form] 1037 | (assert (= acc-count (count (rest form)))) 1038 | acc-value) 1039 | ; Early return 1040 | `(reduced ~form))) 1041 | body)))) 1042 | ; What kind of types does our accumulator need? 1043 | (let [types (mapv (comp :tag meta) acc-names) 1044 | acc-type (symbol (.getName ^Class (mutable-acc-type types))) 1045 | acc-name (with-meta (gensym "acc-") {:tag acc-type}) 1046 | fields (->> (range (count types)) 1047 | (map (comp symbol (partial str "x")))) 1048 | ; [(. acc x0) (. acc x1) ...] 1049 | get-fields (mapv (fn [type field] 1050 | (with-meta (list '. acc-name field) 1051 | {:tag type})) 1052 | types fields) 1053 | ; [foo (. acc x0) bar (. acc x1) ...] 1054 | ; When we bind we want to strip hints off locals; compiler will 1055 | ; complain 1056 | bind-fields (vec (interleave 1057 | (map #(vary-meta % dissoc :tag) acc-names) 1058 | get-fields)) 1059 | ; The argument passed to our final arity 1060 | final-name (gensym "final-")] 1061 | `(fn ~(symbol (str "reduce-" element-name)) 1062 | ; Construct accumulator and initialize its fields. 1063 | ([] (let [~acc-name (new ~acc-type) 1064 | ; Bindings like [foo init, _ (set! (. acc x0) foo), ...] 1065 | ~@(mapcat (fn [acc-name field init] 1066 | ; Can't type hint locals with primitive inits 1067 | (let [acc (vary-meta acc-name dissoc :tag)] 1068 | [acc init 1069 | '_ (list 'set! field acc)])) 1070 | acc-names get-fields acc-inits)] 1071 | ~acc-name)) 1072 | ; Finalizer; destructure and evaluate final, or just return accs as 1073 | ; vector 1074 | ~(if (= 1 (count final-forms)) ; final could be present and nil 1075 | (if acc-as-name 1076 | `([~final-name] 1077 | ; Bind input to acc-as-name, converting our mutable accs to a 1078 | ; vector. 1079 | (if (instance? ~acc-type ~final-name) 1080 | ; Normal return 1081 | (let [~acc-name ~final-name 1082 | ~acc-as-name ~get-fields] 1083 | ~final) 1084 | ; Early return 1085 | (let [~acc-as-name ~final-name] 1086 | ~final))) 1087 | ; No early return. Just bind accs. 1088 | `([~acc-name] 1089 | (let [~@bind-fields] 1090 | ~final))) 1091 | ; No final expression; return reduced or a vector 1092 | `([~final-name] 1093 | (if (instance? ~acc-type ~final-name) 1094 | ; Normal return 1095 | (let [~acc-name ~final-name] 1096 | ~get-fields) 1097 | ; Early return 1098 | ~final-name))) 1099 | ; Reduce: destructure acc and turn recur into mutations 1100 | ([~acc-name ~element-name] 1101 | (let ~bind-fields 1102 | ~(rewrite-tails 1103 | (fn rewrite-tail [form] 1104 | (if (and (seq? form) (= 'recur (first form))) 1105 | ; Recur becomes mutate and return acc 1106 | (do (assert (= acc-count (count (rest form)))) 1107 | `(do ~@(map (fn [get-field value] 1108 | `(set! ~get-field ~value)) 1109 | get-fields 1110 | (rest form)) 1111 | ~acc-name)) 1112 | ; Early return becomes a reduced value 1113 | `(reduced ~form))) 1114 | body)))))))) 1115 | -------------------------------------------------------------------------------- /test/dom_top/core_test.clj: -------------------------------------------------------------------------------- 1 | (ns dom-top.core-test 2 | (:require [clojure [pprint :refer [pprint]] 3 | [test :refer :all]] 4 | [clj-commons.primitive-math :as prim] 5 | [criterium.core :refer [bench quick-bench]] 6 | [dom-top.core :refer :all]) 7 | (:import (java.util.concurrent BrokenBarrierException 8 | CyclicBarrier))) 9 | 10 | (use-fixtures :once (fn [run-tests] 11 | (binding [*warn-on-reflection* true] 12 | (run-tests)))) 13 | 14 | (deftest assert+-test 15 | (testing "passthrough" 16 | (is (= :foo (assert+ :foo))) 17 | (is (= :foo (assert+ :foo "failed"))) 18 | (is (= :foo (assert+ :foo IllegalStateException "failed")))) 19 | 20 | (testing "Default error" 21 | (is (thrown-with-msg? IllegalArgumentException #"\AAssert failed\z" 22 | (assert+ false)))) 23 | 24 | (testing "Custom message" 25 | (is (thrown-with-msg? IllegalArgumentException #"\Ahi\z" 26 | (assert+ false "hi")))) 27 | 28 | (testing "Custom class" 29 | (is (thrown-with-msg? RuntimeException #"\AYOU!\?\z" 30 | (assert+ nil RuntimeException "YOU!?")))) 31 | 32 | (testing "Ex-info" 33 | (is (thrown-with-msg? clojure.lang.ExceptionInfo #"\AAssert failed:\n\{:type :frog-blast\}" 34 | (assert+ false {:type :frog-blast}))))) 35 | 36 | (deftest disorderly-test 37 | (testing "2 branches" 38 | (let [n 100 39 | outcomes (->> (fn [] 40 | (let [a (atom [])] 41 | [(disorderly 42 | (do (swap! a conj 0) :a) 43 | (do (swap! a conj 1) :b)) 44 | @a])) 45 | repeatedly 46 | (take n)) 47 | returns (frequencies (map first outcomes)) 48 | effects (frequencies (map second outcomes))] 49 | 50 | (testing "return vals in order" 51 | (is (= {[:a :b] n} returns))) 52 | 53 | (testing "evaluates both branches" 54 | (is (= #{[0 1] [1 0]} 55 | (set (keys effects))))) 56 | 57 | (testing "roughly as often" 58 | (->> (vals effects) 59 | (every? (fn [freq] (<= (Math/abs (double (- freq (/ n 2)))) 60 | (Math/sqrt n)))) 61 | is)))) 62 | 63 | (testing "3 branches" 64 | (let [n 100 65 | outcomes (->> (fn [] 66 | (let [a (atom [])] 67 | [(disorderly 68 | (do (swap! a conj 0) :a) 69 | (do (swap! a conj 1) :b) 70 | (do (swap! a conj 2) :c)) 71 | @a])) 72 | repeatedly 73 | (take n)) 74 | returns (frequencies (map first outcomes)) 75 | effects (frequencies (map second outcomes))] 76 | 77 | (testing "return vals in order" 78 | (is (= {[:a :b :c] n} returns))) 79 | 80 | (testing "evaluates all branches" 81 | (is (= #{[0 1 2] [0 2 1] [1 0 2] [1 2 0] [2 0 1] [2 1 0]} 82 | (set (keys effects))))) 83 | 84 | (testing "roughly as often" 85 | (->> (vals effects) 86 | (every? (fn [freq] 87 | (<= (Math/abs (double (- freq (/ n 6)))) 88 | (Math/sqrt n)))) 89 | is))))) 90 | 91 | 92 | (deftest fcatch-test 93 | (let [ex (RuntimeException. "foo")] 94 | (is (identical? ex ((fcatch #(throw ex))))))) 95 | 96 | (deftest real-pmap-helper-test 97 | (testing "catches exceptions" 98 | (let [res (real-pmap-helper (fn [x] 99 | (when (= x 0) 100 | (Thread/sleep 5) 101 | (throw (RuntimeException. "hi"))) 102 | 103 | (throw (BrokenBarrierException. "augh"))) 104 | (range 5))] 105 | (is (= (repeat 5 :dom-top.core/crashed) (first res))) 106 | (is (= {BrokenBarrierException 4 107 | InterruptedException 1} 108 | (frequencies (map class (second res)))))))) 109 | 110 | (deftest real-pmap-test 111 | (let [n 1000 112 | b (CyclicBarrier. n) 113 | results (real-pmap (fn [i] [i (.await b)]) (range n))] 114 | (testing "preserves input order" 115 | (is (= (range n) (map first results)))) 116 | 117 | (testing "counts down correctly" 118 | (is (= (range n) (sort (map second results)))))) 119 | 120 | (testing "enforces termination before return" 121 | (let [completed (atom [])] 122 | (try (real-pmap (fn [dt] 123 | (Thread/sleep dt) 124 | (swap! completed conj dt) 125 | (throw (IllegalStateException. "whoops"))) 126 | [50 0]) 127 | (catch IllegalStateException e 128 | (assert (= "whoops") (.getMessage (.getCause e))))) 129 | (is (= [0] @completed)) 130 | ; Other thread should have died. 131 | (Thread/sleep 100) 132 | (is (= [0] @completed)))) 133 | 134 | (testing "doesn't deadlock" 135 | (let [n 6 136 | b (CyclicBarrier. n)] 137 | (is (thrown-with-msg? RuntimeException #"Agh!" 138 | (real-pmap (fn [i] 139 | (when (= i (dec n)) 140 | (throw (RuntimeException. "Agh!"))) 141 | (.await b)) 142 | (range n))))))) 143 | 144 | (deftest bounded-pmap-test 145 | (let [n 1000 146 | threads (atom #{}) 147 | results (bounded-pmap (fn [i] 148 | (swap! threads conj (Thread/currentThread)) 149 | (- i)) 150 | (range n))] 151 | (testing "Performs transformation preserving order" 152 | (is (= results (map - (range n))))) 153 | 154 | (testing "Bounded concurrency" 155 | (is (<= (count @threads) 156 | (+ 2 (.. Runtime getRuntime availableProcessors))))))) 157 | 158 | (deftest with-retry-test 159 | (testing "no bindings" 160 | (is (= 1 (with-retry [] 161 | (/ 1 (rand-int 2)) 162 | (catch ArithmeticException e 163 | (retry)))))) 164 | 165 | (testing "countdown" 166 | (let [tries (atom [])] 167 | (is (= :exhausted (with-retry [attempts 5] 168 | (swap! tries conj attempts) 169 | (/ 1 0) 170 | (catch ArithmeticException e 171 | (if (< 1 attempts) 172 | (retry (dec attempts)) 173 | :exhausted))))) 174 | (is (= [5 4 3 2 1] @tries))))) 175 | 176 | (deftest letr-test 177 | (testing "no bindings" 178 | (is (= (letr []) nil)) 179 | (is (= (letr [] 1 2) 2))) 180 | 181 | (testing "standard bindings" 182 | (is (= (letr [a 1, b a] 2 a) 1))) 183 | 184 | (testing "early return" 185 | (let [side-effect (atom false)] 186 | (is (= (letr [a 1 187 | x (if (pos? a) (return :pos) :neg) 188 | foo (reset! side-effect true)] 189 | x) 190 | :pos)) 191 | (is (not @side-effect)))) 192 | 193 | (testing "using non-return branch" 194 | (let [side-effect (atom false)] 195 | (is (= (letr [a -1 196 | x (if (pos? a) (return :pos) :neg) 197 | foo (reset! side-effect true)] 198 | x) 199 | :neg)) 200 | (is @side-effect))) 201 | 202 | (testing "multiple return" 203 | (is (= (letr [a 2 204 | _ (when (= a 1) (return :1)) 205 | _ (when (= a 2) (return :2)) 206 | _ (when (= a 3) (return :3))] 207 | 4) 208 | :2)))) 209 | 210 | (deftest loopr-test 211 | (testing "simple accumulator" 212 | (is (= 4 (loopr [count 0] [x [1 2 3 4]] (recur (inc count))))) 213 | ) 214 | 215 | (testing "actually iterates" 216 | (is (= [1 2 3 4] 217 | (loopr [out []] [x [1 2 3 4]] (recur (conj out x)))))) 218 | 219 | (testing "nested" 220 | (is (= [[:kyle :freddie] 221 | [:felicity :qubit] 222 | [:felicity :spark]] 223 | ;(pprint (macroexpand (macroexpand 224 | (loopr [owner-pets []] 225 | [person [{:name :kyle, :pets [:freddie]} 226 | {:name :felicity, :pets [:qubit, :spark]}] 227 | pet (:pets person)] 228 | (recur (conj owner-pets [(:name person) pet])))))) 229 | 230 | (testing "multiple accumulators" 231 | (is (= [5 15] 232 | (loopr [count 0 233 | sum 0] 234 | [x [1 2 3 4 5]] 235 | (recur (inc count) (+ sum x)))))) 236 | 237 | (let [matrix [[1 2 3] [4 5 6] [7 8 9]]] 238 | (testing "via" 239 | (is (= [9 45] 240 | (loopr [count 0, sum 0] 241 | [row matrix, x row] 242 | (recur (inc count) (+ sum x))) 243 | (loopr [count 0, sum 0] 244 | [row matrix :via :iterator 245 | x row :via :iterator] 246 | (recur (inc count) (+ sum x))) 247 | (loopr [count 0, sum 0] 248 | [row matrix :via :reduce 249 | x row :via :iterator] 250 | (recur (inc count) (+ sum x))) 251 | (loopr [count 0, sum 0] 252 | [row matrix :via :iterator 253 | x row :via :reduce] 254 | (recur (inc count) (+ sum x))) 255 | (loopr [count 0, sum 0] 256 | [row matrix :via :reduce 257 | x row :via :reduce] 258 | (recur (inc count) (+ sum x))) 259 | ))) 260 | 261 | (testing "final" 262 | (is (= {:count 9, :sum 45, :mean 5} 263 | (loopr [count 0, sum 0] 264 | [row matrix, x row] 265 | (recur (inc count) (+ sum x)) 266 | {:count count, :sum sum, :mean (/ sum count)})))) 267 | 268 | (testing "arrays" 269 | (is (= 6 (loopr [sum 0] 270 | [x (int-array [1 2 3]) :via :array] 271 | (recur (+ sum x))))) 272 | (let [matrix (to-array-2d [[1 2 3] [4 5 6] [7 8 9]])] 273 | (is (= [9 45] 274 | (loopr [count 0, sum 0] 275 | [row matrix :via :array, x row :via :array] 276 | (recur (inc count) (+ sum x))) 277 | (loopr [count 0, sum 0] 278 | [row matrix :via :array, x row :via :reduce] 279 | (recur (inc count) (+ sum x))) 280 | (loopr [count 0, sum 0] 281 | [row matrix :via :reduce, x row :via :array] 282 | (recur (inc count) (+ sum x))))))) 283 | 284 | (testing "nestable" 285 | (is (= [9 45] 286 | (loopr [count 0, sum 0] 287 | [row matrix :via :iterator] 288 | (let [[sum count] (loopr [sum sum, count count] 289 | [x row :via :iterator] 290 | (recur (+ sum x) (inc count)))] 291 | (recur count sum))) 292 | (loopr [count 0, sum 0] 293 | [row matrix :via :reduce] 294 | (let [[sum count] (loopr [sum sum, count count] 295 | [x row :via :reduce] 296 | (recur (+ sum x) (inc count)))] 297 | (recur count sum)))))) 298 | 299 | (testing "allows nested recurs within body" 300 | ; The reduce tactic rewrites recurs forms, and we need to make sure it 301 | ; doesn't interfere with inner recurs. 302 | (is (= 10 (loopr [sum 0] [x [1 2 3] :via :reduce] 303 | (letfn [(powersum [x acc] ; fn with recur 304 | (if (zero? x) 305 | acc 306 | (recur (dec x) (+ x acc))))] 307 | (recur (+ (loop [i 3] ; trivial loop; returns sum 308 | (if (= i 0) 309 | sum 310 | (recur (dec i)))) 311 | (powersum x 0))))))) 312 | (is (= 10 (loopr [sum 0] [x [1 2 3] :via :iterator] 313 | (letfn [(powersum [x acc] ; fn with recur 314 | (if (zero? x) 315 | acc 316 | (recur (dec x) (+ x acc))))] 317 | (recur (+ (loop [i 3] ; trivial loop; returns sum 318 | (if (= i 0) 319 | sum 320 | (recur (dec i)))) 321 | (powersum x 0))))))))) 322 | 323 | (testing "early return" 324 | ; Find a value and its index 325 | (is (= {:x 3, :i 1} 326 | (loopr [i 0] 327 | [x [1 3 2] :via :reduce] 328 | (if (= x 3) 329 | {:x x, :i i} 330 | (recur (inc i)))) 331 | (loopr [i 0] 332 | [x [1 3 2] :via :iterator] 333 | (if (= x 3) 334 | {:x x, :i i} 335 | (recur (inc i)))))) 336 | (testing "nested" 337 | (let [pairs [[1 2] [3 4] [5 6]]] 338 | (is (= {:x 3, :i 2} 339 | (loopr [i 0] 340 | [pair pairs :via :reduce 341 | x pair :via :reduce] 342 | (if (= x 3) 343 | {:x x, :i i} 344 | (recur (inc i)))) 345 | (loopr [i 0] 346 | [pair pairs :via :reduce 347 | x pair :via :iterator] 348 | (if (= x 3) 349 | {:x x, :i i} 350 | (recur (inc i)))) 351 | (loopr [i 0] 352 | [pair pairs :via :iterator 353 | x pair :via :reduce] 354 | (if (= x 3) 355 | {:x x, :i i} 356 | (recur (inc i)))) 357 | (loopr [i 0] 358 | [pair pairs :via :iterator 359 | x pair :via :iterator] 360 | (if (= x 3) 361 | {:x x, :i i} 362 | (recur (inc i)))))))) 363 | 364 | (testing "with nil final expression" 365 | ; This is a search for "the element after 2" on a list where 2 is the 366 | ; final element. 367 | (is (= nil (loopr [preceding nil] 368 | [x [1 2]] 369 | (if (= preceding 2) 370 | x 371 | (recur x)) 372 | nil))))) 373 | 374 | (testing "no accumulator" 375 | (testing "reduce" 376 | (let [acc (atom []) 377 | xs [1 2 3]] 378 | (is (= nil 379 | (loopr [] 380 | [x xs :via :reduce] 381 | (do (swap! acc conj x) 382 | (recur))))) 383 | (is (= [1 2 3] @acc)))) 384 | 385 | (testing "iterator" 386 | (let [acc (atom []) 387 | xs [1 2 3]] 388 | (is (= nil 389 | (loopr [] 390 | [x xs :via :iterator] 391 | (do (swap! acc conj x) 392 | (recur))))) 393 | (is (= [1 2 3] @acc)))) 394 | 395 | (testing "final" 396 | (is (= :finished (loopr [] [x [1 2 3]] (recur) :finished)))) 397 | 398 | (testing "early return" 399 | (is (= 2 400 | (loopr [] 401 | [x [1 2 3] :via :reduce] 402 | (if (even? x) 403 | x 404 | (recur)) 405 | :not-found) 406 | (loopr [] 407 | [x [1 2 3] :via :iterator] 408 | (if (even? x) 409 | x 410 | (recur)) 411 | :not-found)))) 412 | 413 | (testing "nested" 414 | (let [matrix [[1 2 3] [4 5 6] [7 8 9]]] 415 | (is (= [:found 5] 416 | (loopr [] 417 | [row matrix :via :reduce 418 | x row :via :reduce] 419 | (if (= x 5) 420 | [:found 5] 421 | (recur))) 422 | (loopr [] 423 | [row matrix :via :iterator 424 | x row :via :reduce] 425 | (if (= x 5) 426 | [:found 5] 427 | (recur))) 428 | (loopr [] 429 | [row matrix :via :reduce 430 | x row :via :iterator] 431 | (if (= x 5) 432 | [:found 5] 433 | (recur))) 434 | (loopr [] 435 | [row matrix :via :iterator 436 | x row :via :iterator] 437 | (if (= x 5) 438 | [:found 5] 439 | (recur)))))))) 440 | 441 | (testing "reduce with multiple destructuring accs and destructuring" 442 | (is (= {:count 4, :sum 10, :min 1, :max 4} 443 | (loopr [[count sum] [0 0] 444 | [min- max-] [##Inf ##-Inf]] 445 | [x [1 2 3 4]] 446 | (recur [(inc count) (+ sum x)] 447 | [(min min- x) (max max- x)]) 448 | {:sum sum :count count :min min- :max max-}))))) 449 | 450 | (deftest rewrite-tails-test 451 | (is (= 2 (rewrite-tails inc '1))) 452 | (is (= '(do 1 2) 453 | (rewrite-tails inc '(do 1 1)))) 454 | (is (= '(do (do 1 2)) 455 | (rewrite-tails inc '(do (do 1 1))))) 456 | 457 | (let [inc* #(if (number? %) (inc %) %)] 458 | (is (= '(loop* [x 0] (recur 1)) 459 | (rewrite-tails inc* '(loop [x 0] (recur 1))))) 460 | (is (= '(if 3 2 nil) 461 | (rewrite-tails inc* '(if 3 1)))) 462 | (is (= '(if 3 (do 1 1 2) nil) 463 | (rewrite-tails inc* '(when 3 1 1 1)))) 464 | (is (= '(if (even? x) (do 1 2) (do 1 3)) 465 | (rewrite-tails inc* '(if (even? x) (do 1 1) (do 1 2))))) 466 | ; Hard to check this because the case* expands into a weird gensym thing. 467 | (let [form (rewrite-tails inc* '(case x :one 1, :two 2, 3))] 468 | (is (= 2 (eval `(let [~'x :one] ~form)))) 469 | (is (= 3 (eval `(let [~'x :two] ~form)))) 470 | (is (= 4 (eval `(let [~'x :default] ~form))))))) 471 | 472 | (deftest ^:perf loopr-perf-test 473 | (let [bigvec (->> (range 10000) vec) 474 | bigarray (->> (range 10000) long-array) 475 | bigseq (->> (range 10000) (map identity))] 476 | (testing "single accumulators" 477 | (println "\nSingle-acc loop with seq over vector") 478 | (quick-bench 479 | (loop [sum 0 480 | xs bigvec] 481 | (if-not (seq xs) 482 | sum 483 | (let [[x & xs] xs] 484 | (recur (+ sum x) xs))))) 485 | 486 | (println "\nSingle-acc reduce over vector") 487 | (quick-bench 488 | (reduce + bigvec)) 489 | 490 | (println "\nSingle-acc loopr over vector") 491 | (quick-bench 492 | (loopr [sum 0] [x bigvec] (recur (+ sum x))))) 493 | 494 | (testing "multiple accumulators" 495 | (println "\nMulti-acc loop with seq over vector") 496 | (quick-bench 497 | (loop [sum 0 498 | count 0 499 | xs bigvec] 500 | (if-not (seq xs) 501 | [sum count] 502 | (let [[x & xs] xs] 503 | (recur (+ sum x) (inc count) xs))))) 504 | 505 | (println "\nMulti-acc reduce over vector") 506 | (quick-bench 507 | (reduce (fn [[sum count] x] 508 | [(+ sum x) (inc count)]) 509 | [0 0] 510 | bigvec)) 511 | 512 | (println "\nMulti-acc loopr (reduce) over vector") 513 | (quick-bench 514 | (loopr [sum 0, count 0] 515 | [x bigvec :via :reduce] 516 | (recur (+ sum x) (inc count)))) 517 | 518 | (println "\nMulti-acc loopr (iterator) over vector") 519 | (quick-bench 520 | (loopr [sum 0, count 0] 521 | [x bigvec :via :iterator] 522 | (recur (+ sum x) (inc count)))))) 523 | 524 | (testing "nested structures" 525 | (let [people (->> (range 10000) 526 | (map (fn [i] 527 | {:name i 528 | :pets (->> (range (rand-int 10)) 529 | (map (fn [j] 530 | {:name j})))})) 531 | doall)] 532 | (println "\nSingle-acc loop with seq over nested seq") 533 | (quick-bench 534 | (loop [pet-count 0 535 | people people] 536 | (if-not (seq people) 537 | pet-count 538 | (let [[person & people] people] 539 | (recur (loop [pet-count pet-count 540 | pets (:pets person)] 541 | (if-not (seq pets) 542 | pet-count 543 | (recur (inc pet-count) (next pets)))) 544 | people))))) 545 | 546 | (println "\nSingle-acc reduce over nested seq") 547 | (quick-bench 548 | (reduce (fn [pet-count person] 549 | (reduce (fn [pet-count pet] 550 | (inc pet-count)) 551 | pet-count 552 | (:pets person))) 553 | 0 554 | people)) 555 | 556 | (println "\nSingle-acc loopr over nested seq") 557 | (quick-bench 558 | (loopr [pet-count 0] 559 | [person people 560 | pet (:pets person)] 561 | (recur (inc pet-count)))) 562 | 563 | (println "\nMulti-acc loop with seq over nested seq") 564 | (quick-bench 565 | (loop [pet-count 0 566 | pet-names #{} 567 | people people] 568 | (if-not (seq people) 569 | [pet-count pet-names] 570 | (let [[person & people] people 571 | [pet-count pet-names] 572 | (loop [pet-count pet-count 573 | pet-names pet-names 574 | pets (:pets person)] 575 | (if-not (seq pets) 576 | [pet-count pet-names] 577 | (let [pet (first pets)] 578 | (recur (inc pet-count) 579 | (conj pet-names (:name pet)) 580 | (next pets)))))] 581 | (recur pet-count pet-names 582 | people))))) 583 | 584 | (println "\nMulti-acc reduce over nested seq") 585 | (quick-bench 586 | (reduce (fn [acc person] 587 | (reduce (fn [[pet-count pet-names] pet] 588 | [(inc pet-count) 589 | (conj pet-names (:name pet))]) 590 | acc 591 | (:pets person))) 592 | [0 #{}] 593 | people)) 594 | 595 | (println "\nMulti-acc for->reduce over nested seq") 596 | (quick-bench 597 | (->> (for [person people 598 | pet (:pets person)] 599 | (:name pet)) 600 | (reduce (fn [[pet-count pet-names] pet-name] 601 | [(inc pet-count) 602 | (conj pet-names pet-name)]) 603 | [0 #{}]))) 604 | 605 | (println "\nMulti-acc loopr over nested seq") 606 | (quick-bench 607 | (loopr [pet-count 0 608 | pet-names #{}] 609 | [person people 610 | pet (:pets person)] 611 | (recur (inc pet-count) 612 | (conj pet-names (:name pet))))) 613 | )) 614 | 615 | (testing "arrays" 616 | (let [ary (long-array (range 10000))] 617 | (println "\nSingle-acc reduce over array") 618 | (quick-bench 619 | (reduce + ary)) 620 | 621 | (println "\nSingle-acc loopr over array") 622 | (quick-bench 623 | (loopr [sum 0] 624 | [x ary :via :array] 625 | (recur (+ sum x))))) 626 | 627 | (let [matrix (to-array-2d (repeat 1000 (range 1000)))] 628 | (println "\nSingle-acc reduce over 2d array") 629 | (quick-bench 630 | (reduce (partial reduce +) 0 matrix)) 631 | 632 | (println "\nSingle-acc loopr over 2d array") 633 | (quick-bench 634 | (loopr [sum 0] 635 | [row matrix :via :array 636 | x ^"[Ljava.lang.Long;" row :via :array] 637 | (recur (+ sum x))))) 638 | )) 639 | 640 | 641 | (deftest reducer-test 642 | (testing "no acc" 643 | (is (= :done (transduce identity 644 | (reducer [] 645 | [x] 646 | (recur) 647 | :done) 648 | [1 2 3]))) 649 | 650 | (testing "early return" 651 | (is (= 2 (transduce identity 652 | (reducer [] 653 | [x] 654 | (if (< 1 x) 655 | x 656 | (recur))) 657 | [1 2 3]))))) 658 | 659 | (testing "single acc" 660 | (is (= [:sum 10] (transduce identity 661 | (reducer [sum 0] 662 | [x] 663 | (recur (+ sum x)) 664 | [:sum sum]) 665 | [1 2 3 4]))) 666 | 667 | (testing "early return" 668 | (is (= [:sum 6] (transduce identity 669 | (reducer [sum 0] 670 | [x] 671 | (if (< 3 x) 672 | sum 673 | (recur (+ sum x))) 674 | [:sum sum]) 675 | (range)))))) 676 | 677 | (testing "two accs" 678 | (is (= 5/3 (transduce identity 679 | (reducer [sum 0 680 | count 0] 681 | [x] 682 | (recur (+ sum x) (inc count)) 683 | (/ sum count)) 684 | [1 2 2]))) 685 | 686 | (testing "type hints" 687 | (is (= 5/3 (transduce identity 688 | (reducer [^long sum 0 689 | ^int count 0] 690 | [x] 691 | (recur (+ sum x) (inc count)) 692 | (/ sum count)) 693 | [1 2 2])))) 694 | 695 | (testing "referring to earlier accs in init bindings" 696 | (is (= [:b :a] (transduce identity 697 | (reducer [a :a 698 | b [:b a]] 699 | [x] 700 | b) 701 | [1 2 3])))) 702 | 703 | (testing "destructuring" 704 | (is (= {:cats 5/2 705 | :dogs 11/2} 706 | (transduce identity 707 | (reducer [[cat-sum cat-count :as cat-acc] [0 0] 708 | [dog-sum dog-count :as dog-acc] [0 0]] 709 | [{:keys [cuteness type]}] 710 | (case type 711 | :cat (recur [(+ cuteness cat-sum) 712 | (inc cat-count)] 713 | dog-acc) 714 | :dog (recur cat-acc 715 | [(+ cuteness dog-sum) 716 | (inc dog-count)])) 717 | {:cats (/ cat-sum cat-count) 718 | :dogs (/ dog-sum dog-count)}) 719 | [{:type :cat, :cuteness 2} 720 | {:type :cat, :cuteness 3} 721 | {:type :dog, :cuteness 4} 722 | {:type :dog, :cuteness 7}])))) 723 | 724 | (testing "early return" 725 | ; Note that transduce passes reduced values to the final (f acc) arity 726 | (is (= [:final [:early 5]] 727 | (transduce identity 728 | (reducer [sum 0, count 0 :as acc] 729 | [x] 730 | (if (= count 2) 731 | [:early sum] 732 | (recur (+ sum x) (inc count))) 733 | [:final acc]) 734 | [4 1 9 9 9])))) 735 | 736 | (testing "early return, no final" 737 | (is (= [:early 5] 738 | (transduce identity 739 | (reducer [sum 0, count 0] 740 | [x] 741 | (if (= count 2) 742 | [:early sum] 743 | (recur (+ sum x) (inc count)))) 744 | [4 1 9 9 9])))) 745 | )) 746 | 747 | (binding [*warn-on-reflection* true 748 | *unchecked-math* :warn-on-boxed] 749 | (deftest ^:perf reducer-perf-test 750 | (let [bigvec (->> (range 100000) vec)] 751 | (testing "multiple accumulators" 752 | (println "\nRegular vector destructuring") 753 | (quick-bench 754 | (transduce identity 755 | (fn 756 | ([] [0 0]) 757 | ([[sum count]] (/ sum count)) 758 | ([[sum count] x] 759 | [(+ sum x) (inc count)])) 760 | bigvec)) 761 | 762 | (println "\nReducer without types") 763 | (quick-bench 764 | (transduce identity 765 | (reducer [sum 0, count 0] 766 | [x] 767 | (recur (+ sum x) (inc count)) 768 | (/ sum count)) 769 | bigvec)) 770 | 771 | 772 | (println "\nReducer with types") 773 | ; For reasons I can't explain this still winds up going through 774 | ; RT.longCast. :-/ 775 | (quick-bench 776 | (transduce identity 777 | (reducer [^long sum 0, ^long count 0] 778 | [^long x] 779 | (let [sum' ^long (prim/+ sum x) 780 | count' ^long (prim/inc count)] 781 | (recur sum' count')) 782 | (/ sum count)) 783 | bigvec)) 784 | 785 | )))) 786 | 787 | (deftest mutable-acc-type-test 788 | (testing "primitives" 789 | (let [at (mutable-acc-type '[byte short int long float double]) 790 | a (.newInstance at)] 791 | (set! (.x0 a) (byte 1)) 792 | (set! (.x1 a) (short 2)) 793 | (set! (.x2 a) (int 3)) 794 | (set! (.x3 a) (long 4)) 795 | (set! (.x4 a) (float 1.23)) 796 | (set! (.x5 a) (double 4.56)) 797 | (is (identical? (byte 1) (.x0 a))) 798 | (is (identical? (short 2) (.x1 a))) 799 | (is (identical? (int 3) (.x2 a))) 800 | (is (identical? (long 4) (.x3 a))) 801 | ; Not sure about these 802 | (is (= (float 1.23) (.x4 a))) 803 | (is (= (double 4.56) (.x5 a))) 804 | )) 805 | 806 | (testing "arrays" 807 | (let [at (mutable-acc-type '[bytes shorts ints longs floats doubles objects]) 808 | a (.newInstance at)] 809 | (set! (.x0 a) (byte-array 1)) 810 | (set! (.x1 a) (short-array 1)) 811 | (set! (.x2 a) (int-array 1)) 812 | (set! (.x3 a) (long-array 1)) 813 | (set! (.x4 a) (float-array 1)) 814 | (set! (.x5 a) (double-array 1)) 815 | (set! (.x6 a) (object-array 1)) 816 | (is (= 0 (aget ^bytes (.x0 a) 0))) 817 | (is (= 0 (aget ^shorts (.x1 a) 0))) 818 | (is (= 0 (aget ^ints (.x2 a) 0))) 819 | (is (= 0 (aget ^longs (.x3 a) 0))) 820 | (is (= 0.0 (aget ^floats (.x4 a) 0))) 821 | (is (= 0.0 (aget ^doubles (.x5 a) 0))) 822 | (is (= nil (aget ^objects (.x6 a) 0))))) 823 | 824 | (testing "objects" 825 | (let [at (mutable-acc-type '[String Object]) 826 | a (.newInstance at)] 827 | (set! (.x0 a) "foo") 828 | (set! (.x1 a) [1 2 3]) 829 | (is (= "foo" (.x0 a))) 830 | (is (= [1 2 3] (.x1 a)))))) 831 | --------------------------------------------------------------------------------