(ns com.tailrecursion.blacktide.loops-test
"Original recur targets, native loop inference, and bounded independent loop
models. Iteration budgets are structural, so shrinking cannot create hangs."
(:require [clojure.test :refer [deftest is]]
[clojure.test.check.clojure-test :refer [defspec]]
[clojure.test.check.generators :as gen]
[clojure.test.check.properties :as prop]
[com.tailrecursion.blacktide :refer [loophole label goto setq psetq]]
[com.tailrecursion.blacktide.backend-fixture :as backend]
[com.tailrecursion.blacktide.jvm-fixture :as jvm]))
(deftest source-recursion-and-macro-loops
(is (= [2 1] (loophole [] (loop [n 3 a 1 b 2] (if (zero? n) [a b] (recur (dec n) b a))))))
(is (= [2 1 3] (loophole [calls 0]
(loop [n 3 a 1 b 2]
(if (zero? n) [a b calls]
(do (setq calls (inc calls)) (recur (dec n) b a)))))))
(is (= 18 (loophole [total 0]
(dotimes [i 4] (dotimes [i i] (setq total (+ total 3)))) total)))
(is (= [0 2 4] (loophole [out []]
(doseq [i (range 6) :when (even? i) :let [i (* i 2)] :while (< i 10)]
(setq out (conj out (quot i 2)))) out)))
(is (= 5 (loophole [n 0] (while (< n 5) (setq n (inc n))) n)))
(is (= :zero (loophole [] (dotimes [i 0] (throw (Exception. "unreachable"))) :zero)))
(is (= 6 (loophole [n 0] (loop [] (setq n (inc n)) (when (< n 6) (recur))) n))))
(deftest recur-operands-and-abandonment
(let [events (atom [])]
(is (= [1 10 20 20]
(loophole [x 0]
(loop [n 0 a nil b nil]
(if (zero? n)
(recur (do (swap! events conj :first) 1)
(do (setq x 10) (swap! events conj x) x)
(do (setq x 20) (swap! events conj x) x))
[n a b x])))))
(is (= [:first 10 20] @events)))
(is (= [0 1 0 1] (loophole [round 0 out []]
(label again)
(loop [i 0]
(setq out (conj out i))
(when (zero? i) (recur 1)))
(setq round (inc round))
(when (< round 2) (goto again)) out)))
(is (= 8 (loophole [x 0]
(loop [n 4]
(when (pos? n)
(loop [m 2] (when (pos? m) (setq x (inc x)) (recur (dec m))))
(recur (dec n)))) x))))
(deftest native-loop-inference
(doseq [form '[(loop [i 1] (.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice chooser i))
(loop [i (int 1)] (.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice chooser i))
(loop [i (float 1)] (.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice chooser i))
(loop [n 1 value 0] (if (pos? n) (recur (dec n) "string") value))
(loop [n 1 value 0] (if (pos? n) (recur (dec n) 1.5) (class value)))
(loop [n 1 value 0] (if (pos? n) (recur (dec n) 1.5)
(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice chooser value)))
(loop [a (java.util.ArrayList. [1 2 3]) i (int 1)] (.remove a i) (vec a))
(loop [x "abc"] (let [snapshot x] (String/.substring snapshot 1)))
(loop [n 0] (if (zero? n) (recur 1) ^{:value n} [n]))
(loop [f ^{:param-tags [int]} Math/abs] (f -2))
]
lowered? [false true]
:let [body (if lowered? (list* (first form) (second form) '(setq touched true) (nnext form)) form)]]
(is (= (jvm/outcome form) (jvm/outcome (list 'loophole '[touched nil] body))) (pr-str [lowered? form])))
(is (= :long (loophole [x 1]
(loop [n 2] (setq x n)
(loop [n 1] (.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser n))))))
;; DSL writes retain the same initializer promotions as ordinary Clojure.
(is (= (loop [i (int 1)] (class i)) (loophole [x nil] (loop [i (int 1)] (setq x true) (class i)))))
(is (= (loop [i (float 1)] (class i)) (loophole [x nil] (loop [i (float 1)] (setq x true) (class i))))))
(def ^String tagged-value "word")
(defmacro erase-tag [] (alter-meta! #'tagged-value assoc :tag 'Object) :retagged)
(def changing-value :old)
(defmacro make-constant [] (alter-meta! #'changing-value assoc :const true) nil)
(deftest native-types-survive-later-macro-expansion
(let [body '[(loop [] (.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser tagged-value)) (erase-tag)]
evaluate (fn [wrap]
(alter-meta! #'tagged-value assoc :tag 'String)
(binding [*ns* (the-ns 'com.tailrecursion.blacktide.loops-test)]
(eval (list (list 'fn [] (wrap body))))))]
(try
(is (= [:string :retagged] (evaluate identity) (evaluate #(list 'loophole [] %))))
(finally (alter-meta! #'tagged-value assoc :tag 'String))))
(doseq [body ['[changing-value (make-constant)] '[(loop [] changing-value) (make-constant)]]]
(try
(let [evaluate (fn [wrap]
(alter-meta! #'changing-value dissoc :const)
(alter-var-root #'changing-value (constantly :old))
(let [compiled (binding [*ns* (the-ns 'com.tailrecursion.blacktide.loops-test)]
(eval (list 'fn [] (wrap body))))]
(alter-var-root #'changing-value (constantly :new))
(compiled)))]
(is (= [:new nil] (evaluate identity) (evaluate #(list 'loophole [] %)))))
(finally (alter-meta! #'changing-value dissoc :const)
(alter-var-root #'changing-value (constantly :old))))))
(deftest lowered-loop-interop-boundary
(doseq [body '[(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice com.tailrecursion.blacktide.jvm-fixture/chooser i)
(let [copy i] (.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice com.tailrecursion.blacktide.jvm-fixture/chooser copy))
(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice com.tailrecursion.blacktide.jvm-fixture/chooser (inc i))
(loop [] (.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice com.tailrecursion.blacktide.jvm-fixture/chooser i))
(loop [copy i] (.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice com.tailrecursion.blacktide.jvm-fixture/chooser copy))]]
(let [form (list 'loophole '[x 0] (list 'loop '[i 1] '(setq x 1) body))]
(is (= (jvm/outcome (list 'loop '[i 1] body)) (jvm/outcome form)) (pr-str form))))
(is (= :int (loophole [x 0] (loop [i 1] (setq x 1)
(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser (int i))))))
(is (= :object (loophole [x 0] (loop [i (identity 1)] (setq x 1)
(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser i)))))
(is (= :long (loophole [x 0] (loop [i 1] (setq x 1)
(^{:param-tags [long]} com.tailrecursion.blacktide.jvm_fixture.Choice/.choose jvm/chooser i))))))
(deftest recur-legality-and-loop-scopes
(doseq [[form kind]
[['(loophole [] (recur)) :invalid-recur]
['(loophole [] (loop [n 0] (recur))) :recur-arity]
['(loophole [] (loop [] (recur) 1)) :invalid-recur]
['(loophole [] (loop [n 0] (if (recur 1) n n))) :invalid-recur]
['(loophole [] (loop [] [(recur)])) :invalid-recur]
['(loophole [] (loop [n (recur 0)] n)) :invalid-recur]
['(loophole [] (loop [] (loophole [] (recur)))) :unsupported-form]
['(loophole [] (loop [n 1] (setq n 2))) :immutable-assignment]
['(loophole [x nil] (loop [n (byte 1)] (setq x n) (recur nil))) :invalid-recur-type]
['(loophole [x nil] (loop [n 1] (setq x n) (recur (short n)))) :invalid-recur-type]
['(loophole [] (goto body) (loop [] (label body))) :marker-position]
['(loophole [] (loop [] (goto other)) (loop [] (label other))) :marker-position]
['(loophole [] (goto done) (loop [] (recur 1)) (label done)) :recur-arity]]]
(is (= kind (:kind (backend/rejection form))) (pr-str form))))
(deftest illegal-primitive-recur-conversions
(doseq [cast '[byte short char]]
(let [body (list 'loop '[n 0] (list 'recur (list cast 1)))
lowered (list 'loop '[n 0] '(setq x n) (list 'recur (list cast 1)))]
(is (= IllegalArgumentException (:error (jvm/outcome body))))
(is (= :invalid-recur-type
(:kind (backend/rejection (list 'loophole '[x nil] lowered))))))))
(defn loop-model [{:keys [limit cut width a b weight]}]
(loop [i 0 a a b b history []]
(if (or (= i limit) (= i cut)) [a b history i]
(let [delta (reduce + weight (range width))
next (if (even? i) [(+ b delta) (- a delta)] [(- b delta) (+ a delta)])]
(recur (inc i) (first next) (second next) (conj history [a b (inc i)]))))))
(defn loop-program [{:keys [limit cut width a b weight]}]
`(loophole [~'ticks 0 ~'result nil]
(setq ~'result
(loop [~'i 0 ~'a ~a ~'b ~b ~'history []]
(if (= ~'i ~cut) [~'a ~'b ~'history ~'ticks]
(if (= ~'i ~limit) [~'a ~'b ~'history ~'ticks]
(let [~'delta (loop [~'i 0 ~'total ~weight]
(if (= ~'i ~width) ~'total (recur (inc ~'i) (+ ~'total ~'i))))]
(if (even? ~'i)
(recur (do (setq ~'ticks (inc ~'ticks)) (inc ~'i)) (+ ~'b ~'delta) (- ~'a ~'delta)
(conj ~'history [~'a ~'b ~'ticks]))
(recur (do (setq ~'ticks (inc ~'ticks)) (inc ~'i)) (- ~'b ~'delta) (+ ~'a ~'delta)
(conj ~'history [~'a ~'b ~'ticks]))))))))
(label ~'done) ~'result))
(defn loop-outcome [config wrap]
(try {:value (backend/run-form (wrap (loop-program config)))}
(catch Throwable error {:error (class error) :message (ex-message error)})))
(defspec generated-nested-loops {:num-tests 240 :seed 161803}
(prop/for-all [config (gen/hash-map :limit (gen/choose 0 11) :cut (gen/choose 0 14)
:width (gen/choose 0 5) :a (gen/choose -10 10)
:b (gen/choose -10 10) :weight (gen/choose -3 3))]
(every? true?
(for [wrap [identity #(list 'let ['unused 1] (list 'do %))]]
(= {:value (loop-model config)} (loop-outcome config wrap))))))
(defn insertion-sort! [^longs values]
(loophole [writes 0]
(loop [i 1]
(when (< i (alength values))
(let [key (aget values (int i))]
(loop [j i]
(if (and (pos? j) (> (aget values (int (dec j))) key))
(do (aset-long values (int j) (aget values (int (dec j))))
(setq writes (inc writes)) (recur (dec j)))
(aset-long values (int j) key))))
(recur (inc i))))
writes))
(defn first-negative [^longs values]
(loophole [found -1]
(loop [i 0]
(when (< i (alength values))
(when (neg? (aget values (int i))) (setq found i) (goto done))
(recur (inc i))))
(label done) found))
(defn gcd [a b]
(loophole [steps 0]
(loop [a (abs a) b (abs b)]
(if (zero? b) a (do (setq steps (inc steps)) (recur b (rem a b)))))))
(defspec algorithms-against-independent-references {:num-tests 180 :seed 577215}
(prop/for-all [input (gen/vector (gen/choose -7 7) 0 24)
a (gen/choose -500 500) b (gen/choose -500 500)]
(let [values (long-array input)]
(insertion-sort! values)
(and (= (vec (sort input)) (vec values))
(= (or (first (keep-indexed #(when (neg? %2) %1) input)) -1) (first-negative (long-array input)))
(= (.longValue (.gcd (biginteger a) (biginteger b))) (gcd a b))))))