├── .gitignore ├── deps-clr.edn ├── CONTRIBUTING.md ├── src ├── main │ ├── dotnet │ │ └── packager │ │ │ ├── clojure.core.async.sln │ │ │ └── clojure.core.async.csproj │ └── clojure │ │ └── clojure │ │ └── core │ │ └── async │ │ ├── impl │ │ ├── mutex.clj │ │ ├── protocols.clj │ │ ├── exec │ │ │ └── threadpool.clj │ │ ├── dispatch.clj │ │ ├── buffers.clj │ │ ├── ioc_macros.clj │ │ ├── concurrent.clj │ │ ├── timers.clj │ │ ├── channels.clj │ │ └── go.clj │ │ └── lab.clj └── test │ └── clojure │ └── clojure │ └── core │ ├── async │ ├── concurrent_test.clj │ ├── timers_test.clj │ ├── buffers_test.clj │ ├── lab_test.clj │ └── ioc_macros_test.clj │ ├── pipeline_test.clj │ └── async_test.clj ├── README.md ├── project.clj ├── LICENSE.txt └── epl.html /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /lib 3 | /classes 4 | /checkouts 5 | pom.xml 6 | *.jar 7 | *.class 8 | *.dll 9 | *.pdb 10 | *.exe 11 | .lein-deps-sum 12 | .lein-failures 13 | .lein-plugins 14 | 15 | #Visual Studio artifacts 16 | bin/ 17 | obj/ 18 | .vs/ 19 | *.user 20 | *.suo 21 | *.nupkg 22 | 23 | .cpcache/ -------------------------------------------------------------------------------- /deps-clr.edn: -------------------------------------------------------------------------------- 1 | {:paths ["src/main/clojure"] 2 | :deps 3 | {io.github.clojure/tools.analyzer.clr {:git/tag "v1.3.2" :git/sha "732a0f4"}} 4 | 5 | :aliases 6 | {:test 7 | {:extra-paths ["src/test/clojure"] 8 | :extra-deps {io.github.dmiller/test-runner {:git/sha "c055ea13d19c6a9b9632aa2370fcc2215c8043c3"}} 9 | :exec-fn cognitect.test-runner.api/test 10 | :exec-args {:dirs ["src/test/clojure"]}}}} -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This is a [Clojure contrib] project. 2 | 3 | Under the Clojure contrib [guidelines], this project cannot accept 4 | pull requests. All patches must be submitted via [JIRA]. 5 | 6 | See [Contributing] on the Clojure website for 7 | more information on how to contribute. 8 | 9 | [Clojure contrib]: https://clojure.org/community/contrib_libs 10 | [Contributing]: https://clojure.org/community/contributing 11 | [JIRA]: https://clojure.atlassian.net/browse/TNS 12 | [guidelines]: https://clojure.org/community/contrib_howto -------------------------------------------------------------------------------- /src/main/dotnet/packager/clojure.core.async.sln: -------------------------------------------------------------------------------- 1 | 2 | Microsoft Visual Studio Solution File, Format Version 12.00 3 | # Visual Studio Version 17 4 | VisualStudioVersion = 17.4.33103.184 5 | MinimumVisualStudioVersion = 10.0.40219.1 6 | Project("{9A19103F-16F7-4668-BE54-9A1E7A4F7556}") = "clojure.core.async", "clojure.core.async.csproj", "{1F5B66E3-2E3E-4BAA-BD78-7C834767EFC1}" 7 | EndProject 8 | Global 9 | GlobalSection(SolutionConfigurationPlatforms) = preSolution 10 | Debug|Any CPU = Debug|Any CPU 11 | Release|Any CPU = Release|Any CPU 12 | EndGlobalSection 13 | GlobalSection(ProjectConfigurationPlatforms) = postSolution 14 | {1F5B66E3-2E3E-4BAA-BD78-7C834767EFC1}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 15 | {1F5B66E3-2E3E-4BAA-BD78-7C834767EFC1}.Debug|Any CPU.Build.0 = Debug|Any CPU 16 | {1F5B66E3-2E3E-4BAA-BD78-7C834767EFC1}.Release|Any CPU.ActiveCfg = Release|Any CPU 17 | {1F5B66E3-2E3E-4BAA-BD78-7C834767EFC1}.Release|Any CPU.Build.0 = Release|Any CPU 18 | EndGlobalSection 19 | GlobalSection(SolutionProperties) = preSolution 20 | HideSolutionNode = FALSE 21 | EndGlobalSection 22 | GlobalSection(ExtensibilityGlobals) = postSolution 23 | SolutionGuid = {A704628F-06D0-4222-8D41-449E77D41DF1} 24 | EndGlobalSection 25 | EndGlobal 26 | -------------------------------------------------------------------------------- /src/main/dotnet/packager/clojure.core.async.csproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | netstandard2.0;netstandard2.1 5 | 6 | 7 | 8 | clojure.core.async 9 | clojure.core 10 | clojure.core.async 11 | clojure.core.async 12 | clojure.core.async 13 | David Miller and ClojureCLR contributors 14 | A port of core.async to ClojureCLR 15 | Copyright © Rich Hickey and ClojureCLR contributors, 2025 16 | EPL-1.0 17 | https://github.com/clojure/clojure.tools.namesapce 18 | ClojureCLR contributors 19 | Clojure;ClojureCLR 20 | 1.7.701 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/async/concurrent_test.clj: -------------------------------------------------------------------------------- 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 | (ns clojure.core.async.concurrent-test 10 | (:require [clojure.test :refer :all] 11 | [clojure.core.async.impl.concurrent :as conc]) 12 | (:import [System.Threading Thread] 13 | [clojure.core.async.impl.concurrent ThreadFactory])) ;;; [java.util.concurrent ThreadFactory] 14 | 15 | (deftest test-counted-thread-factory 16 | (testing "Creates numbered threads" 17 | (let [^clojure.core.async.impl.concurrent.ThreadFactory factory (conc/counted-thread-factory "foo-%d" true) 18 | threads (repeatedly 3 #(.newThread factory (constantly nil)))] 19 | (is (= ["foo-1" "foo-2" "foo-3"] (map #(.Name ^Thread %) threads)))))) ;;; .getName 20 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/async/impl/mutex.clj: -------------------------------------------------------------------------------- 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 | (ns ^{:skip-wiki true} 10 | clojure.core.async.impl.mutex 11 | (:import [System.Threading Mutex])) ;;; [java.util.concurrent.locks Lock ReentrantLock] 12 | 13 | ;;;(defn mutex [] 14 | ;;; (let [m (ReentrantLock.)] 15 | ;;; (reify 16 | ;;; Lock 17 | ;;; (lock [_] (.lock m)) 18 | ;;; (unlock [_] (.unlock m))))) 19 | 20 | 21 | ;; The easiest solution is to define a protocol to give us the same methods (lock, unlock) as java.util.concurrent.locks.Lock, 22 | ;; then have mutex reify the protocol wrapping a System.Threading.Mutex. 23 | 24 | (defprotocol ILock 25 | "Providing the same affordance as java.util.concurrent.locks.Lock" 26 | (lock [_] "Lock the lock") 27 | (unlock [_] "Unlock the lock")) 28 | 29 | (deftype Lock [^Mutex m] 30 | ILock 31 | (lock [x] (.WaitOne m)) 32 | (unlock [x] (.ReleaseMutex m))) 33 | 34 | 35 | (defn mutex [] 36 | (Lock. (Mutex.))) 37 | 38 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/async/timers_test.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.async.timers-test 2 | (:require [clojure.test :refer :all] 3 | [clojure.core.async.impl.timers :refer :all] 4 | [clojure.core.async :as async])) 5 | 6 | (deftest timeout-interval-test 7 | (let [start-stamp (.Ticks DateTime/UtcNow) ;;; (System/currentTimeMillis) 8 | test-timeout (timeout 500)] 9 | (is (<= (+ start-stamp (* 500 TimeSpan/TicksPerMillisecond)) ;;; (+ start-stamp 500) 10 | (do (async/ A Clojure library designed to provide facilities for async programming and communication. 6 | 7 | 8 | 9 | ## Releases 10 | 11 | Latest stable release: 1.5.2 12 | 13 | [CLI/`deps.edn`](https://clojure.org/reference/deps_edn) dependency information: 14 | 15 | ```clojure 16 | io.github.clojure/clr.core.async {:git/tag "v1.7.701" :git/sha "07c6c8a"} 17 | ``` 18 | 19 | 20 | 21 | 22 | Nuget reference: 23 | 24 | ``` 25 | PM> Install-Package clojure.core.async -Version 1.7.701 26 | ``` 27 | 28 | Leiningen/Clojars reference: 29 | 30 | ``` 31 | [org.clojure.clr/core.async "1.7.701"] 32 | ``` 33 | 34 | 35 | ## Documentation 36 | 37 | * [Rationale](https://clojure.org/news/2013/06/28/clojure-clore-async-channels) 38 | * [API docs](https://clojure.github.io/core.async/) 39 | * [Code walkthrough](https://github.com/clojure/core.async/blob/master/examples/walkthrough.clj) 40 | 41 | ## Presentations 42 | 43 | * [Rich Hickey on core.async](https://www.youtube.com/watch?v=yJxFPoxqzWE) 44 | * [Tim Baldridge on core.async](https://www.youtube.com/watch?v=enwIIGzhahw) from Clojure/conj 2013 ([code](https://github.com/halgari/clojure-conj-2013-core.async-examples)). 45 | * 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) 46 | 47 | ## Contributing 48 | 49 | [Contributing to Clojure projects](https://clojure.org/community/contributing) requires a signed Contributor Agreement. Pull requests and GitHub issues are not accepted; please use the [core.async JIRA project](https://clojure.atlassian.net/browse/ASYNC) to report problems or enhancements. 50 | 51 | # Copyright and License # 52 | 53 | Original ClojureJVM code: 54 | 55 | > Copyright © 2017-2022 Rich Hickey and contributors 56 | 57 | > Distributed under the Eclipse Public License, the same as Clojure 58 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject org.clojure.clr/core.async "1.7.701" 2 | :description "A port of core.async to ClojureCLR" 3 | :url "https://github.com/clojure/clr.core.async" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [[org.clojure.clr/tools.analyzer.clr "1.3.2"]] 7 | :deploy-repositories [["clojars" {:url "https://clojars.org/repo/" 8 | :sign-releases false}]] 9 | :warn-on-reflection true 10 | :source-paths ["src/main/clojure"] 11 | :test-paths ["src/test/clojure"] 12 | :min-lein-version "2.0.0" 13 | :plugins [[lein-clr "0.2.1"]] 14 | :clr {:cmd-templates {:clj-exe [[?PATH "mono"] [CLJCLR14_40 %1]] 15 | :clj-dep [[?PATH "mono"] ["target/clr/clj/Debug 4.0" %1]] 16 | :clj-url "http://sourceforge.net/projects/clojureclr/files/clojure-clr-1.4.1-Debug-4.0.zip/download" 17 | :clj-zip "clojure-clr-1.4.1-Debug-4.0.zip" 18 | :curl ["curl" "--insecure" "-f" "-L" "-o" %1 %2] 19 | :nuget-ver [[?PATH "mono"] [*PATH "nuget.exe"] "install" %1 "-Version" %2] 20 | :nuget-any [[?PATH "mono"] [*PATH "nuget.exe"] "install" %1] 21 | :unzip ["unzip" "-d" %1 %2] 22 | :wget ["wget" "--no-check-certificate" "--no-clobber" "-O" %1 %2]} 23 | ;; for automatic download/unzip of ClojureCLR, 24 | ;; 1. make sure you have curl or wget installed and on PATH, 25 | ;; 2. uncomment deps in :deps-cmds, and 26 | ;; 3. use :clj-dep instead of :clj-exe in :main-cmd and :compile-cmd 27 | :deps-cmds [; [:wget :clj-zip :clj-url] ; edit to use :curl instead of :wget 28 | ; [:unzip "../clj" :clj-zip] 29 | ] 30 | :main-cmd [:clj-exe "Clojure.Main.exe"] 31 | :compile-cmd [:clj-exe "Clojure.Compile.exe"]}) 32 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/async/impl/protocols.clj: -------------------------------------------------------------------------------- 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 | (ns ^{:skip-wiki true} 10 | clojure.core.async.impl.protocols) 11 | 12 | 13 | (def ^:const ^{:tag 'int} MAX-QUEUE-SIZE 1024) 14 | 15 | (defprotocol ReadPort 16 | (take! [port fn1-handler] "derefable val if taken, nil if take was enqueued")) 17 | 18 | (defprotocol WritePort 19 | (put! [port val fn1-handler] "derefable boolean (false iff already closed) if handled, nil if put was enqueued. Must throw on nil val.")) 20 | 21 | (defprotocol Channel 22 | (close! [chan]) 23 | (closed? [chan])) 24 | 25 | (defprotocol Handler 26 | (active? [h] "returns true if has callback. Must work w/o lock") 27 | (blockable? [h] "returns true if this handler may be blocked, otherwise it must not block") 28 | (lock-id [h] "a unique id for lock acquisition order, 0 if no lock") 29 | (commit [h] "commit to fulfilling its end of the transfer, returns cb. Must be called within lock")) 30 | 31 | (defprotocol ABuffer ;;; Rename Buffer because of conflict with System.Buffer 32 | (full? [b] "returns true if buffer cannot accept put") 33 | (remove! [b] "remove and return next item from buffer, called under chan mutex") 34 | (add!* [b itm] "if room, add item to the buffer, returns b, called under chan mutex") 35 | (close-buf! [b] "called on chan closed under chan mutex, return ignored")) 36 | 37 | (defn add! 38 | ([b] b) 39 | ([b itm] 40 | (assert (not (nil? itm))) 41 | (add!* b itm))) 42 | 43 | (defprotocol Executor 44 | (exec [e runnable] "execute runnable asynchronously")) 45 | 46 | ;; Defines a buffer that will never block (return true to full?) 47 | (defprotocol UnblockingBuffer) -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/async/impl/exec/threadpool.clj: -------------------------------------------------------------------------------- 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 | (ns clojure.core.async.impl.exec.threadpool 10 | (:require [clojure.core.async.impl.protocols :as impl] 11 | [clojure.core.async.impl.concurrent :as conc]) 12 | (:import [System.Threading ThreadPool WaitCallback])) ;;; [java.util.concurrent Executors] 13 | 14 | (set! *warn-on-reflection* true) 15 | 16 | (def ^:private pool-size 17 | "Value is set via clojure.core.async.pool-size system property; defaults to 8; uses a 18 | delay so property can be set from code after core.async namespace is loaded but before 19 | any use of the async thread pool." 20 | (delay (let [v (Environment/GetEnvironmentVariable "clojure.core.async.pool-size") ;;; (or (Long/getLong "clojure.core.async.pool-size") 8) 21 | m (long 0) 22 | b (Int64/TryParse ^String v (by-ref m))] 23 | (if b m 8)))) 24 | 25 | ;;;(defn thread-pool-executor 26 | ;;; ([] 27 | ;;; (thread-pool-executor nil)) 28 | ;;; ([init-fn] 29 | ;;; (let [executor-svc (Executors/newFixedThreadPool 30 | ;;; @pool-size 31 | ;;; (conc/counted-thread-factory "async-dispatch-%d" true 32 | ;;; {:init-fn init-fn}))] 33 | ;;; (reify impl/Executor 34 | ;;; (impl/exec [_ r] 35 | ;;; (.execute executor-svc ^Runnable r)))))) 36 | 37 | ;;; Given that we are not implementing our own fixed-size thread pool but, rather, using the system thread pool, 38 | ;;; here we need only reify impl/Executor to queue a method to the thread pool. 39 | 40 | (defn thread-pool-executor 41 | ([] 42 | (thread-pool-executor nil)) 43 | ([init-fn] 44 | (reify impl/Executor 45 | (impl/exec [_ r] 46 | (ThreadPool/QueueUserWorkItem (gen-delegate WaitCallback [_] (when init-fn (init-fn)) (r))))))) 47 | 48 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/async/impl/dispatch.clj: -------------------------------------------------------------------------------- 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 | (ns ^{:skip-wiki true} 10 | clojure.core.async.impl.dispatch 11 | (:require [clojure.core.async.impl.protocols :as impl] 12 | [clojure.core.async.impl.exec.threadpool :as tp])) 13 | 14 | (set! *warn-on-reflection* true) 15 | 16 | ;;;(defonce ^:private in-dispatch (ThreadLocal.)) 17 | 18 | (defonce executor 19 | (delay (tp/thread-pool-executor ))) ;;; #(.set ^ThreadLocal in-dispatch true) -- getting rid of this init-fn. 20 | 21 | (defn in-dispatch-thread? 22 | "Returns true if the current thread is a go block dispatch pool thread" 23 | [] 24 | false) ;;; we have no way to detect (boolean (.get ^ThreadLocal in-dispatch)) 25 | 26 | (defn check-blocking-in-dispatch 27 | "If the current thread is a dispatch pool thread, throw an exception" 28 | [] ;;; making this a no-op 29 | ) ;;; (when (.get ^ThreadLocal in-dispatch) 30 | ;;; (throw (IllegalStateException. "Invalid blocking call in dispatch thread"))) 31 | 32 | (defn ex-handler 33 | "conveys given Exception to current thread's default uncaught handler. returns nil" 34 | [ex] 35 | ;;;(-> (Thread/currentThread) ;;; no equivalent on CLR 36 | ;;; .getUncaughtExceptionHandler 37 | ;;; (.uncaughtException (Thread/currentThread) ex)) 38 | nil) 39 | 40 | (defn run 41 | "Runs Runnable r on current thread when :on-caller? meta true, else in a thread pool thread." 42 | [r] ;;; ^Runnable -- we don't have this type. We are set up to take an IFn -- it will be called with no args 43 | (if (-> r meta :on-caller?) 44 | (try (.invoke ^clojure.lang.IFn r) (catch Exception t (ex-handler t))) ;;; (.run r) Exception 45 | (impl/exec @executor r))) 46 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/async/buffers_test.clj: -------------------------------------------------------------------------------- 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 | (ns clojure.core.async.buffers-test 10 | (:require [clojure.test :refer :all] 11 | [clojure.core.async.impl.buffers :refer :all] 12 | [clojure.core.async.impl.protocols :refer [full? add! remove! close-buf!]])) 13 | 14 | (defmacro throws? [expr] 15 | `(try 16 | ~expr 17 | false 18 | (catch Exception _# true))) ;;; Throwable 19 | 20 | (deftest fixed-buffer-tests 21 | (let [fb (fixed-buffer 2)] 22 | (is (= 0 (count fb))) 23 | 24 | (add! fb :1) 25 | (is (= 1 (count fb))) 26 | 27 | (add! fb :2) 28 | (is (= 2 (count fb))) 29 | 30 | (is (= :1 (remove! fb))) 31 | (is (not (full? fb))) 32 | 33 | (is (= 1 (count fb))) 34 | (is (= :2 (remove! fb))) 35 | 36 | (is (= 0 (count fb))) 37 | (is (throws? (remove! fb))))) 38 | 39 | (deftest dropping-buffer-tests 40 | (let [fb (dropping-buffer 2)] 41 | (is (= 0 (count fb))) 42 | 43 | (add! fb :1) 44 | (is (= 1 (count fb))) 45 | 46 | (add! fb :2) 47 | (is (= 2 (count fb))) 48 | 49 | (is (not (full? fb))) 50 | (is (not (throws? (add! fb :3)))) 51 | (is (= 2 (count fb))) 52 | 53 | (is (= :1 (remove! fb))) 54 | (is (not (full? fb))) 55 | 56 | (is (= 1 (count fb))) 57 | (is (= :2 (remove! fb))) 58 | 59 | (is (= 0 (count fb))) 60 | (is (throws? (remove! fb))))) 61 | 62 | (deftest sliding-buffer-tests 63 | (let [fb (sliding-buffer 2)] 64 | (is (= 0 (count fb))) 65 | 66 | (add! fb :1) 67 | (is (= 1 (count fb))) 68 | 69 | (add! fb :2) 70 | (is (= 2 (count fb))) 71 | 72 | (is (not (full? fb))) 73 | (is (not (throws? (add! fb :3)))) 74 | (is (= 2 (count fb))) 75 | 76 | (is (= :2 (remove! fb))) 77 | (is (not (full? fb))) 78 | 79 | (is (= 1 (count fb))) 80 | (is (= :3 (remove! fb))) 81 | 82 | (is (= 0 (count fb))) 83 | (is (throws? (remove! fb))))) 84 | 85 | (deftest promise-buffer-tests 86 | (let [pb (promise-buffer)] 87 | (is (= 0 (count pb))) 88 | 89 | (add! pb :1) 90 | (is (= 1 (count pb))) 91 | 92 | (add! pb :2) 93 | (is (= 1 (count pb))) 94 | 95 | (is (not (full? pb))) 96 | (is (not (throws? (add! pb :3)))) 97 | (is (= 1 (count pb))) 98 | 99 | (is (= :1 (remove! pb))) 100 | (is (not (full? pb))) 101 | 102 | (is (= 1 (count pb))) 103 | (is (= :1 (remove! pb))) 104 | 105 | (is (= nil (close-buf! pb))) 106 | (is (= :1 (remove! pb))))) -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/pipeline_test.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.pipeline-test 2 | (:require [clojure.test :refer (deftest is are)] 3 | [clojure.core.async :refer [!! go-loop thread chan close! to-chan! 4 | pipeline pipeline-blocking pipeline-async]])) 5 | 6 | ;; in Clojure 1.7, use (map f) instead of this 7 | (defn mapping [f] 8 | (fn [f1] 9 | (fn 10 | ([] (f1)) 11 | ([result] (f1 result)) 12 | ([result input] 13 | (f1 result (f input))) 14 | ([result input & inputs] 15 | (f1 result (apply f input inputs)))))) 16 | 17 | (defn pipeline-tester [pipeline-fn n inputs xf] 18 | (let [cin (to-chan! inputs) 19 | cout (chan 1)] 20 | (pipeline-fn n cout xf cin) 21 | (!! ch v) (close! ch))) 29 | 30 | (deftest test-sizes 31 | (are [n size] 32 | (let [r (range size)] 33 | (and 34 | (= r (pipeline-tester pipeline n r identity-mapping)) 35 | (= r (pipeline-tester pipeline-blocking n r identity-mapping)) 36 | (= r (pipeline-tester pipeline-async n r identity-async)))) 37 | 1 0 38 | 1 10 39 | 10 10 40 | 20 10 41 | 5 1000)) 42 | 43 | (deftest test-close? 44 | (doseq [pf [pipeline pipeline-blocking]] 45 | (let [cout (chan 1)] 46 | (pf 5 cout identity-mapping (to-chan! [1]) true) 47 | (is (= 1 (!! cout :more) 53 | (is (= :more (!! cout :more) 58 | (is (= :more (!! chex e) :err)] 66 | (pf 5 cout ex-mapping (to-chan! [1 2 3 4]) true ex-handler) 67 | (is (= 1 (!! ch i)) 77 | (close! ch))) 78 | 79 | (deftest test-af-multiplier 80 | (is (= [0 0 1 0 1 2 0 1 2 3] 81 | (pipeline-tester pipeline-async 2 (range 1 5) multiplier-async)))) 82 | 83 | (def sleep-mapping (mapping #(do (System.Threading.Thread/Sleep (int %)) %))) ;;; Thread/sleep 84 | 85 | (deftest test-blocking 86 | (let [times [2000 50 1000 100]] 87 | (is (= times (pipeline-tester pipeline-blocking 2 times sleep-mapping))))) 88 | 89 | (defn slow-fib [n] 90 | (if (< n 2) n (+ (slow-fib (- n 1)) (slow-fib (- n 2))))) 91 | 92 | (deftest test-compute 93 | (let [input (take 50 (cycle (range 15 38)))] 94 | (is (= (slow-fib (last input)) 95 | (last (pipeline-tester pipeline 8 input (mapping slow-fib))))))) 96 | 97 | (deftest test-async 98 | (is (= (range 1 101) 99 | (pipeline-tester pipeline-async 1 (range 100) 100 | (fn [v ch] (future (>!! ch (inc v)) (close! ch))))))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/async/impl/buffers.clj: -------------------------------------------------------------------------------- 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 | (ns ^{:skip-wiki true} 10 | clojure.core.async.impl.buffers 11 | (:require [clojure.core.async.impl.protocols :as impl]) 12 | (:import [System.Collections.Generic |LinkedList`1[System.Object]|] ;;; [java.util LinkedList] -- I don't even know why this works. You can use |LinkedList`1| below. 13 | [clojure.lang Counted])) 14 | 15 | (set! *warn-on-reflection* true) 16 | 17 | (deftype FixedBuffer [^|LinkedList`1| buf ^long n] 18 | impl/ABuffer ;;; Buffer 19 | (full? [_this] 20 | (>= (.Count buf) n)) ;;; .size 21 | (remove! [_this] 22 | (let [v (.Last buf)] (.RemoveLast buf) (when v (.Value v)))) ;;; .removeLast 23 | (add!* [this itm] 24 | (.AddFirst buf itm) ;;; .addFirst 25 | this) 26 | (close-buf! [_this]) 27 | Counted 28 | (count [_this] 29 | (.Count buf))) ;;; .size 30 | 31 | (defn fixed-buffer [^long n] 32 | (FixedBuffer. (|LinkedList`1|.) n)) 33 | 34 | 35 | (deftype DroppingBuffer [^|LinkedList`1| buf ^long n] 36 | impl/UnblockingBuffer 37 | impl/ABuffer ;;; Buffer 38 | (full? [_this] 39 | false) 40 | (remove! [_this] 41 | (let [v (.Last buf)] (.RemoveLast buf) (when v (.Value v)))) ;;; .removeLast 42 | (add!* [this itm] 43 | (when-not (>= (.Count buf) n) ;;; .size 44 | (.AddFirst buf itm)) ;;; .addFirst 45 | this) 46 | (close-buf! [_this]) 47 | Counted 48 | (count [_this] 49 | (.Count buf))) ;;; .size 50 | 51 | (defn dropping-buffer [n] 52 | (DroppingBuffer. (|LinkedList`1|.) n)) 53 | 54 | (deftype SlidingBuffer [^|LinkedList`1| buf ^long n] 55 | impl/UnblockingBuffer 56 | impl/ABuffer ;;; Buffer 57 | (full? [_this] 58 | false) 59 | (remove! [_this] 60 | (let [v (.Last buf)] (.RemoveLast buf) (when v (.Value v)))) ;;; .removeLast 61 | (add!* [this itm] 62 | (when (= (.Count buf) n) ;;; .size 63 | (impl/remove! this)) 64 | (.AddFirst buf itm) ;;; .addFirst 65 | this) 66 | (close-buf! [_this]) 67 | Counted 68 | (count [_this] 69 | (.Count buf))) ;;; .size 70 | 71 | (defn sliding-buffer [n] 72 | (SlidingBuffer. (|LinkedList`1|.) n)) 73 | 74 | (defonce ^:private NO-VAL (Object.)) 75 | (defn- undelivered? [val] 76 | (identical? NO-VAL val)) 77 | 78 | (deftype PromiseBuffer [^:unsynchronized-mutable val] 79 | impl/UnblockingBuffer 80 | impl/ABuffer ;;; Buffer 81 | (full? [_] 82 | false) 83 | (remove! [_] 84 | val) 85 | (add!* [this itm] 86 | (when (undelivered? val) 87 | (set! val itm)) 88 | this) 89 | (close-buf! [_] 90 | (when (undelivered? val) 91 | (set! val nil))) 92 | Counted 93 | (count [_] 94 | (if (undelivered? val) 0 1))) 95 | 96 | (defn promise-buffer [] 97 | (PromiseBuffer. NO-VAL)) -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/async/impl/ioc_macros.clj: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey. 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 | ;; by Timothy Baldridge 10 | ;; April 13, 2013 11 | 12 | (ns ^{:skip-wiki true} 13 | clojure.core.async.impl.ioc-macros 14 | (:require [clojure.core.async.impl.protocols :as impl]) 15 | (:import [clojure.core.async.impl.mutex ILock] ;;; [java.util.concurrent.locks Lock] 16 | [clojure.core.async.impl.concurrent IAtomicReferenceArray])) ;;; [java.util.concurrent.atomic AtomicReferenceArray] 17 | 18 | (def ^{:const true :tag 'long} FN-IDX 0) 19 | (def ^{:const true :tag 'long} STATE-IDX 1) 20 | (def ^{:const true :tag 'long} VALUE-IDX 2) 21 | (def ^{:const true :tag 'long} BINDINGS-IDX 3) 22 | (def ^{:const true :tag 'long} EXCEPTION-FRAMES 4) 23 | (def ^{:const true :tag 'long} USER-START-IDX 5) 24 | 25 | (defn aset-object [^IAtomicReferenceArray arr ^long idx o] ;; AtomicReferenceArray 26 | (.set arr idx o)) 27 | 28 | (defn aget-object [^IAtomicReferenceArray arr ^long idx] ;; AtomicReferenceArray 29 | (.get arr idx)) 30 | 31 | (defmacro aset-all! 32 | [arr & more] 33 | (assert (even? (count more)) "Must give an even number of args to aset-all!") 34 | (let [bindings (partition 2 more) 35 | arr-sym (gensym "statearr-")] 36 | `(let [~arr-sym ~arr] 37 | ~@(map 38 | (fn [[idx val]] 39 | `(aset-object ~arr-sym ~idx ~val)) 40 | bindings) 41 | ~arr-sym))) 42 | 43 | (defn- fn-handler 44 | [f] 45 | (reify 46 | ILock ;;; Lock 47 | (lock [_]) 48 | (unlock [_]) 49 | 50 | impl/Handler 51 | (active? [_] true) 52 | (blockable? [_] true) 53 | (lock-id [_] 0) 54 | (commit [_] f))) 55 | 56 | 57 | (defn run-state-machine [state] 58 | ((aget-object state FN-IDX) state)) 59 | 60 | (defn run-state-machine-wrapped [state] 61 | (try 62 | (run-state-machine state) 63 | (catch Exception ex ;;; Throwable 64 | (impl/close! (aget-object state USER-START-IDX)) 65 | (throw ex)))) 66 | 67 | (defn take! [state blk c] 68 | (if-let [cb (impl/take! c (fn-handler 69 | (fn [x] 70 | (aset-all! state VALUE-IDX x STATE-IDX blk) 71 | (run-state-machine-wrapped state))))] 72 | (do (aset-all! state VALUE-IDX @cb STATE-IDX blk) 73 | :recur) 74 | nil)) 75 | 76 | (defn put! [state blk c val] 77 | (if-let [cb (impl/put! c val (fn-handler (fn [ret-val] 78 | (aset-all! state VALUE-IDX ret-val STATE-IDX blk) 79 | (run-state-machine-wrapped state))))] 80 | (do (aset-all! state VALUE-IDX @cb STATE-IDX blk) 81 | :recur) 82 | nil)) 83 | 84 | (defn return-chan [state value] 85 | (let [c (aget-object state USER-START-IDX)] 86 | (when-not (nil? value) 87 | (impl/put! c value (fn-handler (fn [_] nil)))) 88 | (impl/close! c) 89 | c)) 90 | 91 | (def async-custom-terminators 92 | {'clojure.core.async/! `put! 94 | 'clojure.core.async/alts! 'clojure.core.async/ioc-alts! 95 | :Return `return-chan}) -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/async/lab_test.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.async.lab-test 2 | (:require 3 | [clojure.test :refer [deftest is]] 4 | [clojure.core.async.lab :refer [broadcast multiplex]] 5 | [clojure.core.async :as async])) 6 | 7 | ;;; Adding a little helper to deal with all the threading calls. 8 | ;;; Someday should add this to the clr-specific functions. 9 | 10 | (defn start-thread-on [run-fn] 11 | (doto (System.Threading.Thread. 12 | ^System.Threading.ThreadStart 13 | (gen-delegate System.Threading.ThreadStart [] (run-fn))) 14 | (.Start))) 15 | 16 | 17 | (deftest multiplex-test 18 | #_(is (apply = (let [even-chan (async/chan) ;;; TODO -- debug this -gets a "can't cast Boolean to Future 19 | odd-chan (async/chan) 20 | muxer (multiplex even-chan odd-chan) 21 | odds (filter odd? (range 10)) 22 | evens (filter even? (range 10)) 23 | odd-fn #(doseq [odd odds] 24 | (async/>!! odd-chan odd)) 25 | _odd-pusher (start-thread-on odd-fn) ;;; (doto (Thread. ^Runnable odd-fn) (.start)) 26 | even-fn #(doseq [even evens] 27 | (async/>!! even-chan even)) 28 | _even-pusher (start-thread-on even-fn) ;;; (doto (Thread. ^Runnable even-fn) (.start)) 29 | expected (set (range 10)) 30 | observed (set (for [_ (range 10)] (async/!! long-chan i)) 39 | (async/close! short-chan)) 40 | _long-pusher (start-thread-on long-fn) ;;; (doto (Thread. ^Runnable long-fn) (.start)) 41 | short-fn #(do (dotimes [i 10] 42 | (async/>!! short-chan i)) 43 | (async/close! short-chan)) 44 | _short-pusher (start-thread-on short-fn) ;;; (doto (Thread. ^Runnable short-fn) (.start)) 45 | observed (for [_ (range 10010)] (async/!! broadcaster :foo) 61 | expected (repeat 5 :foo) 62 | observed (doall (map async/!! broadcaster :foo) 70 | (async/>!! broadcaster :bar)) 71 | first-reads (doall (map async/!! broadcaster i))) 86 | observed (for [_ (range 100)] 87 | (async/MultiplexingReadPort (mutex/mutex) (|HashSet`1|. ^System.Collections.IEnumerable ports))) ;;; (HashSet. ^Collection ports) 81 | 82 | (defn- broadcast-write 83 | [port-set val handler] 84 | (if (= (count port-set) 1) 85 | (impl/put! (first port-set) val handler) 86 | (let [clauses (map (fn [port] [port val]) port-set) 87 | recur-step (fn [[_ port]] (broadcast-write (disj port-set port) val handler))] 88 | (when-let [alt-res (async/do-alts recur-step clauses {})] 89 | (recur (disj port-set (second @alt-res)) 90 | val 91 | handler))))) 92 | 93 | (deftype BroadcastingWritePort 94 | [write-ports] 95 | impl/WritePort 96 | (put! [port val handler] 97 | (broadcast-write write-ports val handler))) 98 | 99 | (defn broadcast 100 | "Returns a broadcasting write port which, when written to, writes 101 | the value to each of ports. 102 | 103 | Writes to the broadcasting port will park until the value is written 104 | to each of the ports used to create it. For this reason, it is 105 | strongly advised that each of the underlying ports support buffered 106 | writes." 107 | [& ports] 108 | (->BroadcastingWritePort (set ports))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/async/impl/concurrent.clj: -------------------------------------------------------------------------------- 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 | (ns ^{:skip-wiki true} 10 | clojure.core.async.impl.concurrent 11 | (:import [System.Threading Thread ThreadStart])) ;;; [java.util.concurrent ThreadFactory] 12 | 13 | (set! *warn-on-reflection* true) 14 | 15 | 16 | ;;;(defn counted-thread-factory 17 | ;;; "Create a ThreadFactory that maintains a counter for naming Threads. 18 | ;;; name-format specifies thread names - use %d to include counter 19 | ;;; daemon is a flag for whether threads are daemons or not 20 | ;;; opts is an options map: 21 | ;;; init-fn - function to run when thread is created" 22 | ;;; ([name-format daemon] 23 | ;;; (counted-thread-factory name-format daemon nil)) 24 | ;;; ([name-format daemon {:keys [init-fn] :as opts}] 25 | ;;; (let [counter (atom 0)] 26 | ;;; (reify 27 | ;;; ThreadFactory 28 | ;;; (newThread [_this runnable] 29 | ;;; (let [body (if init-fn 30 | ;;; (fn [] (init-fn) (.run ^Runnable runnable)) 31 | ;;; runnable) 32 | ;;; t (Thread. ^Runnable body)] 33 | ;;; (doto t 34 | ;;; (.setName (format name-format (swap! counter inc))) 35 | ;;; (.setDaemon daemon)))))))) 36 | 37 | 38 | ;;; DM: Added this type to match java.util.concurrent.ThreadFactory 39 | 40 | (defprotocol ThreadFactory 41 | "Protocol to match java.util.concurrent.ThreadFactory" 42 | (newThread [_ runnable] "create a new thread")) 43 | 44 | ;;; In ClojureJVM, an IFn is a Runnable. Not so in ClojureCLR. 45 | ;;; We take in something callable, but have to wrap it as a ThreadStart delegate. 46 | 47 | (defn counted-thread-factory 48 | "Create a ThreadFactory that maintains a counter for naming Threads. 49 | name-format specifies thread names - use %d to include counter 50 | daemon is a flag for whether threads are daemons or not 51 | opts is an options map: 52 | init-fn - function to run when thread is created" 53 | ([name-format daemon] 54 | (counted-thread-factory name-format daemon nil)) 55 | ([name-format daemon {:keys [init-fn] :as opts}] 56 | (let [counter (atom 0)] 57 | (reify 58 | ThreadFactory 59 | (newThread [_this runnable] 60 | (let [body (if init-fn 61 | (gen-delegate ThreadStart [] (init-fn) (runnable)) 62 | (gen-delegate ThreadStart [] (runnable))) 63 | t (Thread. ^ThreadStart body)] 64 | (doto t 65 | (.set_Name (format name-format (swap! counter inc))) 66 | (.set_IsBackground daemon)))))))) 67 | 68 | (defonce 69 | ^{:doc "Number of processors reported by the JVM"} 70 | processors Environment/ProcessorCount) ;;; (.availableProcessors (Runtime/getRuntime)) 71 | 72 | 73 | ;; Implementation of a substitute for java.util.concurrent.atomic.AtomicReferenceArray 74 | ;; Would love to do this lock-free (using Interlocked, Volatile.Read/Write, but can't. See comment below. 75 | 76 | (definterface IAtomicReferenceArray 77 | (set [^long idx o]) 78 | (get [^long idx])) 79 | 80 | (deftype AtomicReferenceArray [^|Object[]| arr] 81 | IAtomicReferenceArray 82 | (set [this ^long idx o] 83 | (locking arr 84 | (aset arr idx o) 85 | o)) 86 | (get [this ^long idx] 87 | (locking arr 88 | (aget arr idx)))) 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | ;; Compliments of Copilot 98 | ;; Problem, we cannot do the equivalent of 'ref _array[i]' in Clojure 99 | ;; We'll have to do locking. 100 | ;/// 101 | ;/// Thread-safe array of references where each element can be updated atomically. 102 | ;/// 103 | ;public class AtomicReferenceArray where T : class 104 | ;{ 105 | ; private readonly T[] _array 106 | ; 107 | ; public AtomicReferenceArray(int length) 108 | ; { 109 | ; if (length < 0) 110 | ; throw new ArgumentOutOfRangeException(nameof(length), "Length must be non-negative."); 111 | ; _array = new T[length]; 112 | ; } 113 | ; 114 | ; public AtomicReferenceArray(T[] source) 115 | ; { 116 | ; if (source == null) 117 | ; throw new ArgumentNullException(nameof(source)); 118 | ; _array = new T[source.Length]; 119 | ; Array.Copy(source, _array, source.Length); 120 | ; } 121 | ; 122 | ; public int Length => _array.Length; 123 | ; 124 | ; /// 125 | ; /// Gets the value at the given index. 126 | ; /// 127 | ; public T Get(int index) 128 | ; { 129 | ; ValidateIndex(index); 130 | ; return Volatile.Read(ref _array[index]); 131 | ; } 132 | ; 133 | ; /// 134 | ; /// Sets the value at the given index. 135 | ; /// 136 | ; public void Set(int index, T newValue) 137 | ; { 138 | ; ValidateIndex(index); 139 | ; Volatile.Write(ref _array[index], newValue); 140 | ; } 141 | ; 142 | ; /// 143 | ; /// Atomically sets the value to newValue if the current value equals expectedValue. 144 | ; /// 145 | ; public bool CompareAndSet(int index, T expectedValue, T newValue) 146 | ; { 147 | ; ValidateIndex(index); 148 | ; return Interlocked.CompareExchange(ref _array[index], newValue, expectedValue) == expectedValue; 149 | ; } 150 | ; 151 | ; /// 152 | ; /// Atomically gets the current value and sets a new value. 153 | ; /// 154 | ; public T GetAndSet(int index, T newValue) 155 | ; { 156 | ; ValidateIndex(index); 157 | ; return Interlocked.Exchange(ref _array[index], newValue); 158 | ; } 159 | ; 160 | ; private void ValidateIndex(int index) 161 | ; { 162 | ; if (index < 0 || index >= _array.Length) 163 | ; throw new ArgumentOutOfRangeException(nameof(index)); 164 | ; } 165 | ;} -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/async/impl/timers.clj: -------------------------------------------------------------------------------- 1 | 1422;; 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 | (ns ^{:skip-wiki true} 10 | clojure.core.async.impl.timers 11 | (:require [clojure.core.async.impl.protocols :as impl] 12 | [clojure.core.async.impl.channels :as channels]) 13 | (:import [System.Threading AutoResetEvent Thread])) ;;; [java.util.concurrent DelayQueue Delayed TimeUnit ConcurrentSkipListMap] 14 | 15 | ;; we have to do some serious reworking here. 16 | ;; We do not have direct equivalents of any of the data structures used in the JVM implementation. 17 | ;; 18 | ;; A quick analysis: 19 | ;; 20 | ;; ConcurrentSkipListMap is used essentially as a priority queue. 21 | ;; This code uses the ceilingEntry method to find the first entry with a larger timestamp. 22 | ;; A skip list can do this in log(n) time. 23 | ;; 24 | ;; If we use a SortedList, we'll be O(n). An alternative is a SortedSet, which has a GetViewBetween. 25 | ;; That should be time-efficient, but likely will do more memory allocation. Pick one. 26 | ;; 27 | ;; (It would be nice to use System.Collections.Generic.PriorityQueue, but that is not available in Framework.) 28 | ;; 29 | ;; DelayQueue is a blocking queue for which entries become available only when their timestamps have been reached. 30 | ;; We do have a BlockingCollection, but no underlying collection type to use that has the needed characteristics. 31 | ;; We are going to have roll our own. 32 | ;; 33 | ;; But if you look at the use case here, we don't really need so much. Let us talk our way through this. 34 | ;; 35 | ;; Clients call the function `timeout` to get a channel that will close within a certain number of milliseconds. 36 | ;; If there is a channel with a remaining timeout between the desired duration and that duration + TIMEOUT_RESOLUTION_MS, that channel can be used. 37 | ;; Otherwise we need to create a channel, register it in our system here, and return it. 38 | ;; 39 | ;; We need a thread to timeout the channels. 40 | ;; This thread can WaitOne on a wait handle. Its timeout is infinite if the collection of channels is empty. 41 | ;; Otherwise, its timeout will be at the time when the next channel is to be closed. 42 | ;; the 'timeout' function might post something with a closer timeout. It should trigger the wait handle, waking this thread. 43 | ;; When awakened, the thread closes any channels whose time has expired, then waits again. 44 | ;; 45 | ;; In the JVM code, the thread waits on the DelayQueue. We replace that by waiting on the wait handle with a timeout. 46 | ;; 47 | 48 | ;;; Original code 49 | ;;; 50 | ;;;(set! *warn-on-reflection* true) 51 | ;;; 52 | ;;;(defonce ^:private ^DelayQueue timeouts-queue 53 | ;;; (DelayQueue.)) 54 | ;;; 55 | ;;;(defonce ^:private ^ConcurrentSkipListMap timeouts-map 56 | ;;; (ConcurrentSkipListMap.)) 57 | ;;; 58 | ;;;(def ^:const TIMEOUT_RESOLUTION_MS 10) 59 | ;;; 60 | ;;;(deftype TimeoutQueueEntry [channel ^long timestamp] 61 | ;;; Delayed 62 | ;;; (getDelay [_this time-unit] 63 | ;;; (.convert time-unit 64 | ;;; (- timestamp (System/currentTimeMillis)) 65 | ;;; TimeUnit/MILLISECONDS)) 66 | ;;; (compareTo 67 | ;;; [_this other] 68 | ;;; (let [ostamp (.timestamp ^TimeoutQueueEntry other)] 69 | ;;; (if (< timestamp ostamp) 70 | ;;; -1 71 | ;;; (if (= timestamp ostamp) 72 | ;;; 0 73 | ;;; 1)))) 74 | ;;; impl/Channel 75 | ;;; (close! [_this] 76 | ;;; (impl/close! channel))) 77 | ;;; 78 | ;;;(defn- timeout-worker 79 | ;;; [] 80 | ;;; (let [q timeouts-queue] 81 | ;;; (loop [] 82 | ;;; (let [^TimeoutQueueEntry tqe (.take q)] 83 | ;;; (.remove timeouts-map (.timestamp tqe) tqe) 84 | ;;; (impl/close! tqe)) 85 | ;;; (recur)))) 86 | ;;; 87 | ;;;(defonce timeout-daemon 88 | ;;; (delay 89 | ;;; (doto (Thread. ^Runnable timeout-worker "clojure.core.async.timers/timeout-daemon") 90 | ;;; (.setDaemon true) 91 | ;;; (.start)))) 92 | ;;; 93 | ;;;(defn timeout 94 | ;;; "returns a channel that will close after msecs" 95 | ;;; [^long msecs] 96 | ;;; @timeout-daemon 97 | ;;; (let [timeout (+ (System/currentTimeMillis) msecs) 98 | ;;; me (.ceilingEntry timeouts-map timeout)] 99 | ;;; (or (when (and me (< (.getKey me) (+ timeout TIMEOUT_RESOLUTION_MS))) 100 | ;;; (.channel ^TimeoutQueueEntry (.getValue me))) 101 | ;;; (let [timeout-channel (channels/chan nil) 102 | ;;; timeout-entry (TimeoutQueueEntry. timeout-channel timeout)] 103 | ;;; (.put timeouts-map timeout timeout-entry) 104 | ;;; (.put timeouts-queue timeout-entry) 105 | ;;; timeout-channel)))) 106 | 107 | 108 | ;;; And away we go. 109 | 110 | (set! *warn-on-reflection* true) 111 | 112 | (def ^:const TIMEOUT_RESOLUTION_MS 10) 113 | (def ^:const TIMEOUT_RESOLUTION_TICKS (* TIMEOUT_RESOLUTION_MS TimeSpan/TicksPerMillisecond)) 114 | 115 | (def ^:private ^AutoResetEvent wait-handle (AutoResetEvent. false)) 116 | 117 | (deftype TimeoutQueueEntry [channel ^long timestamp] 118 | IComparable 119 | (CompareTo [this y] 120 | (if (and y (instance? TimeoutQueueEntry y)) 121 | (let [tqe ^TimeoutQueueEntry y] 122 | (.CompareTo timestamp (.timestamp tqe))) 123 | 1)) 124 | impl/Channel 125 | (close! [_this] 126 | (impl/close! channel))) 127 | 128 | 129 | (def ^:private ^|System.Collections.Generic.SortedSet`1[ clojure.core.async.impl.timers.TimeoutQueueEntry]| timeouts-set (|System.Collections.Generic.SortedSet`1[ clojure.core.async.impl.timers.TimeoutQueueEntry]|.)) 130 | 131 | (defn- least-upper-bound-entry 132 | "Get the timeout entry with the smallest value of timeout in the interval given" 133 | [start-time end-time] 134 | (let [start-entry (TimeoutQueueEntry. nil start-time) 135 | end-entry (TimeoutQueueEntry. nil end-time)] 136 | (.Min (.GetViewBetween timeouts-set start-entry end-entry)))) 137 | 138 | (defn- expired? 139 | "Determine if a TimeQueueEntry has expired" 140 | [^TimeoutQueueEntry tqe] 141 | (let [ts (.timestamp tqe) 142 | now (.Ticks DateTime/UtcNow)] 143 | (< ts now))) 144 | 145 | (defn- maybe-close-tqe 146 | "If this entry has expired, close its channel. 147 | Return true if entry has expired, false otherwise" 148 | [^TimeoutQueueEntry tqe] 149 | (when (expired? tqe) 150 | (impl/close! tqe) 151 | true)) 152 | 153 | (defn- process-entries 154 | "Close the channel on each timed-out entry" 155 | [] 156 | (locking (.SyncRoot ^System.Collections.ICollection timeouts-set) 157 | (loop [] 158 | (when-let [tqe (.Min timeouts-set)] 159 | (when (maybe-close-tqe tqe) 160 | (.Remove timeouts-set tqe) 161 | (recur)))))) 162 | 163 | (defn- timeout-worker 164 | [] 165 | (loop [] 166 | (process-entries) 167 | (let [tqe (.Min timeouts-set)] 168 | (if tqe 169 | (.WaitOne wait-handle (TimeSpan. (- (.timestamp tqe) (.Ticks DateTime/UtcNow)))) 170 | (.WaitOne wait-handle))) 171 | (recur))) 172 | 173 | (defonce timeout-daemon 174 | (delay 175 | (doto (Thread. ^System.Threading.ThreadStart (gen-delegate System.Threading.ThreadStart [] (timeout-worker))) 176 | (.set_Name "clojure.core.async.timers/timeout-daemon") 177 | (.set_IsBackground true) 178 | (.Start)))) 179 | 180 | (defn timeout 181 | "returns a channel that will close after msecs" 182 | [^long msecs] 183 | @timeout-daemon 184 | (locking (.SyncRoot ^System.Collections.ICollection timeouts-set) 185 | (let [timeout (+ (.Ticks DateTime/UtcNow) (* TimeSpan/TicksPerMillisecond msecs)) 186 | lub (least-upper-bound-entry timeout (+ timeout TIMEOUT_RESOLUTION_TICKS))] 187 | (or (when lub 188 | (.channel ^TimeoutQueueEntry lub)) 189 | (let [timeout-channel (channels/chan nil) 190 | timeout-entry (TimeoutQueueEntry. timeout-channel timeout)] 191 | (.Add timeouts-set timeout-entry) 192 | (.Set wait-handle) 193 | timeout-channel))))) 194 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Eclipse Public License - v 1.0 2 | 3 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC 4 | LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM 5 | CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 6 | 7 | 1. DEFINITIONS 8 | 9 | "Contribution" means: 10 | 11 | a) in the case of the initial Contributor, the initial code and documentation 12 | distributed under this Agreement, and 13 | b) in the case of each subsequent Contributor: 14 | i) changes to the Program, and 15 | ii) additions to the Program; 16 | 17 | where such changes and/or additions to the Program originate from and are 18 | distributed by that particular Contributor. A Contribution 'originates' 19 | from a Contributor if it was added to the Program by such Contributor 20 | itself or anyone acting on such Contributor's behalf. Contributions do not 21 | include additions to the Program which: (i) are separate modules of 22 | software distributed in conjunction with the Program under their own 23 | license agreement, and (ii) are not derivative works of the Program. 24 | 25 | "Contributor" means any person or entity that distributes the Program. 26 | 27 | "Licensed Patents" mean patent claims licensable by a Contributor which are 28 | necessarily infringed by the use or sale of its Contribution alone or when 29 | combined with the Program. 30 | 31 | "Program" means the Contributions distributed in accordance with this 32 | Agreement. 33 | 34 | "Recipient" means anyone who receives the Program under this Agreement, 35 | including all Contributors. 36 | 37 | 2. GRANT OF RIGHTS 38 | a) Subject to the terms of this Agreement, each Contributor hereby grants 39 | Recipient a non-exclusive, worldwide, royalty-free copyright license to 40 | reproduce, prepare derivative works of, publicly display, publicly 41 | perform, distribute and sublicense the Contribution of such Contributor, 42 | if any, and such derivative works, in source code and object code form. 43 | b) Subject to the terms of this Agreement, each Contributor hereby grants 44 | Recipient a non-exclusive, worldwide, royalty-free patent license under 45 | Licensed Patents to make, use, sell, offer to sell, import and otherwise 46 | transfer the Contribution of such Contributor, if any, in source code and 47 | object code form. This patent license shall apply to the combination of 48 | the Contribution and the Program if, at the time the Contribution is 49 | added by the Contributor, such addition of the Contribution causes such 50 | combination to be covered by the Licensed Patents. The patent license 51 | shall not apply to any other combinations which include the Contribution. 52 | No hardware per se is licensed hereunder. 53 | c) Recipient understands that although each Contributor grants the licenses 54 | to its Contributions set forth herein, no assurances are provided by any 55 | Contributor that the Program does not infringe the patent or other 56 | intellectual property rights of any other entity. Each Contributor 57 | disclaims any liability to Recipient for claims brought by any other 58 | entity based on infringement of intellectual property rights or 59 | otherwise. As a condition to exercising the rights and licenses granted 60 | hereunder, each Recipient hereby assumes sole responsibility to secure 61 | any other intellectual property rights needed, if any. For example, if a 62 | third party patent license is required to allow Recipient to distribute 63 | the Program, it is Recipient's responsibility to acquire that license 64 | before distributing the Program. 65 | d) Each Contributor represents that to its knowledge it has sufficient 66 | copyright rights in its Contribution, if any, to grant the copyright 67 | license set forth in this Agreement. 68 | 69 | 3. REQUIREMENTS 70 | 71 | A Contributor may choose to distribute the Program in object code form under 72 | its own license agreement, provided that: 73 | 74 | a) it complies with the terms and conditions of this Agreement; and 75 | b) its license agreement: 76 | i) effectively disclaims on behalf of all Contributors all warranties 77 | and conditions, express and implied, including warranties or 78 | conditions of title and non-infringement, and implied warranties or 79 | conditions of merchantability and fitness for a particular purpose; 80 | ii) effectively excludes on behalf of all Contributors all liability for 81 | damages, including direct, indirect, special, incidental and 82 | consequential damages, such as lost profits; 83 | iii) states that any provisions which differ from this Agreement are 84 | offered by that Contributor alone and not by any other party; and 85 | iv) states that source code for the Program is available from such 86 | Contributor, and informs licensees how to obtain it in a reasonable 87 | manner on or through a medium customarily used for software exchange. 88 | 89 | When the Program is made available in source code form: 90 | 91 | a) it must be made available under this Agreement; and 92 | b) a copy of this Agreement must be included with each copy of the Program. 93 | Contributors may not remove or alter any copyright notices contained 94 | within the Program. 95 | 96 | Each Contributor must identify itself as the originator of its Contribution, 97 | if 98 | any, in a manner that reasonably allows subsequent Recipients to identify the 99 | originator of the Contribution. 100 | 101 | 4. COMMERCIAL DISTRIBUTION 102 | 103 | Commercial distributors of software may accept certain responsibilities with 104 | respect to end users, business partners and the like. While this license is 105 | intended to facilitate the commercial use of the Program, the Contributor who 106 | includes the Program in a commercial product offering should do so in a manner 107 | which does not create potential liability for other Contributors. Therefore, 108 | if a Contributor includes the Program in a commercial product offering, such 109 | Contributor ("Commercial Contributor") hereby agrees to defend and indemnify 110 | every other Contributor ("Indemnified Contributor") against any losses, 111 | damages and costs (collectively "Losses") arising from claims, lawsuits and 112 | other legal actions brought by a third party against the Indemnified 113 | Contributor to the extent caused by the acts or omissions of such Commercial 114 | Contributor in connection with its distribution of the Program in a commercial 115 | product offering. The obligations in this section do not apply to any claims 116 | or Losses relating to any actual or alleged intellectual property 117 | infringement. In order to qualify, an Indemnified Contributor must: 118 | a) promptly notify the Commercial Contributor in writing of such claim, and 119 | b) allow the Commercial Contributor to control, and cooperate with the 120 | Commercial Contributor in, the defense and any related settlement 121 | negotiations. The Indemnified Contributor may participate in any such claim at 122 | its own expense. 123 | 124 | For example, a Contributor might include the Program in a commercial product 125 | offering, Product X. That Contributor is then a Commercial Contributor. If 126 | that Commercial Contributor then makes performance claims, or offers 127 | warranties related to Product X, those performance claims and warranties are 128 | such Commercial Contributor's responsibility alone. Under this section, the 129 | Commercial Contributor would have to defend claims against the other 130 | Contributors related to those performance claims and warranties, and if a 131 | court requires any other Contributor to pay any damages as a result, the 132 | Commercial Contributor must pay those damages. 133 | 134 | 5. NO WARRANTY 135 | 136 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON AN 137 | "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR 138 | IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF TITLE, 139 | NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Each 140 | Recipient is solely responsible for determining the appropriateness of using 141 | and distributing the Program and assumes all risks associated with its 142 | exercise of rights under this Agreement , including but not limited to the 143 | risks and costs of program errors, compliance with applicable laws, damage to 144 | or loss of data, programs or equipment, and unavailability or interruption of 145 | operations. 146 | 147 | 6. DISCLAIMER OF LIABILITY 148 | 149 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY 150 | CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, 151 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION 152 | LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 153 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 154 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 155 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY 156 | OF SUCH DAMAGES. 157 | 158 | 7. GENERAL 159 | 160 | If any provision of this Agreement is invalid or unenforceable under 161 | applicable law, it shall not affect the validity or enforceability of the 162 | remainder of the terms of this Agreement, and without further action by the 163 | parties hereto, such provision shall be reformed to the minimum extent 164 | necessary to make such provision valid and enforceable. 165 | 166 | If Recipient institutes patent litigation against any entity (including a 167 | cross-claim or counterclaim in a lawsuit) alleging that the Program itself 168 | (excluding combinations of the Program with other software or hardware) 169 | infringes such Recipient's patent(s), then such Recipient's rights granted 170 | under Section 2(b) shall terminate as of the date such litigation is filed. 171 | 172 | All Recipient's rights under this Agreement shall terminate if it fails to 173 | comply with any of the material terms or conditions of this Agreement and does 174 | not cure such failure in a reasonable period of time after becoming aware of 175 | such noncompliance. If all Recipient's rights under this Agreement terminate, 176 | Recipient agrees to cease use and distribution of the Program as soon as 177 | reasonably practicable. However, Recipient's obligations under this Agreement 178 | and any licenses granted by Recipient relating to the Program shall continue 179 | and survive. 180 | 181 | Everyone is permitted to copy and distribute copies of this Agreement, but in 182 | order to avoid inconsistency the Agreement is copyrighted and may only be 183 | modified in the following manner. The Agreement Steward reserves the right to 184 | publish new versions (including revisions) of this Agreement from time to 185 | time. No one other than the Agreement Steward has the right to modify this 186 | Agreement. The Eclipse Foundation is the initial Agreement Steward. The 187 | Eclipse Foundation may assign the responsibility to serve as the Agreement 188 | Steward to a suitable separate entity. Each new version of the Agreement will 189 | be given a distinguishing version number. The Program (including 190 | Contributions) may always be distributed subject to the version of the 191 | Agreement under which it was received. In addition, after a new version of the 192 | Agreement is published, Contributor may elect to distribute the Program 193 | (including its Contributions) under the new version. Except as expressly 194 | stated in Sections 2(a) and 2(b) above, Recipient receives no rights or 195 | licenses to the intellectual property of any Contributor under this Agreement, 196 | whether expressly, by implication, estoppel or otherwise. All rights in the 197 | Program not expressly granted under this Agreement are reserved. 198 | 199 | This Agreement is governed by the laws of the State of New York and the 200 | intellectual property laws of the United States of America. No party to this 201 | Agreement will bring a legal action under this Agreement more than one year 202 | after the cause of action arose. Each party waives its rights to a jury trial in 203 | any resulting litigation. 204 | 205 | -------------------------------------------------------------------------------- /epl.html: -------------------------------------------------------------------------------- 1 | Eclipse Public License - v 1.0 2 | 3 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC 4 | LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM 5 | CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 6 | 7 | 1. DEFINITIONS 8 | 9 | "Contribution" means: 10 | 11 | a) in the case of the initial Contributor, the initial code and documentation 12 | distributed under this Agreement, and 13 | b) in the case of each subsequent Contributor: 14 | i) changes to the Program, and 15 | ii) additions to the Program; 16 | 17 | where such changes and/or additions to the Program originate from and are 18 | distributed by that particular Contributor. A Contribution 'originates' 19 | from a Contributor if it was added to the Program by such Contributor 20 | itself or anyone acting on such Contributor's behalf. Contributions do not 21 | include additions to the Program which: (i) are separate modules of 22 | software distributed in conjunction with the Program under their own 23 | license agreement, and (ii) are not derivative works of the Program. 24 | 25 | "Contributor" means any person or entity that distributes the Program. 26 | 27 | "Licensed Patents" mean patent claims licensable by a Contributor which are 28 | necessarily infringed by the use or sale of its Contribution alone or when 29 | combined with the Program. 30 | 31 | "Program" means the Contributions distributed in accordance with this 32 | Agreement. 33 | 34 | "Recipient" means anyone who receives the Program under this Agreement, 35 | including all Contributors. 36 | 37 | 2. GRANT OF RIGHTS 38 | a) Subject to the terms of this Agreement, each Contributor hereby grants 39 | Recipient a non-exclusive, worldwide, royalty-free copyright license to 40 | reproduce, prepare derivative works of, publicly display, publicly 41 | perform, distribute and sublicense the Contribution of such Contributor, 42 | if any, and such derivative works, in source code and object code form. 43 | b) Subject to the terms of this Agreement, each Contributor hereby grants 44 | Recipient a non-exclusive, worldwide, royalty-free patent license under 45 | Licensed Patents to make, use, sell, offer to sell, import and otherwise 46 | transfer the Contribution of such Contributor, if any, in source code and 47 | object code form. This patent license shall apply to the combination of 48 | the Contribution and the Program if, at the time the Contribution is 49 | added by the Contributor, such addition of the Contribution causes such 50 | combination to be covered by the Licensed Patents. The patent license 51 | shall not apply to any other combinations which include the Contribution. 52 | No hardware per se is licensed hereunder. 53 | c) Recipient understands that although each Contributor grants the licenses 54 | to its Contributions set forth herein, no assurances are provided by any 55 | Contributor that the Program does not infringe the patent or other 56 | intellectual property rights of any other entity. Each Contributor 57 | disclaims any liability to Recipient for claims brought by any other 58 | entity based on infringement of intellectual property rights or 59 | otherwise. As a condition to exercising the rights and licenses granted 60 | hereunder, each Recipient hereby assumes sole responsibility to secure 61 | any other intellectual property rights needed, if any. For example, if a 62 | third party patent license is required to allow Recipient to distribute 63 | the Program, it is Recipient's responsibility to acquire that license 64 | before distributing the Program. 65 | d) Each Contributor represents that to its knowledge it has sufficient 66 | copyright rights in its Contribution, if any, to grant the copyright 67 | license set forth in this Agreement. 68 | 69 | 3. REQUIREMENTS 70 | 71 | A Contributor may choose to distribute the Program in object code form under 72 | its own license agreement, provided that: 73 | 74 | a) it complies with the terms and conditions of this Agreement; and 75 | b) its license agreement: 76 | i) effectively disclaims on behalf of all Contributors all warranties 77 | and conditions, express and implied, including warranties or 78 | conditions of title and non-infringement, and implied warranties or 79 | conditions of merchantability and fitness for a particular purpose; 80 | ii) effectively excludes on behalf of all Contributors all liability for 81 | damages, including direct, indirect, special, incidental and 82 | consequential damages, such as lost profits; 83 | iii) states that any provisions which differ from this Agreement are 84 | offered by that Contributor alone and not by any other party; and 85 | iv) states that source code for the Program is available from such 86 | Contributor, and informs licensees how to obtain it in a reasonable 87 | manner on or through a medium customarily used for software exchange. 88 | 89 | When the Program is made available in source code form: 90 | 91 | a) it must be made available under this Agreement; and 92 | b) a copy of this Agreement must be included with each copy of the Program. 93 | Contributors may not remove or alter any copyright notices contained 94 | within the Program. 95 | 96 | Each Contributor must identify itself as the originator of its Contribution, 97 | if 98 | any, in a manner that reasonably allows subsequent Recipients to identify the 99 | originator of the Contribution. 100 | 101 | 4. COMMERCIAL DISTRIBUTION 102 | 103 | Commercial distributors of software may accept certain responsibilities with 104 | respect to end users, business partners and the like. While this license is 105 | intended to facilitate the commercial use of the Program, the Contributor who 106 | includes the Program in a commercial product offering should do so in a manner 107 | which does not create potential liability for other Contributors. Therefore, 108 | if a Contributor includes the Program in a commercial product offering, such 109 | Contributor ("Commercial Contributor") hereby agrees to defend and indemnify 110 | every other Contributor ("Indemnified Contributor") against any losses, 111 | damages and costs (collectively "Losses") arising from claims, lawsuits and 112 | other legal actions brought by a third party against the Indemnified 113 | Contributor to the extent caused by the acts or omissions of such Commercial 114 | Contributor in connection with its distribution of the Program in a commercial 115 | product offering. The obligations in this section do not apply to any claims 116 | or Losses relating to any actual or alleged intellectual property 117 | infringement. In order to qualify, an Indemnified Contributor must: 118 | a) promptly notify the Commercial Contributor in writing of such claim, and 119 | b) allow the Commercial Contributor to control, and cooperate with the 120 | Commercial Contributor in, the defense and any related settlement 121 | negotiations. The Indemnified Contributor may participate in any such claim at 122 | its own expense. 123 | 124 | For example, a Contributor might include the Program in a commercial product 125 | offering, Product X. That Contributor is then a Commercial Contributor. If 126 | that Commercial Contributor then makes performance claims, or offers 127 | warranties related to Product X, those performance claims and warranties are 128 | such Commercial Contributor's responsibility alone. Under this section, the 129 | Commercial Contributor would have to defend claims against the other 130 | Contributors related to those performance claims and warranties, and if a 131 | court requires any other Contributor to pay any damages as a result, the 132 | Commercial Contributor must pay those damages. 133 | 134 | 5. NO WARRANTY 135 | 136 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON AN 137 | "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR 138 | IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF TITLE, 139 | NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Each 140 | Recipient is solely responsible for determining the appropriateness of using 141 | and distributing the Program and assumes all risks associated with its 142 | exercise of rights under this Agreement , including but not limited to the 143 | risks and costs of program errors, compliance with applicable laws, damage to 144 | or loss of data, programs or equipment, and unavailability or interruption of 145 | operations. 146 | 147 | 6. DISCLAIMER OF LIABILITY 148 | 149 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY 150 | CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, 151 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION 152 | LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 153 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 154 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 155 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY 156 | OF SUCH DAMAGES. 157 | 158 | 7. GENERAL 159 | 160 | If any provision of this Agreement is invalid or unenforceable under 161 | applicable law, it shall not affect the validity or enforceability of the 162 | remainder of the terms of this Agreement, and without further action by the 163 | parties hereto, such provision shall be reformed to the minimum extent 164 | necessary to make such provision valid and enforceable. 165 | 166 | If Recipient institutes patent litigation against any entity (including a 167 | cross-claim or counterclaim in a lawsuit) alleging that the Program itself 168 | (excluding combinations of the Program with other software or hardware) 169 | infringes such Recipient's patent(s), then such Recipient's rights granted 170 | under Section 2(b) shall terminate as of the date such litigation is filed. 171 | 172 | All Recipient's rights under this Agreement shall terminate if it fails to 173 | comply with any of the material terms or conditions of this Agreement and does 174 | not cure such failure in a reasonable period of time after becoming aware of 175 | such noncompliance. If all Recipient's rights under this Agreement terminate, 176 | Recipient agrees to cease use and distribution of the Program as soon as 177 | reasonably practicable. However, Recipient's obligations under this Agreement 178 | and any licenses granted by Recipient relating to the Program shall continue 179 | and survive. 180 | 181 | Everyone is permitted to copy and distribute copies of this Agreement, but in 182 | order to avoid inconsistency the Agreement is copyrighted and may only be 183 | modified in the following manner. The Agreement Steward reserves the right to 184 | publish new versions (including revisions) of this Agreement from time to 185 | time. No one other than the Agreement Steward has the right to modify this 186 | Agreement. The Eclipse Foundation is the initial Agreement Steward. The 187 | Eclipse Foundation may assign the responsibility to serve as the Agreement 188 | Steward to a suitable separate entity. Each new version of the Agreement will 189 | be given a distinguishing version number. The Program (including 190 | Contributions) may always be distributed subject to the version of the 191 | Agreement under which it was received. In addition, after a new version of the 192 | Agreement is published, Contributor may elect to distribute the Program 193 | (including its Contributions) under the new version. Except as expressly 194 | stated in Sections 2(a) and 2(b) above, Recipient receives no rights or 195 | licenses to the intellectual property of any Contributor under this Agreement, 196 | whether expressly, by implication, estoppel or otherwise. All rights in the 197 | Program not expressly granted under this Agreement are reserved. 198 | 199 | This Agreement is governed by the laws of the State of New York and the 200 | intellectual property laws of the United States of America. No party to this 201 | Agreement will bring a legal action under this Agreement more than one year 202 | after the cause of action arose. Each party waives its rights to a jury trial in 203 | any resulting litigation. 204 | 205 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/async_test.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.async-test 2 | (:refer-clojure :exclude [map into reduce transduce merge take partition partition-by]) 3 | (:require [clojure.core.async.impl.buffers :as b] 4 | [clojure.core.async :refer :all :as a] 5 | [clojure.test :refer :all])) 6 | 7 | 8 | (defn default-chan [] 9 | (chan 1)) 10 | 11 | (deftest buffers-tests 12 | (is (not (unblocking-buffer? (buffer 1)))) 13 | (is (unblocking-buffer? (dropping-buffer 1))) 14 | (is (unblocking-buffer? (sliding-buffer 1))) 15 | (is (unblocking-buffer? (b/promise-buffer)))) 16 | 17 | (deftest basic-channel-test 18 | (let [c (default-chan) 19 | f (future (!! c 42) 21 | (is (= @f 42)))) 22 | 23 | (def DEREF_WAIT 20) 24 | 25 | (deftest writes-block-on-full-buffer 26 | (let [c (default-chan) 27 | _ (>!! c 42) 28 | blocking (deref (future (>!! c 43)) DEREF_WAIT :blocked)] 29 | (is (= blocking :blocked)))) 30 | 31 | (deftest unfulfilled-readers-block 32 | (let [c (default-chan) 33 | r1 (future (!! c 42) 36 | r1v (deref r1 DEREF_WAIT :blocked) 37 | r2v (deref r2 DEREF_WAIT :blocked)] 38 | (is (and (or (= r1v :blocked) (= r2v :blocked)) 39 | (or (= 42 r1v) (= 42 r2v)))))) 40 | 41 | (deftest test-!!-and-take! 52 | (is (= :test-val (let [read-promise (promise) 53 | test-channel (chan nil)] 54 | (take! test-channel #(deliver read-promise %)) 55 | (is (not (realized? read-promise)) 56 | "The read waits until a writer provides a value.") 57 | (>!! test-channel :test-val) 58 | (deref read-promise 1000 false))) 59 | "The written value is the value provided to the read callback.")) 60 | 61 | (deftest take!-on-caller? 62 | (is (apply = (let [starting-thread (System.Threading.Thread/CurrentThread) ;;; (Thread/currentThread) 63 | test-channel (chan nil) 64 | read-promise (promise)] 65 | (take! test-channel (fn [_] (deliver read-promise (System.Threading.Thread/CurrentThread))) true) ;;; (Thread/currentThread) 66 | (>!! test-channel :foo) 67 | [starting-thread @read-promise])) 68 | "When on-caller? requested, but no value is immediately 69 | available, take!'s callback executes on putter's thread.") 70 | (is (apply = (let [starting-thread (System.Threading.Thread/CurrentThread) ;;; (Thread/currentThread) 71 | test-channel (chan nil) 72 | read-promise (promise)] 73 | (put! test-channel :foo (constantly nil)) 74 | (take! test-channel (fn [_] (deliver read-promise (System.Threading.Thread/CurrentThread))) true) ;;; (Thread/currentThread) 75 | [starting-thread @read-promise])) 76 | "When on-caller? requested, and a value is ready to read, 77 | take!'s callback executes on the same thread.") 78 | (is (apply not= (let [starting-thread (System.Threading.Thread/CurrentThread) ;;; (Thread/currentThread) 79 | test-channel (chan nil) 80 | read-promise (promise)] 81 | (put! test-channel :foo (constantly nil)) 82 | (take! test-channel (fn [_] (deliver read-promise (System.Threading.Thread/CurrentThread))) false) ;;; (Thread/currentThread) 83 | [starting-thread @read-promise])) 84 | "When on-caller? is false, and a value is ready to read, 85 | take!'s callback executes on a different thread.")) 86 | 87 | (deftest put!-on-caller? 88 | (is (apply = (let [starting-thread (System.Threading.Thread/CurrentThread) ;;; (Thread/currentThread) 89 | test-channel (chan nil) 90 | write-promise (promise)] 91 | (take! test-channel (fn [_] nil)) 92 | (put! test-channel :foo (fn [_] (deliver write-promise (System.Threading.Thread/CurrentThread))) true) ;;; (Thread/currentThread) 93 | [starting-thread @write-promise])) 94 | "When on-caller? requested, and a reader can consume the value, 95 | put!'s callback executes on the same thread.") 96 | (is (apply not= (let [starting-thread (System.Threading.Thread/CurrentThread) ;;; (Thread/currentThread) 97 | test-channel (chan nil) 98 | write-promise (promise)] 99 | (take! test-channel (fn [_] nil)) 100 | (put! test-channel :foo (fn [_] (deliver write-promise (System.Threading.Thread/CurrentThread))) false) ;;; (Thread/currentThread) 101 | [starting-thread @write-promise])) 102 | "When on-caller? is false, but a reader can consume the value, 103 | put!'s callback executes on a different thread.") 104 | (is (apply = (let [starting-thread (System.Threading.Thread/CurrentThread) ;;; (Thread/currentThread) 105 | test-channel (chan nil) 106 | write-promise (promise)] 107 | (put! test-channel :foo (fn [_] (deliver write-promise (System.Threading.Thread/CurrentThread))) true) ;;; (Thread/currentThread) 108 | (take! test-channel (fn [_] nil)) 109 | [starting-thread @write-promise])) 110 | "When on-caller? requested, but no reader can consume the value, 111 | put!'s callback executes on a taker's thread.")) 112 | 113 | 114 | (deftest limit-async-take!-put! 115 | (testing "async put! limit" 116 | (let [c (chan)] 117 | (dotimes [x 1024] 118 | (put! c x)) 119 | (is (thrown? InvalidOperationException ;;; AssertionError 120 | (put! c 42))) 121 | (is (= (!! c 42)))))) ;; make sure the channel unlocks 129 | 130 | (deftest puts-fulfill-when-buffer-available 131 | (is (= :proceeded 132 | (let [c (chan 1) 133 | p (promise)] 134 | (>!! c :full) ;; fill up the channel 135 | (put! c :enqueues (fn [_] (deliver p :proceeded))) ;; enqueue a put 136 | (!! c :val) 157 | (is (= :val (!! c :LOST) 160 | (is (= :val (!! c :val) ;; deliver 177 | (is (= :val (" 194 | (is (= [2 3 4 5] 195 | (let [out (chan) 196 | in (a/map> inc out)] 197 | (a/onto-chan! in [1 2 3 4]) 198 | (" 226 | (is (= [2 4 6] 227 | (let [out (chan) 228 | in (filter> even? out)] 229 | (a/onto-chan! in [1 2 3 4 5 6]) 230 | (" 232 | (is (= [1 3 5] 233 | (let [out (chan) 234 | in (remove> even? out)] 235 | (a/onto-chan! in [1 2 3 4 5 6]) 236 | (" 242 | (is (= [0 0 1 0 1 2] 243 | (let [out (chan) 244 | in (mapcat> range out)] 245 | (a/onto-chan! in [1 2 3]) 246 | ( [1 1 2 2 3 3] 374 | (defn xerox [n] 375 | (fn [f1] 376 | (fn 377 | ([] (f1)) 378 | ([result] (f1 result)) 379 | ([result input] 380 | (loop [res result 381 | i n] 382 | (if (pos? i) 383 | (let [a (f1 result input)] 384 | (if (reduced? a) 385 | a 386 | (recur a (dec i)))) 387 | res)))))) 388 | 389 | (defn check-expanding-transducer [buffer-size in multiplier takers] 390 | (let [input (range in) 391 | xf (xerox multiplier) 392 | expected (apply interleave (repeat multiplier input)) 393 | counter (atom 0) 394 | res (atom []) 395 | c (chan buffer-size xf)] 396 | (dotimes [x takers] 397 | (take! c #(do 398 | (when (some? %) (swap! res conj %)) 399 | (swap! counter inc)))) 400 | (onto-chan! c input) 401 | 402 | ;; wait for all takers to report 403 | (while (< @counter takers) 404 | (System.Threading.Thread/Sleep 50)) ;;; Thread/sleep 405 | 406 | ;; check expected results 407 | (is (= (sort (clojure.core/take takers expected)) 408 | (sort @res))))) 409 | 410 | (deftest expanding-transducer-delivers-to-multiple-pending 411 | (doseq [b (range 1 10) 412 | t (range 1 10)] 413 | (check-expanding-transducer b 3 3 t))) 414 | 415 | (deftest expanding-transducer-puts-can-ignore-buffer-fullness 416 | (testing "non-blocking puts behave as expected" 417 | ;; put coll, expanding xf, 418 | (let [c (chan 1 (mapcat identity))] 419 | (is (true? (>!! c [1 2 3]))) 420 | (is (= 1 (!! c [1 2 3]))) 429 | (is (= 1 (!! c [4 5 6])] 433 | (swap! counter inc) 434 | r))] 435 | (is (= 0 @counter)) 436 | (is (= 2 (! c (! c :foo) 42)] 389 | [(!! c :foo) 395 | (! c :foo) 401 | (>! c :bar) 402 | (>! c :baz) 403 | 404 | (>! c :boz) 405 | ( ast :env :locals vals)) 199 | :when (contains? locals local)] 200 | (get locals local))) 201 | (writes-to [this] [(:id this)]) 202 | (block-references [_this] []) 203 | IEmittableInstruction 204 | (emit-instruction [this _state-sym] 205 | (if (not-empty (reads-from this)) 206 | `[~@(into [] 207 | (comp 208 | (map #(select-keys % [:op :name :form])) 209 | (filter (fn [local] 210 | (contains? locals (:name local)))) 211 | (distinct) 212 | (mapcat 213 | (fn [local] 214 | `[~(:form local) ~(get locals (:name local))]))) 215 | (-> ast :env :locals vals)) 216 | ~(:id this) ~(:form ast)] 217 | `[~(:id this) ~(:form ast)]))) 218 | 219 | (defrecord CustomTerminator [f blk values meta] 220 | IInstruction 221 | (reads-from [_this] values) 222 | (writes-to [_this] []) 223 | (block-references [_this] []) 224 | ITerminator 225 | (terminate-block [_this state-sym _] 226 | (with-meta `(~f ~state-sym ~blk ~@values) 227 | meta))) 228 | 229 | (defn- emit-clashing-binds 230 | [recur-nodes ids clashes] 231 | (let [temp-binds (reduce 232 | (fn [acc i] 233 | (assoc acc i (gensym "tmp"))) 234 | {} clashes)] 235 | (concat 236 | (mapcat (fn [i] 237 | `[~(temp-binds i) ~i]) 238 | clashes) 239 | (mapcat (fn [node id] 240 | `[~node ~(get temp-binds id id)]) 241 | recur-nodes 242 | ids)))) 243 | 244 | (defrecord Recur [recur-nodes ids] 245 | IInstruction 246 | (reads-from [_this] ids) 247 | (writes-to [_this] recur-nodes) 248 | (block-references [_this] []) 249 | IEmittableInstruction 250 | (emit-instruction [_this _state-sym] 251 | (if-let [overlap (seq (set/intersection (set recur-nodes) (set ids)))] 252 | (emit-clashing-binds recur-nodes ids overlap) 253 | (mapcat (fn [r i] 254 | `[~r ~i]) recur-nodes ids)))) 255 | 256 | (defrecord Call [refs] 257 | IInstruction 258 | (reads-from [_this] refs) 259 | (writes-to [this] [(:id this)]) 260 | (block-references [_this] []) 261 | IEmittableInstruction 262 | (emit-instruction [this _state-sym] 263 | `[~(:id this) ~(seq refs)])) 264 | 265 | (defrecord StaticCall [class method refs] 266 | IInstruction 267 | (reads-from [_this] refs) 268 | (writes-to [this] [(:id this)]) 269 | (block-references [_this] []) 270 | IEmittableInstruction 271 | (emit-instruction [this _state-sym] 272 | `[~(:id this) (. ~class ~method ~@(seq refs))])) 273 | 274 | (defrecord InstanceInterop [instance-id op refs] 275 | IInstruction 276 | (reads-from [_this] (cons instance-id refs)) 277 | (writes-to [this] [(:id this)]) 278 | (block-references [_this] []) 279 | IEmittableInstruction 280 | (emit-instruction [this _state-sym] 281 | `[~(:id this) (. ~instance-id ~op ~@(seq refs))])) 282 | 283 | (defrecord Case [val-id test-vals jmp-blocks default-block] 284 | IInstruction 285 | (reads-from [_this] [val-id]) 286 | (writes-to [_this] []) 287 | (block-references [_this] []) 288 | ITerminator 289 | (terminate-block [_this state-sym _] 290 | `(do (case ~val-id 291 | ~@(concat (mapcat (fn [test blk] 292 | `[~test (rt/aset-all! ~state-sym ~rt/STATE-IDX ~blk)]) 293 | test-vals jmp-blocks) 294 | (when default-block 295 | `[(do (rt/aset-all! ~state-sym ~rt/STATE-IDX ~default-block) 296 | :recur)]))) 297 | :recur))) 298 | 299 | (defrecord Fn [fn-expr local-names local-refs] 300 | IInstruction 301 | (reads-from [_this] local-refs) 302 | (writes-to [this] [(:id this)]) 303 | (block-references [_this] []) 304 | IEmittableInstruction 305 | (emit-instruction [this _state-sym] 306 | `[~(:id this) 307 | (let [~@(interleave local-names local-refs)] 308 | ~@fn-expr)])) 309 | 310 | (defrecord Dot [cls-or-instance method args] 311 | IInstruction 312 | (reads-from [_this] `[~cls-or-instance ~method ~@args]) 313 | (writes-to [this] [(:id this)]) 314 | (block-references [_this] []) 315 | IEmittableInstruction 316 | (emit-instruction [this _state-sym] 317 | `[~(:id this) (. ~cls-or-instance ~method ~@args)])) 318 | 319 | (defrecord Jmp [value block] 320 | IInstruction 321 | (reads-from [_this] [value]) 322 | (writes-to [_this] []) 323 | (block-references [_this] [block]) 324 | ITerminator 325 | (terminate-block [_this state-sym _] 326 | `(do (rt/aset-all! ~state-sym ~rt/VALUE-IDX ~value ~rt/STATE-IDX ~block) 327 | :recur))) 328 | 329 | (defrecord Return [value] 330 | IInstruction 331 | (reads-from [_this] [value]) 332 | (writes-to [_this] []) 333 | (block-references [_this] []) 334 | ITerminator 335 | (terminator-code [_this] :Return) 336 | (terminate-block [this state-sym custom-terminators] 337 | (if-let [f (get custom-terminators (terminator-code this))] 338 | `(~f ~state-sym ~value) 339 | `(do (rt/aset-all! ~state-sym ~rt/VALUE-IDX ~value ~rt/STATE-IDX ::finished) 340 | nil)))) 341 | 342 | (defrecord CondBr [test then-block else-block] 343 | IInstruction 344 | (reads-from [_this] [test]) 345 | (writes-to [_this] []) 346 | (block-references [_this] [then-block else-block]) 347 | ITerminator 348 | (terminate-block [_this state-sym _] 349 | `(do (if ~test 350 | (rt/aset-all! ~state-sym ~rt/STATE-IDX ~then-block) 351 | (rt/aset-all! ~state-sym ~rt/STATE-IDX ~else-block)) 352 | :recur))) 353 | 354 | (defrecord PushTry [catch-block] 355 | IInstruction 356 | (reads-from [_this] []) 357 | (writes-to [_this] []) 358 | (block-references [_this] [catch-block]) 359 | IEmittableInstruction 360 | (emit-instruction [_this state-sym] 361 | `[~'_ (rt/aset-all! ~state-sym ~rt/EXCEPTION-FRAMES (cons ~catch-block (rt/aget-object ~state-sym ~rt/EXCEPTION-FRAMES)))])) 362 | 363 | (defrecord PopTry [] 364 | IInstruction 365 | (reads-from [_this] []) 366 | (writes-to [_this] []) 367 | (block-references [_this] []) 368 | IEmittableInstruction 369 | (emit-instruction [_this state-sym] 370 | `[~'_ (rt/aset-all! ~state-sym ~rt/EXCEPTION-FRAMES (rest (rt/aget-object ~state-sym ~rt/EXCEPTION-FRAMES)))])) 371 | 372 | (defrecord CatchHandler [catches] 373 | IInstruction 374 | (reads-from [_this] []) 375 | (writes-to [_this] []) 376 | (block-references [_this] (map first catches)) 377 | ITerminator 378 | (terminate-block [_this state-sym _] 379 | (let [ex (gensym 'ex)] 380 | `(let [~ex (rt/aget-object ~state-sym ~rt/VALUE-IDX)] 381 | (cond 382 | ~@(for [[handler-idx type] catches 383 | i [`(instance? ~type ~ex) `(rt/aset-all! ~state-sym ~rt/STATE-IDX ~handler-idx)]] 384 | i) 385 | :else (throw ~ex)) 386 | :recur)))) 387 | 388 | (defrecord EndFinally [exception-local] 389 | IInstruction 390 | (reads-from [_this] [exception-local]) 391 | (writes-to [_this] []) 392 | (block-references [_this] []) 393 | IEmittableInstruction 394 | (emit-instruction [_this _state-sym] 395 | `[~'_ (throw ~exception-local)])) 396 | 397 | ;; Dispatch clojure forms based on :op 398 | (def -item-to-ssa nil) ;; for help in the repl 399 | (defmulti -item-to-ssa :op) 400 | 401 | (defmethod -item-to-ssa :default 402 | [ast] 403 | (gen-plan 404 | [locals (get-binding :locals) 405 | id (add-instruction (->RawCode ast locals))] 406 | id)) 407 | 408 | (defn item-to-ssa [ast] 409 | (if (or (::transform? ast) 410 | (contains? #{:local :const :quote} (:op ast))) 411 | (-item-to-ssa ast) 412 | (gen-plan 413 | [locals (get-binding :locals) 414 | id (add-instruction (->RawCode ast locals))] 415 | id))) 416 | 417 | (defmethod -item-to-ssa :invoke 418 | [{f :fn args :args}] 419 | (gen-plan 420 | [arg-ids (all (map item-to-ssa (cons f args))) 421 | inst-id (add-instruction (->Call arg-ids))] 422 | inst-id)) 423 | 424 | (defmethod -item-to-ssa :keyword-invoke 425 | [{f :keyword target :target}] 426 | (gen-plan 427 | [arg-ids (all (map item-to-ssa (list f target))) 428 | inst-id (add-instruction (->Call arg-ids))] 429 | inst-id)) 430 | 431 | (defmethod -item-to-ssa :protocol-invoke 432 | [{f :protocol-fn target :target args :args}] 433 | (gen-plan 434 | [arg-ids (all (map item-to-ssa (list* f target args))) 435 | inst-id (add-instruction (->Call arg-ids))] 436 | inst-id)) 437 | 438 | (defmethod -item-to-ssa :instance? 439 | [{:keys [class target]}] 440 | (gen-plan 441 | [arg-id (item-to-ssa target) 442 | inst-id (add-instruction (->Call (list `instance? class arg-id)))] 443 | inst-id)) 444 | 445 | (defmethod -item-to-ssa :prim-invoke 446 | [{f :fn args :args}] 447 | (gen-plan 448 | [arg-ids (all (map item-to-ssa (cons f args))) 449 | inst-id (add-instruction (->Call arg-ids))] 450 | inst-id)) 451 | 452 | (defmethod -item-to-ssa :instance-call 453 | [{:keys [instance method args]}] 454 | (gen-plan 455 | [arg-ids (all (map item-to-ssa args)) 456 | instance-id (item-to-ssa instance) 457 | inst-id (add-instruction (->InstanceInterop instance-id method arg-ids))] 458 | inst-id)) 459 | 460 | (defmethod -item-to-ssa :instance-field 461 | [{:keys [instance field]}] 462 | (gen-plan 463 | [instance-id (item-to-ssa instance) 464 | inst-id (add-instruction (->InstanceInterop instance-id (symbol (str "-" field)) ()))] 465 | inst-id)) 466 | 467 | (defmethod -item-to-ssa :host-interop 468 | [{:keys [target m-or-f]}] 469 | (gen-plan 470 | [instance-id (item-to-ssa target) 471 | inst-id (add-instruction (->InstanceInterop instance-id m-or-f ()))] 472 | inst-id)) 473 | 474 | (defmethod -item-to-ssa :static-call 475 | [{:keys [class method args]}] 476 | (gen-plan 477 | [arg-ids (all (map item-to-ssa args)) 478 | inst-id (add-instruction (->StaticCall class method arg-ids))] 479 | inst-id)) 480 | 481 | (defmethod -item-to-ssa :set! 482 | [{:keys [val target]}] 483 | (gen-plan 484 | [arg-ids (all (map item-to-ssa (list target val))) 485 | inst-id (add-instruction (->Call (cons 'set! arg-ids)))] 486 | inst-id)) 487 | 488 | (defn var-name [v] 489 | (let [nm (:name (meta v)) 490 | nsp (.getName ^clojure.lang.Namespace (:ns (meta v)))] 491 | (symbol (name nsp) (name nm)))) 492 | 493 | 494 | (defmethod -item-to-ssa :var 495 | [{:keys [var]}] 496 | (gen-plan 497 | [] 498 | (var-name var))) 499 | 500 | (defmethod -item-to-ssa :const 501 | [{:keys [form]}] 502 | (gen-plan 503 | [] 504 | form)) 505 | 506 | (defn let-binding-to-ssa 507 | [{:keys [name init form]}] 508 | (gen-plan 509 | [bind-id (item-to-ssa init) 510 | _ (push-alter-binding :locals assoc (vary-meta name merge (meta form)) bind-id)] 511 | bind-id)) 512 | 513 | (defmethod -item-to-ssa :let 514 | [{:keys [bindings body]}] 515 | (gen-plan 516 | [let-ids (all (map let-binding-to-ssa bindings)) 517 | _ (all (map (fn [_] (pop-binding :locals)) bindings)) 518 | 519 | local-ids (all (map (comp add-instruction ->Const) let-ids)) 520 | _ (push-alter-binding :locals merge (into {} (map (fn [id {:keys [name form]}] 521 | [name (vary-meta id merge (meta form))]) 522 | local-ids bindings))) 523 | 524 | body-id (item-to-ssa body) 525 | _ (pop-binding :locals)] 526 | body-id)) 527 | 528 | (defmethod -item-to-ssa :loop 529 | [{:keys [body bindings] :as ast}] 530 | (gen-plan 531 | [local-val-ids (all (map let-binding-to-ssa bindings)) 532 | _ (all (for [_ bindings] 533 | (pop-binding :locals))) 534 | local-ids (all (map (comp add-instruction ->Const) local-val-ids)) 535 | body-blk (add-block) 536 | final-blk (add-block) 537 | _ (add-instruction (->Jmp nil body-blk)) 538 | 539 | _ (set-block body-blk) 540 | _ (push-alter-binding :locals merge (into {} (map (fn [id {:keys [name form]}] 541 | [name (vary-meta id merge (meta form))]) 542 | local-ids bindings))) 543 | _ (push-binding :recur-point body-blk) 544 | _ (push-binding :recur-nodes local-ids) 545 | 546 | ret-id (item-to-ssa body) 547 | 548 | _ (pop-binding :recur-nodes) 549 | _ (pop-binding :recur-point) 550 | _ (pop-binding :locals) 551 | _ (if (not= ret-id ::terminated) 552 | (add-instruction (->Jmp ret-id final-blk)) 553 | (no-op)) 554 | _ (set-block final-blk) 555 | ret-id (add-instruction (->Const ::value))] 556 | ret-id)) 557 | 558 | (defmethod -item-to-ssa :do 559 | [{:keys [statements ret] :as _ast}] 560 | (gen-plan 561 | [_ (all (map item-to-ssa statements)) 562 | ret-id (item-to-ssa ret)] 563 | ret-id)) 564 | 565 | (defmethod -item-to-ssa :case 566 | [{:keys [test tests thens default] :as _ast}] 567 | (gen-plan 568 | [end-blk (add-block) 569 | start-blk (get-block) 570 | clause-blocks (all (map (fn [expr] 571 | (assert expr) 572 | (gen-plan 573 | [blk-id (add-block) 574 | _ (set-block blk-id) 575 | expr-id (item-to-ssa expr) 576 | _ (if (not= expr-id ::terminated) 577 | (add-instruction (->Jmp expr-id end-blk)) 578 | (no-op))] 579 | blk-id)) 580 | (map :then thens))) 581 | default-block (if default 582 | (gen-plan 583 | [blk-id (add-block) 584 | _ (set-block blk-id) 585 | expr-id (item-to-ssa default) 586 | _ (if (not= expr-id ::terminated) 587 | (add-instruction (->Jmp expr-id end-blk)) 588 | (no-op))] 589 | blk-id) 590 | (no-op)) 591 | _ (set-block start-blk) 592 | val-id (item-to-ssa test) 593 | case-id (add-instruction (->Case val-id (map (comp :form :test) tests) 594 | clause-blocks 595 | default-block)) 596 | _ (set-block end-blk) 597 | ret-id (add-instruction (->Const ::value))] 598 | ret-id)) 599 | 600 | (defmethod -item-to-ssa :quote 601 | [{:keys [form]}] 602 | (gen-plan 603 | [ret-id (add-instruction (->Const form))] 604 | ret-id)) 605 | 606 | (defmethod -item-to-ssa :try 607 | [{:keys [catches body finally] :as _ast}] 608 | (let [make-finally (fn [exit-block rethrow?] 609 | (if finally 610 | (gen-plan 611 | [cur-blk (get-block) 612 | finally-blk (add-block) 613 | _ (set-block finally-blk) 614 | ;; catch block has to pop itself off of 615 | ;; rt/EXCEPTION-FRAMES. every try/catch pushes at 616 | ;; least 1 frame on to rt/EXCEPTION-FRAMES, 617 | ;; try/catch/finally pushes 2. The exception 618 | ;; handling machinery around the state machine 619 | ;; pops one off when handling an exception. 620 | _ (add-instruction (->PopTry)) 621 | result-id (add-instruction (->Const ::value)) 622 | _ (item-to-ssa finally) 623 | ;; rethrow exception on exception path 624 | _ (if rethrow? 625 | (add-instruction (->EndFinally result-id)) 626 | (no-op)) 627 | _ (add-instruction (->Jmp result-id exit-block)) 628 | _ (set-block cur-blk)] 629 | finally-blk) 630 | (gen-plan [] exit-block)))] 631 | (gen-plan 632 | [body-block (add-block) 633 | exit-block (add-block) 634 | ;; Two routes to the finally block, via normal execution and 635 | ;; exception execution 636 | finally-blk (make-finally exit-block false) 637 | exception-finally-blk (make-finally exit-block true) 638 | catch-blocks (all 639 | (for [{ex-bind :local {ex :val} :class catch-body :body} catches] 640 | (gen-plan 641 | [cur-blk (get-block) 642 | catch-blk (add-block) 643 | _ (set-block catch-blk) 644 | ex-id (add-instruction (->Const ::value)) 645 | _ (push-alter-binding :locals assoc (:name ex-bind) 646 | (vary-meta ex-id merge (when (:tag ex-bind) 647 | {:tag (.FullName ^Type (:tag ex-bind))}))) ;;; .getName ^Class 648 | result-id (item-to-ssa catch-body) 649 | ;; if there is a finally, jump to it after 650 | ;; handling the exception, if not jump to exit 651 | _ (add-instruction (->Jmp result-id finally-blk)) 652 | _ (pop-binding :locals) 653 | _ (set-block cur-blk)] 654 | [catch-blk ex]))) 655 | ;; catch block handler routes exceptions to the correct handler, 656 | ;; rethrows if there is no match 657 | catch-handler-block (add-block) 658 | cur-blk (get-block) 659 | _ (set-block catch-handler-block) 660 | _ (add-instruction (->PopTry)) ; pop catch-handler-block 661 | _ (add-instruction (->CatchHandler catch-blocks)) 662 | _ (set-block cur-blk) 663 | _ (add-instruction (->Jmp nil body-block)) 664 | _ (set-block body-block) 665 | ;; the finally gets pushed on to the exception handler stack, so 666 | ;; it will be executed if there is an exception 667 | _ (if finally 668 | (add-instruction (->PushTry exception-finally-blk)) 669 | (no-op)) 670 | _ (add-instruction (->PushTry catch-handler-block)) 671 | body (item-to-ssa body) 672 | _ (add-instruction (->PopTry)) ; pop catch-handler-block 673 | ;; if the body finishes executing normally, jump to the finally 674 | ;; block, if it exists 675 | _ (add-instruction (->Jmp body finally-blk)) 676 | _ (set-block exit-block) 677 | ret (add-instruction (->Const ::value))] 678 | ret))) 679 | 680 | (defmethod -item-to-ssa :throw 681 | [{:keys [exception] :as ast}] 682 | (gen-plan 683 | [exception-id (item-to-ssa exception) 684 | ret-id (add-instruction (->Call ['throw exception-id]))] 685 | ret-id)) 686 | 687 | (defmethod -item-to-ssa :new 688 | [{:keys [args class] :as ast}] 689 | (gen-plan 690 | [arg-ids (all (map item-to-ssa args)) 691 | ret-id (add-instruction (->Call (list* 'new (:val class) arg-ids)))] 692 | ret-id)) 693 | 694 | (defmethod -item-to-ssa :recur 695 | [{:keys [exprs] :as ast}] 696 | (gen-plan 697 | [val-ids (all (map item-to-ssa exprs)) 698 | recurs (get-binding :recur-nodes) 699 | _ (do (assert (= (count val-ids) 700 | (count recurs)) 701 | "Wrong number of arguments to recur") 702 | (no-op)) 703 | _ (add-instruction (->Recur recurs val-ids)) 704 | 705 | recur-point (get-binding :recur-point) 706 | 707 | _ (add-instruction (->Jmp nil recur-point))] 708 | ::terminated)) 709 | 710 | (defmethod -item-to-ssa :if 711 | [{:keys [test then else]}] 712 | (gen-plan 713 | [test-id (item-to-ssa test) 714 | then-blk (add-block) 715 | else-blk (add-block) 716 | final-blk (add-block) 717 | _ (add-instruction (->CondBr test-id then-blk else-blk)) 718 | 719 | _ (set-block then-blk) 720 | then-id (item-to-ssa then) 721 | _ (if (not= then-id ::terminated) 722 | (gen-plan 723 | [_ (add-instruction (->Jmp then-id final-blk))] 724 | then-id) 725 | (no-op)) 726 | 727 | _ (set-block else-blk) 728 | else-id (item-to-ssa else) 729 | _ (if (not= else-id ::terminated) 730 | (gen-plan 731 | [_ (add-instruction (->Jmp else-id final-blk))] 732 | then-id) 733 | (no-op)) 734 | 735 | _ (set-block final-blk) 736 | val-id (add-instruction (->Const ::value))] 737 | val-id)) 738 | 739 | (defmethod -item-to-ssa :transition 740 | [{:keys [name args form]}] 741 | (gen-plan 742 | [blk (add-block) 743 | vals (all (map item-to-ssa args)) 744 | val (add-instruction (->CustomTerminator name blk vals (meta form))) 745 | _ (set-block blk) 746 | res (add-instruction (->Const ::value))] 747 | res)) 748 | 749 | (defmethod -item-to-ssa :local 750 | [{:keys [name form]}] 751 | (gen-plan 752 | [locals (get-binding :locals) 753 | inst-id (if (contains? locals name) 754 | (fn [p] 755 | [(locals name) p]) 756 | (fn [p] 757 | [form p]))] 758 | inst-id)) 759 | 760 | (defmethod -item-to-ssa :map 761 | [{:keys [keys vals]}] 762 | (gen-plan 763 | [keys-ids (all (map item-to-ssa keys)) 764 | vals-ids (all (map item-to-ssa vals)) 765 | id (add-instruction (->Call (cons 'clojure.core/hash-map 766 | (interleave keys-ids vals-ids))))] 767 | id)) 768 | 769 | (defmethod -item-to-ssa :with-meta 770 | [{:keys [expr meta]}] 771 | (gen-plan 772 | [meta-id (item-to-ssa meta) 773 | expr-id (item-to-ssa expr) 774 | id (add-instruction (->Call (list 'clojure.core/with-meta expr-id meta-id)))] 775 | id)) 776 | 777 | (defmethod -item-to-ssa :record 778 | [x] 779 | (-item-to-ssa `(~(symbol (.FullName (class x)) "create") ;;; .getName 780 | (hash-map ~@(mapcat identity x))))) 781 | 782 | (defmethod -item-to-ssa :vector 783 | [{:keys [items]}] 784 | (gen-plan 785 | [item-ids (all (map item-to-ssa items)) 786 | id (add-instruction (->Call (cons 'clojure.core/vector 787 | item-ids)))] 788 | id)) 789 | 790 | (defmethod -item-to-ssa :set 791 | [{:keys [items]}] 792 | (gen-plan 793 | [item-ids (all (map item-to-ssa items)) 794 | id (add-instruction (->Call (cons 'clojure.core/hash-set 795 | item-ids)))] 796 | id)) 797 | 798 | (defn parse-to-state-machine 799 | "Takes an sexpr and returns a hashmap that describes the execution flow of the sexpr as 800 | a series of SSA style blocks." 801 | [body terminators] 802 | (-> (gen-plan 803 | [_ (push-binding :terminators terminators) 804 | blk (add-block) 805 | _ (set-block blk) 806 | id (item-to-ssa body) 807 | term-id (add-instruction (->Return id)) 808 | _ (pop-binding :terminators)] 809 | term-id) 810 | get-plan)) 811 | 812 | 813 | (defn index-instruction [blk-id idx inst] 814 | (let [idx (reduce 815 | (fn [acc id] 816 | (update-in acc [id :read-in] (fnil conj #{}) blk-id)) 817 | idx 818 | (filter instruction? (reads-from inst))) 819 | idx (reduce 820 | (fn [acc id] 821 | (update-in acc [id :written-in] (fnil conj #{}) blk-id)) 822 | idx 823 | (filter instruction? (writes-to inst)))] 824 | idx)) 825 | 826 | (defn index-block [idx [blk-id blk]] 827 | (reduce (partial index-instruction blk-id) idx blk)) 828 | 829 | (defn index-state-machine [machine] 830 | (reduce index-block {} (:blocks machine))) 831 | 832 | (defn id-for-inst [m sym] ;; m :: symbols -> integers 833 | (if-let [i (get @m sym)] 834 | i 835 | (let [next-idx (get @m ::next-idx)] 836 | (swap! m assoc sym next-idx) 837 | (swap! m assoc ::next-idx (inc next-idx)) 838 | next-idx))) 839 | 840 | (defn persistent-value? 841 | "Returns true if this value should be saved in the state hash map" 842 | [index value] 843 | (or (not= (-> index value :read-in) 844 | (-> index value :written-in)) 845 | (-> index value :read-in count (> 1)))) 846 | 847 | (defn count-persistent-values 848 | [index] 849 | (transduce 850 | (comp (filter instruction?) (filter (partial persistent-value? index))) 851 | (completing (fn [acc _] (inc acc))) 0 (keys index))) 852 | 853 | (defn- build-block-preamble [local-map idx state-sym blk] 854 | (let [args (into [] (comp 855 | (mapcat reads-from) 856 | (filter instruction?) 857 | (filter (partial persistent-value? idx)) 858 | (distinct)) 859 | blk)] 860 | (if (empty? args) 861 | [] 862 | (mapcat (fn [sym] 863 | `[~sym (rt/aget-object ~state-sym ~(id-for-inst local-map sym))]) 864 | args)))) 865 | 866 | (defn- build-block-body [state-sym blk] 867 | (mapcat 868 | #(emit-instruction % state-sym) 869 | (butlast blk))) 870 | 871 | (defn- build-new-state [local-map idx state-sym blk] 872 | (let [results (into [] (comp 873 | (mapcat writes-to) 874 | (filter instruction?) 875 | (filter (partial persistent-value? idx)) 876 | (distinct)) 877 | blk) 878 | results (interleave (map (partial id-for-inst local-map) results) results)] 879 | (if-not (empty? results) 880 | [state-sym `(rt/aset-all! ~state-sym ~@results)] 881 | []))) 882 | 883 | (defn- emit-state-machine [machine num-user-params custom-terminators] 884 | (let [index (index-state-machine machine) 885 | state-sym (with-meta (gensym "state_") 886 | {:tag 'objects}) 887 | local-start-idx (+ num-user-params rt/USER-START-IDX) 888 | state-arr-size (+ local-start-idx (count-persistent-values index)) 889 | local-map (atom {::next-idx local-start-idx}) 890 | block-catches (:block-catches machine)] 891 | `(fn state-machine# 892 | ([] (rt/aset-all! (conc/->AtomicReferenceArray (object-array (int ~state-arr-size))) ;;; (AtomicReferenceArray. ~state-arr-size) -- use an Array for now TODO -- fix! 893 | ~rt/FN-IDX state-machine# 894 | ~rt/STATE-IDX ~(:start-block machine))) 895 | ([~state-sym] 896 | (let [old-frame# (clojure.lang.Var/getThreadBindingFrame) 897 | ret-value# (try 898 | (clojure.lang.Var/resetThreadBindingFrame (rt/aget-object ~state-sym ~rt/BINDINGS-IDX)) 899 | (loop [] 900 | (let [result# (case (int (rt/aget-object ~state-sym ~rt/STATE-IDX)) 901 | ~@(mapcat 902 | (fn [[id blk]] 903 | [id `(let [~@(concat (build-block-preamble local-map index state-sym blk) 904 | (build-block-body state-sym blk)) 905 | ~@(build-new-state local-map index state-sym blk)] 906 | ~(terminate-block (last blk) state-sym custom-terminators))]) 907 | (:blocks machine)))] 908 | (if (identical? result# :recur) 909 | (recur) 910 | result#))) 911 | (catch Exception ex# ;;; Throwable 912 | (rt/aset-all! ~state-sym ~rt/VALUE-IDX ex#) 913 | (if (seq (rt/aget-object ~state-sym ~rt/EXCEPTION-FRAMES)) 914 | (rt/aset-all! ~state-sym ~rt/STATE-IDX (first (rt/aget-object ~state-sym ~rt/EXCEPTION-FRAMES))) 915 | (throw ex#)) 916 | :recur) 917 | (finally 918 | (rt/aset-object ~state-sym ~rt/BINDINGS-IDX (clojure.lang.Var/getThreadBindingFrame)) 919 | (clojure.lang.Var/resetThreadBindingFrame old-frame#)))] 920 | (if (identical? ret-value# :recur) 921 | (recur ~state-sym) 922 | ret-value#)))))) 923 | 924 | (defn finished? 925 | "Returns true if the machine is in a finished state" 926 | [state-array] 927 | (identical? (rt/aget-object state-array rt/STATE-IDX) ::finished)) 928 | 929 | (defn- fn-handler 930 | [f] 931 | (reify 932 | ILock ;;; Lock 933 | (lock [_]) 934 | (unlock [_]) 935 | 936 | impl/Handler 937 | (active? [_] true) 938 | (blockable? [_] true) 939 | (lock-id [_] 0) 940 | (commit [_] f))) 941 | 942 | (defn mark-transitions 943 | {:pass-info {:walk :post :depends #{} :after an-clr/default-passes}} ;;; an-jvm 944 | [{:keys [op fn] :as ast}] 945 | (let [transitions (-> (env/deref-env) :passes-opts :mark-transitions/transitions)] 946 | (if (and (= op :invoke) 947 | (= (:op fn) :var) 948 | (contains? transitions (var-name (:var fn)))) 949 | (merge ast 950 | {:op :transition 951 | :name (get transitions (var-name (:var fn)))}) 952 | ast))) 953 | 954 | (defn propagate-transitions 955 | {:pass-info {:walk :post :depends #{#'mark-transitions}}} 956 | [{:keys [op] :as ast}] 957 | (if (or (= op :transition) 958 | (some #(or (= (:op %) :transition) 959 | (::transform? %)) 960 | (ast/children ast))) 961 | (assoc ast ::transform? true) 962 | ast)) 963 | 964 | (defn propagate-recur 965 | {:pass-info {:walk :post :depends #{#'annotate-loops #'propagate-transitions}}} 966 | [ast] 967 | (if (and (= (:op ast) :loop) 968 | (::transform? ast)) 969 | ;; If we are a loop and we need to transform, and 970 | ;; one of our children is a recur, then we must transform everything 971 | ;; that has a recur 972 | (let [loop-id (:loop-id ast)] 973 | (ast/postwalk ast #(if (contains? (:loops %) loop-id) 974 | (assoc % ::transform? true) 975 | %))) 976 | ast)) 977 | 978 | (defn nested-go? [env] 979 | (-> env vals first map?)) 980 | 981 | (defn make-env [input-env crossing-env] 982 | (assoc (an-clr/empty-env) ;;; an-jvm 983 | :locals (into {} 984 | (if (nested-go? input-env) 985 | (for [[l expr] input-env 986 | :let [local (get crossing-env l)]] 987 | [local (-> expr 988 | (assoc :form local) 989 | (assoc :name local))]) 990 | (for [l (keys input-env) 991 | :let [local (get crossing-env l)]] 992 | [local {:op :local 993 | :form local 994 | :name local}]))))) 995 | 996 | (defn pdebug [x] 997 | ((requiring-resolve 'clojure.pprint/pprint) x) 998 | (println "----") 999 | x) 1000 | 1001 | (def passes (into (disj an-clr/default-passes #'warn-on-reflection) ;;; an-jvm 1002 | #{#'propagate-recur 1003 | #'propagate-transitions 1004 | #'mark-transitions})) 1005 | 1006 | (def run-passes 1007 | (schedule passes)) 1008 | 1009 | (defn emit-hinted [local tag env] 1010 | (let [tag (or tag (-> local meta :tag)) 1011 | init (list (get env local))] 1012 | (if-let [prim-fn (case (cond-> tag (string? tag) symbol) 1013 | int `int uint `uint ;;; DM Added cases 1014 | long `long ulong `ulong 1015 | char `char 1016 | float `float 1017 | double `double 1018 | byte `byte sbyte `sbyte 1019 | short `short ushort `ushort 1020 | boolean `boolean 1021 | nil)] 1022 | [(vary-meta local dissoc :tag) (list prim-fn init)] 1023 | [(vary-meta local merge (when tag {:tag tag})) init]))) 1024 | 1025 | (defn state-machine [body num-user-params [crossing-env env] user-transitions] 1026 | (binding [an-clr/run-passes run-passes] ;;; an-jvm 1027 | (-> (an-clr/analyze `(let [~@(if (nested-go? env) ;;; an-jvm 1028 | (mapcat (fn [[l {:keys [tag]}]] 1029 | (emit-hinted l tag crossing-env)) 1030 | env) 1031 | (mapcat (fn [[l ^ clojure.lang.CljCompiler.Ast.LocalBinding lb]] ;;; clojure.lang.Compiler$LocalBinding 1032 | (emit-hinted l (when (.HasClrType lb) ;;; .hasJavaClass 1033 | (some-> lb .ClrType .FullName)) ;;; .getJavaClass .getName 1034 | crossing-env)) 1035 | env))] 1036 | ~body) 1037 | (make-env env crossing-env) 1038 | {:passes-opts (merge an-clr/default-passes-opts ;;; an-jvm 1039 | {:uniquify/uniquify-env true 1040 | :mark-transitions/transitions user-transitions})}) 1041 | (parse-to-state-machine user-transitions) 1042 | second 1043 | (emit-state-machine num-user-params user-transitions)))) 1044 | 1045 | (defn go-impl 1046 | [env body] 1047 | (let [crossing-env (zipmap (keys env) (repeatedly gensym))] 1048 | `(let [c# (clojure.core.async/chan 1) 1049 | captured-bindings# (Var/getThreadBindingFrame)] 1050 | (dispatch/run 1051 | (^:once fn* [] 1052 | (let [~@(mapcat (fn [[l sym]] [sym `(^:once fn* [] ~(vary-meta l dissoc :tag))]) crossing-env) 1053 | f# ~(state-machine 1054 | `(do ~@body) 1 [crossing-env env] rt/async-custom-terminators) 1055 | state# (-> (f#) 1056 | (rt/aset-all! rt/USER-START-IDX c# 1057 | rt/BINDINGS-IDX captured-bindings#))] 1058 | (rt/run-state-machine-wrapped state#)))) 1059 | c#))) --------------------------------------------------------------------------------