(ns com.tailrecursion.blacktide.source-loops-test
"Compare ordinary numeric loops with both backends, including source boxing,
recur inference, evaluation traces and bounded generated alpha variants."
(:require [clojure.test :as t]
[clojure.test.check.clojure-test :refer [defspec]]
[clojure.test.check.generators :as gen]
[clojure.test.check.properties :as prop]
[clojure.walk :as walk]
[com.tailrecursion.blacktide :refer [loophole]]
[com.tailrecursion.blacktide.backend-fixture :as backend]
[com.tailrecursion.blacktide.jvm-fixture :as jvm]))
(defn canonical [value]
(cond
(instance? Double value) [(class value) (Double/doubleToLongBits value)]
(instance? Float value) [(class value) (Float/floatToIntBits value)]
(number? value) [(class value) value]
(sequential? value) (mapv canonical value)
:else value))
(defn enclose [body mode]
;; The helper functions belong to the caller. Only the loop is the region.
(if (#{'let 'clojure.core/let} (first body))
(list* (first body) (second body) (concat (butlast (nnext body)) [(enclose (last body) mode)]))
(if (= mode :ordinary) body
(list 'loophole '[loop-effect nil]
(list* (first body) (second body) '(com.tailrecursion.blacktide/setq loop-effect true) (nnext body))))))
(defn compile-body [body mode]
(try
(binding [*ns* (the-ns 'com.tailrecursion.blacktide.source-loops-test)]
(backend/with-backend mode #(eval (list 'fn '[events input n] (enclose body mode)))))
(catch Throwable e {:compile (class (backend/root-error e))})))
(defn outcome [f input n]
(if (map? f) f
(let [events (atom [])]
(try (let [value (f events input n)] {:value (canonical value) :class (class value) :trace (canonical @events)})
(catch Throwable e {:throw (class e) :trace (canonical @events)})))))
(def bodies
'[(let [step (fn ^long [^long x] (unchecked-inc x))]
(loop [i 0 x 1000] (if (< i n) (recur (inc i) (step x)) [x (class x) (identical? x x)])))
(let [step (fn [x] x)]
(loop [i 0 x 1000 y x]
(if (< i n) (recur (inc i) (step x) x) [(identical? x y) (identical? x x)])))
(let [step (fn [x] x)]
(loop [i 0 x Long/MIN_VALUE]
(if (< i n) (recur (inc i) (step x)) (- x x))))
(let [step (fn [x] x)]
(loop [i 0 x Long/MIN_VALUE y 1000]
(if (< i n) (recur (inc i) x (step y)) (- x x))))
(let [step (fn [x] x)]
(loop [i 0 x Long/MIN_VALUE y Long/MIN_VALUE]
(if (< i n) (recur (inc i) (step x) x) (- y y))))
(let [step (fn ^long [^long x] (unchecked-inc x))]
(loop [i 1000 x (long input)]
(if (< i (+ 1000 n)) (recur (inc i) (step x)) [(identical? i i) x])))
(let [step (fn ^long [^long x] (unchecked-inc x))]
(loop [i 0 x 0]
(if (< i n) (let [next (step x)]
(recur (do (swap! events conj [:index i]) (inc i))
(do (swap! events conj [:value x next]) next)))
x)))
(let [step (fn ^double [^double x] (+ x 0.5))]
(loop [i 0 x (double input)] (if (< i n) (recur (inc i) (step x)) (Double/doubleToRawLongBits x))))
(let [step (fn [x] input)]
(loop [i 0 x 0] (if (< i n) (recur (inc i) (step x)) [x (class x)])))
(let [step (fn ^long [^long x] (inc x))]
(loop [i 0 x 1000]
(if (< i n) (recur (int (inc i)) (step x)) x)))
(let [step (fn ^double [^double x] (+ x 0.5))]
(loop [i 0.0 x 1.5]
(if (< i n) (recur (float (+ i 1.0)) (step x)) [i x (class i)])))
(let [step (fn ^long [^long x] (inc x))]
(loop [i 0 x (do (swap! events conj :initial) 1000)]
(if (< i n) (recur (inc i) (step x)) x)))
(let [step (fn [x] (if x nil 1000))]
(loop [i 0 x 1000] (if (< i n) (recur (inc i) (step x)) x)))])
(t/deftest dependent-loop-initializers-retain-final-types
(doseq [init [1000 1.5]
:let [body `(let [~'step (fn [~'x] (swap! ~'events conj ~'x) ~'x)]
(loop [~'i 0 ~'x ~init ~'y (+ ~'x 1)]
(if (< ~'i ~'n)
(recur (inc ~'i) (~'step ~'x) (~'step ~'y))
[(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser ~'x)
(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser ~'y)
~'x ~'y])))
ordinary (compile-body body :ordinary)]]
(doseq [mode [:default :dispatcher]
:let [compiled (compile-body body mode)] n [0 1 3]]
(t/is (= (outcome ordinary nil n) (outcome compiled nil n)) (pr-str [init mode n])))))
(t/deftest source-loop-regressions
(doseq [body bodies
:let [ordinary (compile-body body :ordinary)]
mode [:default :dispatcher]
:let [compiled (compile-body body mode)]
input [0 1000 -7 1.5 1/3 1000N 2M nil]
n [0 1 3]]
(t/is (= (outcome ordinary input n) (outcome compiled input n)) (pr-str [mode input n body])))
(doseq [initializer '[1000 1.5 -0.0 Double/NaN]
:let [body (list 'let ['step '(fn [x] x)]
(list 'loop ['i 0 'x initializer]
'(if (< i n) (recur (inc i) (step x)) x)))
ordinary (compile-body body :ordinary)]
mode [:default :dispatcher] :let [compiled (compile-body body mode)]
n [0 1 3]]
(t/is (= (identical? (ordinary nil nil n) (ordinary nil nil n))
(identical? (compiled nil nil n) (compiled nil nil n))) (pr-str [mode n body])))
;; A primitive backedge is insufficient to specialize an unknown initial box.
(let [body '(loop [i 0 x (identity input)]
(if (< i n) (recur (inc i) (Math/fma 1.5 (double x) 0.25)) x))]
(doseq [mode [:default :dispatcher] input [0 1.5 -0.0 1M nil] n [0 1 3]]
(t/is (= (outcome (compile-body body :ordinary) input n)
(outcome (compile-body body mode) input n))))))
(t/deftest source-loop-overloads-follow-fixed-point-types
(doseq [body '[(let [step (fn ^long [^long x] (inc x))]
(loop [i 0 x 1000]
(if (< i n) (recur (inc i) (step x))
[(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser x)
(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser i)])))
(let [step (fn ^long [^long x] (inc x))]
(loop [i 0 x 1000 y x]
(if (< i n) (recur (inc i) (step x) x)
(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser y))))
(let [step (fn ^double [^double x] (+ x 0.5))]
(loop [i 0 x 1000.0]
(if (< i n) (recur (inc i) (step x))
(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser x))))
(let [step (fn [x] input)]
(loop [i 0 x 1000]
(if (< i n) (recur (inc i) (step x))
(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser x))))
(let [step (fn ^long [^long x] (inc x))]
(loop [i 0 x 1000]
(if (< i n) (recur (inc i) (step x)) (Math/abs x))))
(let [step (fn [x] input)]
(loop [i 0 x 1000]
(if (< i n) (recur (inc i) (step x)) (.substring x 1))))
(let [step (fn [x] input)]
(loop [i 0 x 1000]
(if (< i n) (recur (inc i) (step x)) (.length x))))]
:let [reference (compile-body body :ordinary)]]
(doseq [mode [:default :dispatcher] :let [compiled (compile-body body mode)]
input [0 1.5 1/3 2M "word" nil] n [0 1 3]]
(t/is (= (outcome reference input n) (outcome compiled input n)) (pr-str [body mode input n])))))
(defn arithmetic [double? value [op k]]
(let [v (gensym "operand") k (if double? (double k) k)]
`(let [~v ~value]
~(case op
:add `(+ ~v ~k)
:increment `(inc ~v)
:negate `(- ~v)
:scale `(* ~v ~k)
:branch `(if (< ~v 0) (+ ~v ~k) (- ~v ~k))
:flip (if double? `(- 0.0 ~v) `(bit-xor ~v ~(long k)))))))
(defn generated-body [{:keys [double? typed? narrow? alias? shadow? scalar? forward? literal? steps k]} renamed?]
(let [cast (if double? 'double 'long)
parameters (cond-> ['p] typed? (with-meta {:tag cast}))
parameters (if typed? (with-meta [(with-meta 'p {:tag cast})] (meta parameters)) parameters)
compute (reduce (partial arithmetic double?) (list cast 'p) steps)
compute `(do (swap! ~'events conj [:call ~'p ~'bias]) ~compute)
call (list 'step 'x)
call (if shadow? `(let [~'x (+ ~'x ~'bias)] ~call) call)
update (if alias? `(let [~'snapshot ~call] ~'snapshot) call)
next-index (if narrow? (list (if double? 'float 'int) '(inc i)) '(inc i))
initial (if literal? (if double? 1.5 1000) (list cast 'input))
result (if scalar? '(- y y)
'[x y (class x) (class y) (identical? x x) (identical? x y) (identical? i i)
(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser x)
(.choose ^com.tailrecursion.blacktide.jvm_fixture.Choice jvm/chooser y)])
body `(let [~'bias ~(if double? (double k) k)
~'step (fn ~parameters ~compute)]
(loop [~'i ~(if double? 0.0 0)
~'x (do (swap! ~'events conj :init) ~initial)
~'y ~'x]
(if (< ~'i ~'n)
(recur (do (swap! ~'events conj [:index ~'i]) ~next-index)
(do (swap! ~'events conj [:left ~'x]) ~update)
(do (swap! ~'events conj [:right ~'y]) ~(if forward? 'x '(step y))))
~result)))]
(if renamed?
(list 'let ['unused :harmless]
(walk/postwalk #(if (symbol? %) (with-meta (get '{i counter x left y right p value
step when bias amount snapshot saved} % %) (meta %)) %) body))
body)))
(def configuration
(gen/let [double? gen/boolean typed? gen/boolean narrow? gen/boolean
alias? gen/boolean shadow? gen/boolean scalar? gen/boolean
forward? gen/boolean literal? gen/boolean k (gen/choose -3 3)
input (gen/elements (if double? [-0.0 1.5 Double/NaN Double/POSITIVE_INFINITY Double/MIN_VALUE]
[0 1000 Long/MIN_VALUE Long/MAX_VALUE 2M 1/3 nil]))
steps (gen/vector (gen/tuple (gen/elements [:add :increment :negate :scale :branch :flip])
(gen/choose -3 3)) 0 4)]
{:double? double? :typed? typed? :narrow? narrow? :alias? alias? :shadow? shadow?
:scalar? scalar? :forward? forward? :literal? literal? :k k :input input :steps steps}))
(defspec generated-source-loop-equivalence {:num-tests 128 :seed 141421}
(prop/for-all [config configuration]
(let [reference (compile-body (generated-body config false) :ordinary)]
(every? true?
(for [renamed? [false true] mode [:default :dispatcher]
:let [compiled (compile-body (generated-body config renamed?) mode)] n [0 1 4]]
(= (outcome reference (:input config) n) (outcome compiled (:input config) n)))))))