2020 [clojure.tools.analyzer.passes.jvm.warn-on-reflection :refer [warn-on-reflection]]
2121 [clojure.tools.analyzer.jvm :as an-jvm]
2222 [clojure.core.async.impl.protocols :as impl]
23+ [clojure.core.async.impl.dispatch :as dispatch]
24+ [clojure.core.async.impl.runtime :as rt]
2325 [clojure.set :as set])
24- (:import [java.util.concurrent.locks Lock ]
25- [java.util.concurrent.atomic AtomicReferenceArray ]))
26+ (:import [java.util.concurrent.atomic AtomicReferenceArray ]
27+ [clojure.lang Var ]))
2628
2729(defn debug [x]
2830 (pprint x)
2931 x )
3032
31- (def ^{:const true :tag 'long} FN-IDX 0 )
32- (def ^{:const true :tag 'long} STATE-IDX 1 )
33- (def ^{:const true :tag 'long} VALUE-IDX 2 )
34- (def ^{:const true :tag 'long} BINDINGS-IDX 3 )
35- (def ^{:const true :tag 'long} EXCEPTION-FRAMES 4 )
36- (def ^{:const true :tag 'long} USER-START-IDX 5 )
37-
38- (defn aset-object [^AtomicReferenceArray arr ^long idx o]
39- (.set arr idx o))
40-
41- (defn aget-object [^AtomicReferenceArray arr ^long idx]
42- (.get arr idx))
43-
44- (defmacro aset-all!
45- [arr & more]
46- (assert (even? (count more)) " Must give an even number of args to aset-all!"
47- (let [bindings (partition 2 more)
48- arr-sym (gensym " statearr-"
49- `(let [~arr-sym ~arr]
50- ~@(map
51- (fn [[idx val]]
52- `(aset-object ~arr-sym ~idx ~val))
53- bindings)
54- ~arr-sym)))
55-
5633; ; State monad stuff, used only in SSA construction
5734
5835(defmacro gen-plan
217194 IEmittableInstruction
218195 (emit-instruction [this state-sym]
219196 (if (= value ::value )
220- `[~(:id this) (aget-object ~state-sym ~VALUE-IDX)]
197+ `[~(:id this) (rt/ aget-objectrt/ VALUE-IDX)]
221198 `[~(:id this) ~value])))
222199
223200(defrecord RawCode [ast locals]
317294 (terminate-block [_this state-sym _]
318295 `(do (case ~val-id
319296 ~@(concat (mapcat (fn [test blk]
320- `[~test (aset-all! ~state-sym ~STATE-IDX ~blk)])
297+ `[~test (rt/ aset-all!rt/ STATE-IDX ~blk)])
321298 test-vals jmp-blocks)
322299 (when default-block
323- `[(do (aset-all! ~state-sym ~STATE-IDX ~default-block)
300+ `[(do (rt/ aset-all!rt/ STATE-IDX ~default-block)
324301 :recur )])))
325302 :recur )))
326303
351328 (block-references [_this] [block])
352329 ITerminator
353330 (terminate-block [_this state-sym _]
354- `(do (aset-all! ~state-sym ~VALUE-IDX ~value ~STATE-IDX ~block)
331+ `(do (rt/ aset-all!rt/ VALUE-IDX ~value ~rt/ STATE-IDX ~block)
355332 :recur )))
356333
357334(defrecord Return [value]
364341 (terminate-block [this state-sym custom-terminators]
365342 (if-let [f (get custom-terminators (terminator-code this))]
366343 `(~f ~state-sym ~value)
367- `(do (aset-all! ~state-sym ~VALUE-IDX ~value ~STATE-IDX ::finished )
344+ `(do (rt/ aset-all!rt/ VALUE-IDX ~value ~rt/ STATE-IDX ::finished )
368345 nil ))))
369346
370347(defrecord CondBr [test then-block else-block]
375352 ITerminator
376353 (terminate-block [_this state-sym _]
377354 `(do (if ~test
378- (aset-all! ~state-sym ~STATE-IDX ~then-block)
379- (aset-all! ~state-sym ~STATE-IDX ~else-block))
355+ (rt/ aset-all!rt/ STATE-IDX ~then-block)
356+ (rt/ aset-all!rt/ STATE-IDX ~else-block))
380357 :recur )))
381358
382359(defrecord PushTry [catch-block]
386363 (block-references [_this] [catch-block])
387364 IEmittableInstruction
388365 (emit-instruction [_this state-sym]
389- `[~'_ (aset-all! ~state-sym ~EXCEPTION-FRAMES (cons ~catch-block (aget-object ~state-sym ~EXCEPTION-FRAMES)))]))
366+ `[~'_ (rt/ aset-all!rt/ EXCEPTION-FRAMES (cons ~catch-block (rt/ aget-objectrt/ EXCEPTION-FRAMES)))]))
390367
391368(defrecord PopTry []
392369 IInstruction
395372 (block-references [_this] [])
396373 IEmittableInstruction
397374 (emit-instruction [_this state-sym]
398- `[~'_ (aset-all! ~state-sym ~EXCEPTION-FRAMES (rest (aget-object ~state-sym ~EXCEPTION-FRAMES)))]))
375+ `[~'_ (rt/ aset-all!rt/ EXCEPTION-FRAMES (rest (rt/ aget-objectrt/ EXCEPTION-FRAMES)))]))
399376
400377(defrecord CatchHandler [catches]
401378 IInstruction
405382 ITerminator
406383 (terminate-block [_this state-sym _]
407384 (let [ex (gensym 'ex)]
408- `(let [~ex (aget-object ~state-sym ~VALUE-IDX)]
385+ `(let [~ex (rt/ aget-objectrt/ VALUE-IDX)]
409386 (cond
410387 ~@(for [[handler-idx type] catches
411- i [`(instance? ~type ~ex) `(aset-all! ~state-sym ~STATE-IDX ~handler-idx)]]
388+ i [`(instance? ~type ~ex) `(rt/ aset-all! ~state-sym ~rt/ STATE-IDX ~handler-idx)]]
412389 i)
413390 :else (throw ~ex))
414391 :recur ))))
888865 (if (empty? args)
889866 []
890867 (mapcat (fn [sym]
891- `[~sym (aget-object ~state-sym ~(id-for-inst local-map sym))])
868+ `[~sym (rt/ aget-objectid-for-inst local-map sym))])
892869 args))))
893870
894871(defn- build-block-body [state-sym blk]
905882 blk)
906883 results (interleave (map (partial id-for-inst local-map) results) results)]
907884 (if-not (empty? results)
908- [state-sym `(aset-all! ~state-sym ~@results)]
885+ [state-sym `(rt/ aset-all! ~state-sym ~@results)]
909886 [])))
910887
911888(defn- emit-state-machine [machine num-user-params custom-terminators]
912889 (let [index (index-state-machine machine)
913890 state-sym (with-meta (gensym " state_"
914891 {:tag 'objects})
915- local-start-idx (+ num-user-params USER-START-IDX)
892+ local-start-idx (+ num-user-params rt/ USER-START-IDX)
916893 state-arr-size (+ local-start-idx (count-persistent-values index))
917894 local-map (atom {::next-idx local-start-idx})
918895 block-catches (:block-catches machine)]
919896 `(fn state-machine#
920- ([] (aset-all! (AtomicReferenceArray. ~state-arr-size)
921- ~FN-IDX state-machine#
922- ~STATE-IDX ~(:start-block machine)))
897+ ([] (rt/ aset-all!AtomicReferenceArray. ~state-arr-size)
898+ ~rt/ FN-IDX state-machine#
899+ ~rt/ STATE-IDX ~(:start-block machine)))
923900 ([~state-sym]
924901 (let [old-frame# (clojure.lang.Var/getThreadBindingFrame )
925902 ret-value# (try
926- (clojure.lang.Var/resetThreadBindingFrame (aget-object ~state-sym ~BINDINGS-IDX))
903+ (clojure.lang.Var/resetThreadBindingFrame (rt/ aget-objectrt/ BINDINGS-IDX))
927904 (loop []
928- (let [result# (case (int (aget-object ~state-sym ~STATE-IDX))
905+ (let [result# (case (int (rt/ aget-objectrt/ STATE-IDX))
929906 ~@(mapcat
930907 (fn [[id blk]]
931908 [id `(let [~@(concat (build-block-preamble local-map index state-sym blk)
937914 (recur )
938915 result#)))
939916 (catch Throwable ex#
940- (aset-all! ~state-sym ~VALUE-IDX ex#)
941- (if (seq (aget-object ~state-sym ~EXCEPTION-FRAMES))
942- (aset-all! ~state-sym ~STATE-IDX (first (aget-object ~state-sym ~EXCEPTION-FRAMES)))
917+ (rt/ aset-all!rt/ VALUE-IDX ex#)
918+ (if (seq (rt/ aget-objectrt/ EXCEPTION-FRAMES))
919+ (rt/ aset-all!rt/ STATE-IDX (first (rt/ aget-objectrt/ EXCEPTION-FRAMES)))
943920 (throw ex#))
944921 :recur )
945922 (finally
946- (aset-object ~state-sym ~BINDINGS-IDX (clojure.lang.Var/getThreadBindingFrame ))
923+ (rt/ aset-objectrt/ BINDINGS-IDX (clojure.lang.Var/getThreadBindingFrame ))
947924 (clojure.lang.Var/resetThreadBindingFrame old-frame#)))]
948925 (if (identical? ret-value# :recur )
949926 (recur ~state-sym)
950927 ret-value#))))))
951928
952- (defn finished?
953- " Returns true if the machine is in a finished state"
954- [state-array]
955- (identical? (aget-object state-array STATE-IDX) ::finished ))
956-
957- (defn- fn-handler
958- [f]
959- (reify
960- Lock
961- (lock [_])
962- (unlock [_])
963-
964- impl/Handler
965- (active? [_] true )
966- (blockable? [_] true )
967- (lock-id [_] 0 )
968- (commit [_] f)))
969-
970-
971- (defn run-state-machine [state]
972- ((aget-object state FN-IDX) state))
973-
974- (defn run-state-machine-wrapped [state]
975- (try
976- (run-state-machine state)
977- (catch Throwable ex
978- (impl/close! (aget-object state USER-START-IDX))
979- (throw ex))))
980-
981- (defn take! [state blk c]
982- (if-let [cb (impl/take! c (fn-handler
983- (fn [x]
984- (aset-all! state VALUE-IDX x STATE-IDX blk)
985- (run-state-machine-wrapped state))))]
986- (do (aset-all! state VALUE-IDX @cb STATE-IDX blk)
987- :recur )
988- nil ))
989-
990- (defn put! [state blk c val]
991- (if-let [cb (impl/put! c val (fn-handler (fn [ret-val]
992- (aset-all! state VALUE-IDX ret-val STATE-IDX blk)
993- (run-state-machine-wrapped state))))]
994- (do (aset-all! state VALUE-IDX @cb STATE-IDX blk)
995- :recur )
996- nil ))
997-
998- (defn return-chan [state value]
999- (let [c (aget-object state USER-START-IDX)]
1000- (when-not (nil? value)
1001- (impl/put! c value (fn-handler (fn [_] nil ))))
1002- (impl/close! c)
1003- c))
1004-
1005- (def async-custom-terminators
1006- {'clojure.core.async/<! `take!
1007- 'clojure.core.async/>! `put!
1008- 'clojure.core.async/alts! 'clojure.core.async/ioc-alts!
1009- :Return `return-chan})
1010-
1011929(defn mark-transitions
1012930 {:pass-info {:walk :post :depends #{} :after an-jvm/default-passes}}
1013931 [{:keys [op fn ] :as ast}]
11101028 (parse-to-state-machine user-transitions)
11111029 second
11121030 (emit-state-machine num-user-params user-transitions))))
1031+
1032+ (defn go-impl
1033+ [env body]
1034+ (let [crossing-env (zipmap (keys env) (repeatedly gensym))]
1035+ `(let [c# (clojure.core.async/chan 1 )
1036+ captured-bindings# (Var/getThreadBindingFrame )]
1037+ (dispatch/run
1038+ (^:once fn* []
1039+ (let [~@(mapcat (fn [[l sym]] [sym `(^:once fn* [] ~(vary-meta l dissoc :tag ))]) crossing-env)
1040+ f# ~(state-machine
1041+ `(do ~@body) 1 [crossing-env env] rt/async-custom-terminators)
1042+ state# (-> (f# )
1043+ (rt/aset-all! rt/USER-START-IDX c#
1044+ rt/BINDINGS-IDX captured-bindings#))]
1045+ (rt/run-state-machine-wrapped state#))))
1046+ c#)))
0 commit comments