(ns com.tailrecursion.blacktide.generated-test
"Bounded source generation with a separate state model, two backends, alpha
variants and validity-preserving shrinking. Coverage includes fallback code."
(:require [clojure.test :refer [deftest is]]
[clojure.test.check :as tc]
[clojure.test.check.generators :as gen]
[clojure.test.check.properties :as prop]
[clojure.walk :as walk]
[com.tailrecursion.blacktide :refer [loophole label goto setq psetq]]
[com.tailrecursion.blacktide.backend-fixture :as backend]
[com.tailrecursion.blacktide.compiler.passes.structure :as structure]
[com.tailrecursion.blacktide.compiler.passes.storage :as storage]
[com.tailrecursion.blacktide.compiler.passes.numeric :as numeric]
[com.tailrecursion.blacktide.compiler.passes.numeric-lower :as numeric-lower]))
(defn three-steps [x k] (+ x (* 3 k)))
(def operations [:parallel :if :case :snapshot :arguments :shadow :helper :loop :check :truth :cast :lookup])
(defn model-step [{:keys [x y] :as state} i index [op k]]
(if (and (= op :check) (= i k)) (reduced (assoc state :throw ArithmeticException))
(let [[x y] (case op
:parallel [(+ y k) (- x k)]
:if [(if (< x y) (+ x k) (- x k)) y]
:case [(+ x (case (mod i 3) 0 k 1 (- k) (* 2 k))) y]
:snapshot [(+ x k) (+ y x)]
:arguments [x (+ (* 2 x) k)]
:shadow [x (+ y (* 2 k))]
:helper [(+ x (* 3 k)) y]
:loop [(+ x (* 2 k)) y]
:truth [(+ x (if (even? k) k (- k))) y]
:cast [(+ x k) y]
:lookup [(+ x k) (+ x y)]
:check [x y])]
(assoc state :x x :y y :trace (conj (:trace state) [i index x y])))))
(defn model [{:keys [limit cut x y steps scalar?]}]
(loop [i 0 state {:x x :y y :trace []}]
(cond
(:throw state) (select-keys state [:throw :trace])
(or (= i limit) (= i cut)) {:value (if scalar? (:x state) [(:x state) (:y state)]) :trace (:trace state)}
:else (recur (inc i) (reduce (fn [state [index step]] (model-step state i index step))
state (map-indexed vector steps))))))
(defn observed [numeric? id]
;; A numeric computation observes the number without observing the identity
;; of its source box, so primitive storage can participate in this regime.
(if numeric? (list 'unchecked-add id 0) id))
(defn step-form [numeric? index [op k]]
`(do
~(case op
:parallel `(psetq ~'x (+ ~'y ~k) ~'y (- ~'x ~k))
:if `(if (< ~'x ~'y) (setq ~'x (+ ~'x ~k)) (setq ~'x (- ~'x ~k)))
:case `(setq ~'x (case (mod ~'i 3) 0 (+ ~'x ~k) 1 (- ~'x ~k) (+ ~'x (* 2 ~k))))
:snapshot `(let [~'old ~'x] (setq ~'x (+ ~'x ~k) ~'y (+ ~'y ~'old)))
:arguments `(setq ~'y (+ (do (setq ~'x (+ ~'x ~k)) ~'x)
(do (setq ~'x (- ~'x ~k)) ~'x)))
:shadow `(let [~'x (+ ~'y ~k)] (setq ~'y (+ ~'x ~k)))
:helper `(setq ~'x (com.tailrecursion.blacktide.generated-test/three-steps ~'x ~k))
:loop `(let [~'old ~'x]
(setq ~'x (loop [~'n 2 ~'v ~'old]
(if (zero? ~'n) ~'v (recur (dec ~'n) (+ ~'v ~k))))))
:truth `(setq ~'x (if ~(if (even? k) (if (pos? k) 0 :selected) (if (pos? k) false nil))
(+ ~'x ~k) (- ~'x ~k)))
:cast `(setq ~'x (+ (long ~'x) ~k))
:lookup `(setq ~'y (:value (case (mod ~'i 3)
0 (let [~'old ~'x] (setq ~'x (+ ~'x ~k)) {:value (+ ~'old ~'y)})
(do (setq ~'x (+ ~'x ~k)) {:value (+ (- ~'x ~k) ~'y)}))))
:check `(when (= ~'i ~k) (+ Long/MAX_VALUE 1)))
(swap! ~'events conj [~(observed numeric? 'i) ~index ~(observed numeric? 'x) ~(observed numeric? 'y)])))
(defn program [{:keys [limit cut x y steps numeric? scalar? hinted? native-result? literal-init?]} control renamed?]
(let [body (map-indexed (partial step-form numeric?) steps)
local #(if hinted? (with-meta % {:tag 'long}) %)
initial #(if (and numeric? (not literal-init?)) (list 'long %) %)
cut-form `(when (= ~'i ~cut) (goto ~'done))
forms (case control
:linear (mapcat (fn [i] `((setq ~'i ~i) ~cut-form ~@body)) (range limit))
:goto `((label ~'again) (when (>= ~'i ~limit) (goto ~'done)) ~cut-form
~@body (setq ~'i (inc ~'i)) (goto ~'again))
:irreducible `((if (zero? ~'x) (goto ~'left) (goto ~'right))
(label ~'left) (when (>= ~'i ~limit) (goto ~'done)) ~cut-form
~@body (setq ~'i (inc ~'i)) (goto ~'right)
(label ~'right) (when (>= ~'i ~limit) (goto ~'done)) ~cut-form
~@body (setq ~'i (inc ~'i)) (goto ~'left))
:recur `((loop [~'i 0]
(when (< ~'i ~limit) ~cut-form ~@body (recur (inc ~'i)))))
:nested `((while (< ~'i ~limit) ~cut-form
(dotimes [~'inner 1] ~@body) (setq ~'i (inc ~'i)))))
result (if scalar? 'x [(observed numeric? 'x) (observed numeric? 'y)])
result (if native-result? `(loop [remaining# 1]
(if (zero? remaining#) ~result (recur (dec remaining#)))) result)
form `(loophole [~(local 'i) 0 ~(local 'x) ~(initial x) ~(local 'y) ~(initial y)]
~@forms (label ~'done) ~result)]
(if renamed?
(let [renames '{i counter__17 x value__93 y value__94 again start__51 done end left phase__1 right phase__2}]
(list 'let ['unused :harmless]
(walk/postwalk #(if (symbol? %) (with-meta (get renames % %) (meta %)) %) form)))
form)))
(defn outcome [config control renamed? mode]
(try (backend/execution (program config control renamed?) mode)
(catch Throwable error {:compile-error (class error) :message (ex-message error)})))
(def configuration
(gen/let [representation (gen/elements [:boxed :primitive :hinted :literal])
scalar? gen/boolean native-result? gen/boolean numeric-only? gen/boolean
limit (gen/choose 0 6) cut (gen/choose 0 8)
x (gen/choose -15 15) y (gen/choose -15 15)
steps (gen/vector (gen/tuple (gen/elements (if numeric-only? [:case :snapshot :shadow :cast] operations)) (gen/choose -4 4)) 0 5)]
{:numeric? (not= :boxed representation) :hinted? (= :hinted representation)
:literal-init? (= :literal representation) :scalar? scalar? :native-result? native-result?
:limit limit :cut cut :x x :y y :steps steps}))
(deftest generated-backend-equivalence
(let [seed 618033 coverage (atom {}) recover structure/recover
choose storage/select-storage lower numeric-lower/program]
(with-redefs [numeric-lower/program
(fn [program]
(when (some #(and (map? %) (= :numeric (:op %))
(= 'add (:member (:operation %)))
(numeric/plan (:types program) %)
(some (fn [operand] (not= Long/TYPE (:type (:jvm operand)))) (:args %)))
(tree-seq coll? seq (:body program)))
(swap! coverage update :specialized-add (fnil inc 0)))
(lower program))
structure/recover (fn [analysis]
(let [out (recover analysis)]
(when (and (= :structured (:op out))
(empty? (:loops analysis)))
(swap! coverage update :acyclic (fnil inc 0)))
(swap! coverage update (or (:reason out) (:op out)) (fnil inc 0)) out))
storage/select-storage (fn [analysis expr]
(let [out (choose analysis expr)]
(when (seq (select-keys (:types out) (storage/loop-slots (:body out))))
(swap! coverage update :primitive-loops (fnil inc 0)))
(when (some #(and (map? %) (= :return (:op %))
(some (fn [value] (contains? (:types out) (:id value))) (:values %)))
(tree-seq coll? seq (:body out)))
(swap! coverage update :primitive-returns (fnil inc 0)))
out))]
(let [result (tc/quick-check 80
(prop/for-all [config configuration]
(let [expected (model config)]
(every? true?
(for [control [:linear :goto :recur :nested :irreducible]
renamed? [false true] mode [:default :generic :dispatcher]]
(= expected (outcome config control renamed? mode))))))
:seed seed)]
(is (:pass? result) (pr-str result))))
(is (pos? (get @coverage :specialized-add 0)) (str @coverage))
(is (pos? (get @coverage :structured 0)) (str @coverage))
(is (pos? (get @coverage :acyclic 0)) (str @coverage))
(is (pos? (get @coverage :cycles 0)) (str @coverage))
(is (pos? (get @coverage :primitive-loops 0)) (str @coverage))
(is (pos? (get @coverage :primitive-returns 0)) (str @coverage))
(println "Control generator:" {:seed seed :coverage @coverage})))