|
19 | 19 | [clojure.tools.analyzer.passes.clr.annotate-loops :refer [annotate-loops]]
|
20 | 20 | [clojure.tools.analyzer.passes.clr.warn-on-reflection :refer [warn-on-reflection]]
|
21 | 21 | [clojure.tools.analyzer.clr :as an-clr]
|
22 |
| - [clojure.core.async.impl.protocols :as impl] [clojure.core.async.impl.mutex :as mutex] ;;; added mutex |
| 22 | + [clojure.core.async.impl.runtime :as rt] |
23 | 23 | [clojure.set :as set])
|
24 |
| - (:import [clojure.core.async.impl.mutex ILock] ;;; [java.util.concurrent.locks Lock] |
25 |
| - )) ;;; [java.util.concurrent.atomic AtomicReferenceArray] |
| 24 | + (:import )) ;;; [java.util.concurrent.atomic AtomicReferenceArray] |
26 | 25 |
|
27 | 26 | (defn debug [x]
|
28 | 27 | (pprint x)
|
29 | 28 | x)
|
30 | 29 |
|
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 [^System.Array arr ^long idx o] ;;; ^AtomicReferenceArray -- for now, replace with a regular array. We'll work on the atomic version eventully. |
39 |
| - (.SetValue arr o idx)) ;;; (.set arr idx o) |
40 |
| - |
41 |
| -(defn aget-object [^System.Array arr ^long idx] ;;; ^AtomicReferenceArray -- for now, replace with a regular array. We'll work on the atomic version eventully. |
42 |
| - (.GetValue arr idx)) ;;; .get |
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 |
| - |
56 | 30 | ;; State monad stuff, used only in SSA construction
|
57 | 31 |
|
58 | 32 | (defmacro gen-plan
|
|
217 | 191 | IEmittableInstruction
|
218 | 192 | (emit-instruction [this state-sym]
|
219 | 193 | (if (= value ::value)
|
220 |
| - `[~(:id this) (aget-object ~state-sym ~VALUE-IDX)] |
| 194 | + `[~(:id this) (rt/aget-object ~state-sym ~rt/VALUE-IDX)] |
221 | 195 | `[~(:id this) ~value])))
|
222 | 196 |
|
223 | 197 | (defrecord RawCode [ast locals]
|
|
317 | 291 | (terminate-block [_this state-sym _]
|
318 | 292 | `(do (case ~val-id
|
319 | 293 | ~@(concat (mapcat (fn [test blk]
|
320 |
| - `[~test (aset-all! ~state-sym |
321 |
| - ~STATE-IDX ~blk)]) |
| 294 | + `[~test (rt/aset-all! ~state-sym ~rt/STATE-IDX ~blk)]) |
322 | 295 | test-vals jmp-blocks)
|
323 | 296 | (when default-block
|
324 |
| - `[(do (aset-all! ~state-sym ~STATE-IDX ~default-block) |
| 297 | + `[(do (rt/aset-all! ~state-sym ~rt/STATE-IDX ~default-block) |
325 | 298 | :recur)])))
|
326 | 299 | :recur)))
|
327 | 300 |
|
|
352 | 325 | (block-references [_this] [block])
|
353 | 326 | ITerminator
|
354 | 327 | (terminate-block [_this state-sym _]
|
355 |
| - `(do (aset-all! ~state-sym ~VALUE-IDX ~value ~STATE-IDX ~block) |
| 328 | + `(do (rt/aset-all! ~state-sym ~rt/VALUE-IDX ~value ~rt/STATE-IDX ~block) |
356 | 329 | :recur)))
|
357 | 330 |
|
358 | 331 | (defrecord Return [value]
|
|
365 | 338 | (terminate-block [this state-sym custom-terminators]
|
366 | 339 | (if-let [f (get custom-terminators (terminator-code this))]
|
367 | 340 | `(~f ~state-sym ~value)
|
368 |
| - `(do (aset-all! ~state-sym |
369 |
| - ~VALUE-IDX ~value |
370 |
| - ~STATE-IDX ::finished) |
| 341 | + `(do (rt/aset-all! ~state-sym ~rt/VALUE-IDX ~value ~rt/STATE-IDX ::finished) |
371 | 342 | nil))))
|
372 | 343 |
|
373 | 344 | (defrecord CondBr [test then-block else-block]
|
|
378 | 349 | ITerminator
|
379 | 350 | (terminate-block [_this state-sym _]
|
380 | 351 | `(do (if ~test
|
381 |
| - (aset-all! ~state-sym |
382 |
| - ~STATE-IDX ~then-block) |
383 |
| - (aset-all! ~state-sym |
384 |
| - ~STATE-IDX ~else-block)) |
| 352 | + (rt/aset-all! ~state-sym ~rt/STATE-IDX ~then-block) |
| 353 | + (rt/aset-all! ~state-sym ~rt/STATE-IDX ~else-block)) |
385 | 354 | :recur)))
|
386 | 355 |
|
387 | 356 | (defrecord PushTry [catch-block]
|
|
391 | 360 | (block-references [_this] [catch-block])
|
392 | 361 | IEmittableInstruction
|
393 | 362 | (emit-instruction [_this state-sym]
|
394 |
| - `[~'_ (aset-all! ~state-sym ~EXCEPTION-FRAMES (cons ~catch-block (aget-object ~state-sym ~EXCEPTION-FRAMES)))])) |
| 363 | + `[~'_ (rt/aset-all! ~state-sym ~rt/EXCEPTION-FRAMES (cons ~catch-block (rt/aget-object ~state-sym ~rt/EXCEPTION-FRAMES)))])) |
395 | 364 |
|
396 | 365 | (defrecord PopTry []
|
397 | 366 | IInstruction
|
|
400 | 369 | (block-references [_this] [])
|
401 | 370 | IEmittableInstruction
|
402 | 371 | (emit-instruction [_this state-sym]
|
403 |
| - `[~'_ (aset-all! ~state-sym ~EXCEPTION-FRAMES (rest (aget-object ~state-sym ~EXCEPTION-FRAMES)))])) |
| 372 | + `[~'_ (rt/aset-all! ~state-sym ~rt/EXCEPTION-FRAMES (rest (rt/aget-object ~state-sym ~rt/EXCEPTION-FRAMES)))])) |
404 | 373 |
|
405 | 374 | (defrecord CatchHandler [catches]
|
406 | 375 | IInstruction
|
|
410 | 379 | ITerminator
|
411 | 380 | (terminate-block [_this state-sym _]
|
412 | 381 | (let [ex (gensym 'ex)]
|
413 |
| - `(let [~ex (aget-object ~state-sym ~VALUE-IDX)] |
| 382 | + `(let [~ex (rt/aget-object ~state-sym ~rt/VALUE-IDX)] |
414 | 383 | (cond
|
415 | 384 | ~@(for [[handler-idx type] catches
|
416 |
| - i [`(instance? ~type ~ex) `(aset-all! ~state-sym ~STATE-IDX ~handler-idx)]] |
| 385 | + i [`(instance? ~type ~ex) `(rt/aset-all! ~state-sym ~rt/STATE-IDX ~handler-idx)]] |
417 | 386 | i)
|
418 | 387 | :else (throw ~ex))
|
419 | 388 | :recur))))
|
|
893 | 862 | (if (empty? args)
|
894 | 863 | []
|
895 | 864 | (mapcat (fn [sym]
|
896 |
| - `[~sym (aget-object ~state-sym ~(id-for-inst local-map sym))]) |
| 865 | + `[~sym (rt/aget-object ~state-sym ~(id-for-inst local-map sym))]) |
897 | 866 | args))))
|
898 | 867 |
|
899 | 868 | (defn- build-block-body [state-sym blk]
|
|
910 | 879 | blk)
|
911 | 880 | results (interleave (map (partial id-for-inst local-map) results) results)]
|
912 | 881 | (if-not (empty? results)
|
913 |
| - [state-sym `(aset-all! ~state-sym ~@results)] |
| 882 | + [state-sym `(rt/aset-all! ~state-sym ~@results)] |
914 | 883 | [])))
|
915 | 884 |
|
916 | 885 | (defn- emit-state-machine [machine num-user-params custom-terminators]
|
917 | 886 | (let [index (index-state-machine machine)
|
918 | 887 | state-sym (with-meta (gensym "state_")
|
919 | 888 | {:tag 'objects})
|
920 |
| - local-start-idx (+ num-user-params USER-START-IDX) |
| 889 | + local-start-idx (+ num-user-params rt/USER-START-IDX) |
921 | 890 | state-arr-size (+ local-start-idx (count-persistent-values index))
|
922 | 891 | local-map (atom {::next-idx local-start-idx})
|
923 | 892 | block-catches (:block-catches machine)]
|
924 | 893 | `(fn state-machine#
|
925 |
| - ([] (aset-all! (System.Array/CreateInstance Object ~state-arr-size) ;;; (AtomicReferenceArray. ~state-arr-size) -- use an Array for now |
926 |
| - ~FN-IDX state-machine# |
927 |
| - ~STATE-IDX ~(:start-block machine))) |
| 894 | + ([] (rt/aset-all! (System.Array/CreateInstance System.Object (int ~state-arr-size)) ;;; (AtomicReferenceArray. ~state-arr-size) -- use an Array for now TODO -- fix! |
| 895 | + ~rt/FN-IDX state-machine# |
| 896 | + ~rt/STATE-IDX ~(:start-block machine))) |
928 | 897 | ([~state-sym]
|
929 | 898 | (let [old-frame# (clojure.lang.Var/getThreadBindingFrame)
|
930 | 899 | ret-value# (try
|
931 |
| - (clojure.lang.Var/resetThreadBindingFrame (aget-object ~state-sym ~BINDINGS-IDX)) |
| 900 | + (clojure.lang.Var/resetThreadBindingFrame (rt/aget-object ~state-sym ~rt/BINDINGS-IDX)) |
932 | 901 | (loop []
|
933 |
| - (let [result# (case (int (aget-object ~state-sym ~STATE-IDX)) |
| 902 | + (let [result# (case (int (rt/aget-object ~state-sym ~rt/STATE-IDX)) |
934 | 903 | ~@(mapcat
|
935 | 904 | (fn [[id blk]]
|
936 | 905 | [id `(let [~@(concat (build-block-preamble local-map index state-sym blk)
|
|
942 | 911 | (recur)
|
943 | 912 | result#)))
|
944 | 913 | (catch Exception ex# ;;; Throwable
|
945 |
| - (aset-all! ~state-sym ~VALUE-IDX ex#) |
946 |
| - (if (seq (aget-object ~state-sym ~EXCEPTION-FRAMES)) |
947 |
| - (aset-all! ~state-sym ~STATE-IDX (first (aget-object ~state-sym ~EXCEPTION-FRAMES))) |
| 914 | + (rt/aset-all! ~state-sym ~rt/VALUE-IDX ex#) |
| 915 | + (if (seq (rt/aget-object ~state-sym ~rt/EXCEPTION-FRAMES)) |
| 916 | + (rt/aset-all! ~state-sym ~rt/STATE-IDX (first (rt/aget-object ~state-sym ~rt/EXCEPTION-FRAMES))) |
948 | 917 | (throw ex#))
|
949 | 918 | :recur)
|
950 | 919 | (finally
|
951 |
| - (aset-object ~state-sym ~BINDINGS-IDX (clojure.lang.Var/getThreadBindingFrame)) |
| 920 | + (rt/aset-object ~state-sym ~rt/BINDINGS-IDX (clojure.lang.Var/getThreadBindingFrame)) |
952 | 921 | (clojure.lang.Var/resetThreadBindingFrame old-frame#)))]
|
953 | 922 | (if (identical? ret-value# :recur)
|
954 | 923 | (recur ~state-sym)
|
955 | 924 | ret-value#))))))
|
956 | 925 |
|
957 |
| -(defn finished? |
958 |
| - "Returns true if the machine is in a finished state" |
959 |
| - [state-array] |
960 |
| - (identical? (aget-object state-array STATE-IDX) ::finished)) |
961 |
| - |
962 |
| -(defn- fn-handler |
963 |
| - [f] |
964 |
| - (reify |
965 |
| - ILock ;;; Lock |
966 |
| - (lock [_]) |
967 |
| - (unlock [_]) |
968 |
| - |
969 |
| - impl/Handler |
970 |
| - (active? [_] true) |
971 |
| - (blockable? [_] true) |
972 |
| - (lock-id [_] 0) |
973 |
| - (commit [_] f))) |
974 |
| - |
975 |
| - |
976 |
| -(defn run-state-machine [state] |
977 |
| - ((aget-object state FN-IDX) state)) |
978 |
| - |
979 |
| -(defn run-state-machine-wrapped [state] |
980 |
| - (try |
981 |
| - (run-state-machine state) |
982 |
| - (catch Exception ex ;;; Throwable |
983 |
| - (impl/close! (aget-object state USER-START-IDX)) |
984 |
| - (throw ex)))) |
985 |
| - |
986 |
| -(defn take! [state blk c] |
987 |
| - (if-let [cb (impl/take! c (fn-handler |
988 |
| - (fn [x] |
989 |
| - (aset-all! state VALUE-IDX x STATE-IDX blk) |
990 |
| - (run-state-machine-wrapped state))))] |
991 |
| - (do (aset-all! state VALUE-IDX @cb STATE-IDX blk) |
992 |
| - :recur) |
993 |
| - nil)) |
994 |
| - |
995 |
| -(defn put! [state blk c val] |
996 |
| - (if-let [cb (impl/put! c val (fn-handler (fn [ret-val] |
997 |
| - (aset-all! state VALUE-IDX ret-val STATE-IDX blk) |
998 |
| - (run-state-machine-wrapped state))))] |
999 |
| - (do (aset-all! state VALUE-IDX @cb STATE-IDX blk) |
1000 |
| - :recur) |
1001 |
| - nil)) |
1002 |
| - |
1003 |
| -(defn return-chan [state value] |
1004 |
| - (let [c (aget-object state USER-START-IDX)] |
1005 |
| - (when-not (nil? value) |
1006 |
| - (impl/put! c value (fn-handler (fn [_] nil)))) |
1007 |
| - (impl/close! c) |
1008 |
| - c)) |
1009 |
| - |
1010 |
| -(def async-custom-terminators |
1011 |
| - {'clojure.core.async/<! `take! |
1012 |
| - 'clojure.core.async/>! `put! |
1013 |
| - 'clojure.core.async/alts! 'clojure.core.async/ioc-alts! |
1014 |
| - :Return `return-chan}) |
1015 |
| - |
1016 | 926 | (defn mark-transitions
|
1017 | 927 | {:pass-info {:walk :post :depends #{} :after an-clr/default-passes}}
|
1018 | 928 | [{:keys [op fn] :as ast}]
|
|
0 commit comments