(ns com.tailrecursion.blacktide.backend-test
"Backend decisions, primitive storage, reference identity and conversion order."
(:require [clojure.test :refer [deftest is]]
[clojure.test.check :as tc]
[clojure.test.check.generators :as gen]
[clojure.test.check.properties :as prop]
[com.tailrecursion.blacktide.compiler.passes.structure :as structure]
[com.tailrecursion.blacktide.compiler.passes.storage :as storage]
[com.tailrecursion.blacktide.compiler.passes.compact :as compact]
[com.tailrecursion.blacktide.compiler.passes.value-facts :as facts]
[com.tailrecursion.blacktide.compiler.jvm :as jvm]
[com.tailrecursion.blacktide.compiler.passes.prepare :as prepare]
[com.tailrecursion.blacktide.compiler.passes.lower :as lower]
[com.tailrecursion.blacktide.backend-fixture :as m :refer [compile-program execution capture]]))
(defmacro local-class [name]
(let [^clojure.lang.Compiler$LocalBinding binding (get &env name)]
(list 'quote (if (.hasJavaClass binding) (.getJavaClass binding) Object))))
(deftest compaction-carries-free-read-counts
(let [x (m/local 'x) y (m/local 'y) result {:op :return :values [x]}
binding (m/call 'x 'f x)]
(doseq [[tree expected]
[[{:op :bind :binding binding :body result} {'f 1 'x 1}]
[{:op :effect :binding binding :body result} {'f 1 'x 2}]
[{:op :branch :test (m/local 'test) :yes result :no result} {'test 1 'x 2}]
[{:op :switch :test (m/local 'index) :arms [result {:op :throw :value y}]} {'index 1 'x 1 'y 1}]
[{:op :loop :bindings [{:target 'x :value x} {:target 'y :value x}]
:body {:op :return :values [y]}} {'x 1}]
[{:op :recur :args [x y x]} {'x 2 'y 1}]
[{:op :join :targets ['x] :value result
:body {:op :bind :binding (m/call 'z 'f x) :body {:op :return :values [(m/local 'z)]}}}
{'x 1 'f 1}]
[{:op :join :targets ['x 'y] :value {:op :return :values [y x]}
:body {:op :return :values [x y]}} {'x 1 'y 1}]
[{:op :bind :binding (m/assign 'x {:op :value :value y})
:body {:op :bind :binding binding :body result}} {'y 1 'f 1}]]]
(let [[out refs] (compact/simplify {} tree)]
(is (= expected refs) (pr-str tree))
(is (= expected (compact/reads out)) (pr-str out)))))
(let [n 1024
tree (reduce (fn [body i]
{:op :bind :binding (m/call (symbol (str "x" (inc i))) 'f (m/local (symbol (str "x" i))))
:body body})
{:op :return :values [(m/local (symbol (str "x" n)))]} (reverse (range n)))
visits (atom 0) reads compact/reads
[out refs] (with-redefs [compact/reads (fn [node] (swap! visits inc) (reads node))]
(compact/simplify {} tree))]
(is (= n (count (take-while #(= :bind (:op %)) (iterate :body out))))
"Long binding sequences must not grow the simplifier's call stack")
(is (= {'f n 'x0 1} refs))
(is (= 1 @visits) "Retained bindings reuse the child's summary instead of walking it again")))
(deftest result-type-boundary
(doseq [body '[1 2.5 nil false "text" (loop [] 1) (do (goto end) :dead (label end) 42)]
mode [:default :dispatcher]]
(let [form (list 'let ['result (list 'loophole [] body)] '(com.tailrecursion.blacktide.backend-test/local-class result))]
(is (= Object ((compile-program form mode) nil)) (pr-str [body mode])))))
(deftest object-arguments-need-facts-and-snapshots-but-no-cast
(let [conversions (atom []) graphs (atom []) conversion prepare/conversion compile-graph lower/compile-graph]
(with-redefs [prepare/conversion
(fn [how expr]
(let [out (conversion how expr)]
(when (= Object (:type how)) (swap! conversions conj out)) out))
lower/compile-graph (fn [supply expr]
(let [out (compile-graph supply expr)] (swap! graphs conj out) out))]
(doseq [mode [:default :dispatcher]]
(is (= {:value [false 30] :trace [10 20]}
(execution '(loophole [x 10]
[(java.util.Objects/equals (do (swap! events conj x) x)
(do (setq x 20) (swap! events conj x) (setq x 30))) x]) mode)))
(is (= :throw
(if (:throw (execution '(loophole []
(^{:param-tags [Object Object]} clojure.lang.Numbers/minus
(long Long/MIN_VALUE) (long Long/MIN_VALUE))) mode)) :throw :returned)))
(is (.startsWith ^String (:value (execution '(loophole []
(^{:param-tags [Object]} String/valueOf (char-array [\a \b]))) mode))
"[C@"))))
(is (seq @conversions))
(is (every? #(and (= Object (:type (:jvm %))) (false? (:primitive? (:jvm %)))) @conversions))
(is (not-any? #(and (map? %) (= :convert (:op %)) (= Object (:type (:conversion %))))
(mapcat #(tree-seq coll? seq %) @graphs)))))
(deftest integer-conversion-overloads-are-not-interchangeable
(let [outcome (fn [f x] (try (let [v (f x)] [v (class v)])
(catch Throwable e [(class e)])))
reference (fn [x] (int (identity x)))]
(doseq [[cast values]
[['long [Long/MIN_VALUE (dec (long Integer/MIN_VALUE)) Integer/MIN_VALUE
-1 0 1 Integer/MAX_VALUE (inc (long Integer/MAX_VALUE)) Long/MAX_VALUE]]
['double [Double/NaN Double/POSITIVE_INFINITY Double/NEGATIVE_INFINITY
-0.0 0.0 1.5 -1.5 2147483647.5 -2147483648.9
(double Long/MIN_VALUE) (double Long/MAX_VALUE)]]]
mode [:default :dispatcher]
:let [form (list 'fn '[input] (list 'loophole ['x (list cast 'input)] '(int x)))
compiled ((compile-program form mode) (atom []))]]
(doseq [value values :let [value (if (= cast 'long) (long value) (double value))]]
(is (= (outcome reference value) (outcome compiled value)) (pr-str [cast mode value])))
(when (= cast 'long)
(let [result (tc/quick-check 64
(prop/for-all [value gen/large-integer]
(= (outcome reference value) (outcome compiled value)))
:seed 173205)]
(is (:pass? result) (pr-str [mode result])))))))
(deftest return-boxing-preserves-values-and-observed-references
(doseq [literal [-129 0 1000 -0.0 1.5]]
(let [form (list 'loophole ['i 0 'x literal]
'(while (< i 2) (setq i (inc i))) 'x)]
(is (some (fn [[id type]] (and (.endsWith (name id) "__x")
(= type (if (instance? Long literal) Long/TYPE Double/TYPE))))
(:types (capture #'storage/select-storage form))))
(doseq [mode [:default :dispatcher]]
(let [value ((compile-program form mode) nil)]
(is (= (Double/doubleToRawLongBits (double literal)) (Double/doubleToRawLongBits (double value))))
(is (= (class literal) (class value)))))))
;; Externally supplied and observed boxes retain identity regardless of value.
(doseq [mode [:default :dispatcher]
value [(Long. 0) (Long. 127) (Long. 128) (Integer. 0) (Double. 0.0)]]
(let [f (compile-program '(loophole [i 0 x events]
(while (< i 2) (setq i (inc i))) x) mode)]
(is (identical? value (f value)))))
(doseq [mode [:default :dispatcher]
initializer '[(Long. 0) (Long. 128) 0 127 128]]
(let [form (list 'loophole ['i 0 'x initializer 'saved 'x]
'(while (< i 2) (setq x (inc x) i (inc i)))
'(do (reset! events saved) saved))
f (compile-program form mode) events (atom nil) result (f events)]
(is (identical? result @events)))))
(deftest primitive-proofs-follow-producers
(let [hint (jvm/fact false {:hint 'long :var-meta {}} Long/TYPE)]
(is (= :boxed (facts/rhs-type {} {:op :external :name 'x :jvm hint})))
(is (= Long/TYPE (facts/rhs-type {} {:op :external :name 'x :jvm (assoc hint :primitive? true)})))
(is (= :boxed (facts/atom-type {} (m/literal (Integer/valueOf 1000))))))
(is (= {'x Long/TYPE 'y Long/TYPE}
(facts/solve {'x [{:op :value :value (m/literal 1)} {:op :value :value (m/local 'y)}]
'y [{:op :value :value (m/local 'x)}]})))
(is (= {'x :boxed 'y :boxed}
(facts/solve {'x [{:op :value :value (m/literal 1)} {:op :value :value (m/local 'y)}]
'y [{:op :value :value (m/local 'x)} {:op :value :value (m/literal 2.0)}]}))))
(deftest dead-blocks-are-retained-but-not-type-proofs
(let [machine (m/checked-machine {:entry 0 :blocks {0 (m/block [(m/put-value 'x 1)] {:op :return :value (m/local 'x)})
1 (m/block [(m/put-value 'x nil)] {:op :return :value (m/local 'x)})}})
analysis (facts/analyze machine)]
(is (= machine (:machine analysis)))
(is (= #{0} (:reachable analysis)))
(is (= {'x Long/TYPE} (:types analysis)))))
(deftest feasible-paths-preserve-primitive-state
(let [form '(loophole [^long i 0 ^long total 0]
(while (< i 5)
(setq total (cond (= i 2) (unchecked-add total 10)
:else (unchecked-inc total))
i (unchecked-inc i)))
(long total))
program (capture #'storage/select-storage form)
slots (storage/loop-slots (:body program))]
(is (= 2 (count slots)))
(is (= #{Long/TYPE} (set (vals (select-keys (:types program) slots)))))
(is (every? (:types program) slots))
(doseq [mode [:default :dispatcher]]
(is (= {:value 14 :trace []} (execution form mode)))))
(doseq [[value expected] [[nil -3] [false -3] [true 3] [0 3] ["" 3] [:else 3] [[] 3]]
mode [:default :dispatcher]]
(let [form (list 'loophole '[i 0 x 0]
(list 'while '(< i 3)
(list 'if (list 'do '(swap! events conj :test) (list 'quote value))
'(setq x (inc x)) '(setq x (dec x)))
'(setq i (inc i))) 'x)]
(is (= {:value expected :trace [:test :test :test]} (execution form mode))))))
(deftest structured-loops-and-fallbacks
(let [form '(loophole [i 0 a 0 b 1]
(label again)
(swap! events conj [i a b])
(if (< i 6)
(do (psetq a b b (+ a b)) (setq i (inc i)) (goto again))
[a b]))]
(is (= :structured (:op (capture #'structure/recover form))))
(is (some? (capture #'facts/analyze form)) "Structured emission needs numeric value proofs")
(doseq [mode [:default :dispatcher]]
(let [events (atom [])]
(is (= [8 13] ((compile-program form mode) events)))
(is (= [[0 0 1] [1 1 1] [2 1 2] [3 2 3] [4 3 5] [5 5 8] [6 8 13]] @events)))))
(let [form '(loophole [i 0 j 0]
(while (< i 2) (setq i (inc i)))
(while (< j 3) (setq j (inc j))) [i j])]
(is (= :structured (:op (capture #'structure/recover form))))
(is (= [2 3] ((compile-program form :default) nil))))
(let [form '(loophole [n 0]
(if (seq @events) (goto left) (goto right))
(label left) (setq n (inc n)) (when (< n 3) (goto right)) (goto done)
(label right) (setq n (inc n)) (when (< n 3) (goto left))
(label done) n)]
(is (= :cycles (:reason (capture #'structure/recover form))))
(is (nil? (capture #'facts/analyze form)) "Dispatcher fallback skips unused numeric value proofs")
(doseq [events [[] [:left]]] (is (= 3 ((compile-program form :default) (atom events))))))
(let [step '(if (odd? i) (setq x (inc x) y (inc y)) (setq x (+ x 2) y (+ y 2)))
form (list 'loophole '[i 0 x 0 y 0]
(list* 'while '(< i 3) (concat (repeat 8 step) ['(setq i (inc i))])) '[x y])]
(is (= :budget (:reason (capture #'structure/recover form))))
(is (= [40 40] ((compile-program form :default) (atom []))))))
(deftest structured-code-preserves-native-validation
(doseq [invalid '[(Math/abs 1 2 3) (String. 1 2 3 4 5)]]
(let [form (list 'loophole '[i 0] '(label again) '(setq i (inc i))
'(when (< i 2) (goto again)) '(goto done) invalid '(label done))]
(doseq [mode [:default :dispatcher]]
(is (thrown? clojure.lang.Compiler$CompilerException (compile-program form mode))))))
(let [form '(loophole [i 0]
(label again) (setq i (inc i)) (when (< i 2) (goto again))
(goto done) (swap! events conj :dead) (label done))
events (atom [])]
(is (= :validation (:reason (capture #'structure/recover form))))
(is (nil? ((compile-program form :default) events)))
(is (empty? @events))))
(deftest joins-share-one-continuation
(let [step '(if (odd? i) (setq hits (inc hits)) (setq hits (+ hits 2)))
form (list 'loophole '[i 0 hits 0]
(list* 'while '(< i 3) (concat (repeat 8 step) ['(setq i (inc i))])) 'hits)
decision (capture #'structure/recover form)]
(is (= :structured (:op decision)))
(is (= 9 (count (filter #(and (map? %) (= :branch (:op %))) (tree-seq coll? seq (:body decision))))))
(doseq [mode [:default :dispatcher]] (is (= 40 ((compile-program form mode) (atom []))))))
(let [form (list 'loophole '[i 0 answer nil]
(list 'while '(< i 96)
(list 'setq 'answer (list* 'case 'i (concat (mapcat #(vector % %) (range 96)) [nil])))
'(setq i (inc i))) 'answer)]
(is (= :structured (:op (capture #'structure/recover form))))
(doseq [mode [:default :dispatcher]] (is (= 95 ((compile-program form mode) (atom []))))))
(doseq [mode [:default :dispatcher]]
(let [events (atom [])]
(is (= [false nil 7]
((compile-program '(loophole [i 0 values []]
(while (< i 3)
(let [value (case i 0 (do (swap! events conj :false) false)
1 (do (swap! events conj :nil) nil)
(do (swap! events conj :number) 7))]
(setq values (conj values value)))
(setq i (inc i))) values) mode) events)))
(is (= [:false :nil :number] @events)))))
(deftest joins-return-current-values-together
(let [form '(loophole [x (Object.) y (Object.) saved-x x saved-y y]
(dotimes [i 1]
(dotimes [j 1]
(if (seq @events)
(psetq x y y x)
(setq x nil))))
(swap! events conj :joined)
[(identical? x saved-y) (identical? y saved-x) (nil? x)])
decision (capture #'structure/recover form)]
(is (= :structured (:op decision)))
(is (some #(and (map? %) (= :join (:op %)) (= 2 (count (:targets %))))
(tree-seq coll? seq (:body decision))))
(doseq [mode [:default :dispatcher] initial [[] [:swap]]]
(let [events (atom initial)]
(is (= (if (seq initial) [true true false] [false false true])
((compile-program form mode) events)))
(is (= (conj initial :joined) @events))))))
(deftest nested-loops-preserve-exits-and-reentry
(doseq [[form expected]
[['(loophole [i 0 total 0]
(while (< i 3)
(let [n (do (swap! events conj [:init i]) i)]
(loop [j 0]
(when (< j n)
(swap! events conj [i j]) (setq total (inc total)) (recur (inc j)))))
(setq i (inc i))) total)
{:value 3 :trace [[:init 0] [:init 1] [1 0] [:init 2] [2 0] [2 1]]}]
['(loophole [i 0 scratch 0]
(while (< i 2)
(loop [j 0]
(when (< j 2) (setq scratch j) (swap! events conj [i j]) (recur (inc j))))
(setq i (inc i))) i)
{:value 2 :trace [[0 0] [0 1] [1 0] [1 1]]}]
['(loophole [a 0 b 0]
(dotimes [i 3]
(dotimes [j 3]
(setq a (inc a) b (+ b a)) (swap! events conj [i j a b])
(when (= a 4)
(let [message (do (swap! events conj :construct) (str a "/" b))]
(throw (ex-info message {:a a :b b})))))))
{:throw clojure.lang.ExceptionInfo
:trace [[0 0 1 1] [0 1 2 3] [0 2 3 6] [1 0 4 10] :construct]}]]]
(is (= :structured (:op (capture #'structure/recover form))))
(doseq [mode [:default :generic :dispatcher]] (is (= expected (execution form mode)))))
(let [form '(loophole [sum 0 n 0]
(let [bias (long (first events))]
(dotimes [i 2] (dotimes [j 3] (setq sum (+ sum bias) n (inc n))))) [sum n])
program (capture #'storage/select-storage form)
loops (filter #(and (map? %) (= :loop (:op %))) (tree-seq coll? seq (:body program)))]
(is (= [3 3] (mapv #(count (:slots %)) loops)) "Only sum, n and each loop's index need carrying")
(doseq [mode [:default :generic :dispatcher]] (is (= [42 6] ((compile-program form mode) [7]))))))
(defn primitive-target ^long [^long n] (+ n 1))
(defn primitive-replacement ^long [^long n] (+ n 100))
(deftest primitive-conversions-effects-and-exceptions
(doseq [mode [:default :dispatcher]]
(is (= {:throw ArithmeticException :trace [:before]}
(execution '(loophole [^long i 1]
(while (< i 2)
(swap! events conj :before)
(+ Long/MAX_VALUE i)
(swap! events conj :after)
(setq i (inc i)))) mode)))
(is (= {:throw NullPointerException :trace []}
(execution '(loophole [^long i 0]
(while (< i 1)
(^{:param-tags [long long]} Math/max nil (do (swap! events conj :argument) 1))
(setq i (inc i)))) mode)))
(let [f (compile-program '(loophole [^long i 0]
(while (< i 1)
(com.tailrecursion.blacktide.backend-test/primitive-target (do (swap! events conj :argument) 5))
(setq i (inc i)))) mode)
events (atom [])]
(with-redefs [primitive-target (fn [x] x)]
(is (thrown? ClassCastException (f events)))
(is (empty? @events))))
(with-redefs [primitive-target primitive-target]
(is (= {:value 6 :trace []}
(execution '(loophole [^long i 0 result nil]
(while (< i 1)
(setq result (com.tailrecursion.blacktide.backend-test/primitive-target
(do (alter-var-root #'com.tailrecursion.blacktide.backend-test/primitive-target
(constantly com.tailrecursion.blacktide.backend-test/primitive-replacement))
5))
i (inc i))) result) mode))))))
(deftest object-conversions-preserve-references-dispatch-and-order
(doseq [mode [:default :dispatcher]]
(is (= {:throw ClassCastException :trace [:array]}
(execution '(loophole [^long i 0]
(while (< i 1)
(^{:param-tags [long/1 int long]} clojure.lang.RT/aset
(do (swap! events conj :array) (identity :wrong))
(do (swap! events conj :index) 0)
(do (swap! events conj :value) 1))
(setq i (inc i)))) mode)))
(is (= {:value true :trace []}
(execution '(loophole [i 0 x (inc (long 1000)) same true]
(while (< i 3)
(let [copy (java.util.Objects/requireNonNull x)]
(setq same (and same (identical? copy x)) i (inc i)))) same) mode)))
(is (= {:value [false false "null"] :trace [:left :right]}
(execution '(loophole [i 0 x nil result nil]
(while (< i 1)
(setq result (java.util.Objects/equals
(do (swap! events conj :left) x)
(do (setq x false) (swap! events conj :right) x))
i (inc i)))
[result x (^{:param-tags [Object]} String/valueOf nil)]) mode)))
(is (= {:throw NullPointerException :trace [:message]}
(execution '(loophole [i 0]
(while (< i 1)
(^{:param-tags [Object String]} java.util.Objects/requireNonNull
nil (do (swap! events conj :message) "required"))
(setq i (inc i)))) mode)))))
(deftest primitive-cast-cleanup-keeps-observable-boxes
(let [form '(loophole [x (long events)]
(< (^{:param-tags [long]} clojure.lang.RT/longCast x) 0))
program (capture #'compact/program form)]
(is (not-any? #(and (map? %) (= :host (:op %))
(= clojure.lang.RT (:class (:operation %)))
(= 'longCast (:member (:operation %)))
(= [Long/TYPE] (:tags (:operation %))))
(tree-seq coll? seq (:body program))))
(doseq [mode [:default :dispatcher] input [Long/MIN_VALUE 1000 Long/MAX_VALUE]]
(is (= (neg? input) ((compile-program form mode) input)))))
(doseq [mode [:default :dispatcher]]
(is (false? ((compile-program '(loophole [] (let [x 1000] (identical? x x))) mode) nil)))
(is (true? ((compile-program '(loophole [x (long 1000) y nil] (psetq y x) (identical? x y)) mode) nil)))))