(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.value-facts
"Prove scalar values across reachable definitions and copy cycles. Numeric
calls may carry long values in boxes; storage selection decides whether those
boxes can disappear. Source JVM facts remain unchanged."
(:require [com.tailrecursion.nanopass :as np]
[com.tailrecursion.blacktide.compiler.languages :as l]
[com.tailrecursion.blacktide.compiler.jvm :as jvm]
[com.tailrecursion.blacktide.compiler.passes.numeric-rules :as rules]
[com.tailrecursion.blacktide.compiler.passes.graph :as graph]
[typed.clojure :as-alias t]))
(np/defpass primitive {:from [l/JVM Type] :to [l/Analysis Type] :body true}
[type]
(if (and (class? type) (.isPrimitive ^Class type) (not= Void/TYPE type)) type :boxed))
(np/defpass join {:from [l/Analysis Type] :to [l/Analysis Type] :args [l/Analysis-Type] :body true}
[a b]
(cond (= a :bottom) b (= b :bottom) a (= a b) a :else :boxed))
(np/defpass atom-type {:from [l/Machine Atom] :to [l/Analysis Type] :args [l/Analysis-Types]}
[types node]
:local (get types (:id node) :bottom)
;; Quoted Integer constants stay boxed to preserve their width.
:literal (cond (instance? Long (:value node)) (primitive Long/TYPE)
(instance? Double (:value node)) (primitive Double/TYPE)
:else :boxed))
(np/defpass rhs-type {:from [l/Numeric Rhs] :to [l/Analysis Type] :args [l/Analysis-Types]}
[types rhs]
:value (atom-type types (:value rhs))
:external (if (:primitive? (:jvm rhs)) (primitive (:type (:jvm rhs))) :boxed)
:convert (if (:parameter? (:conversion rhs)) (primitive (:type (:conversion rhs))) :boxed)
:dispatch (primitive Long/TYPE)
:host (if (#{:adapt} (:op (:operation rhs))) :boxed
(primitive (jvm/host-type (mapv #(:type (:jvm %)) (:args rhs)) (:operation rhs))))
:numeric (let [actual (primitive (:return rhs))
args (mapv #(atom-type types (:value %)) (:args rhs))]
(if (class? actual) actual
(if-let [plan (rules/plan args (:parameters rhs) (:return rhs) (:operation rhs))]
(primitive (:result plan))
(if (and (some #{:bottom} args) (not (some #{:boxed} args))) :bottom :boxed))))
:native :boxed
:global :boxed
:var :boxed
:construct :boxed
:metadata :boxed
:invoke :boxed)
(np/defpass definitions
{:from [l/Numeric Program] :to [l/Analysis Definitions] :args [(t/Set l/Machine-Label)] :body true}
[reachable machine]
(reduce (fn [^{::t/- l/Analysis-Definitions} out ^{::t/- l/Numeric-Operation} op]
(assoc out (:target op) (conj (get out (:target op) []) (:value op))))
{} (mapcat :ops (vals (select-keys (:blocks machine) reachable)))))
(np/defpass solve {:from [l/Analysis Definitions] :to [l/Analysis Types] :body true}
[definitions]
((fn ^{::t/- [l/Analysis-Types :-> l/Analysis-Types]} fixed-point [types]
(let [next (reduce-kv
(fn [^{::t/- l/Analysis-Types} out ^{::t/- t/Sym} id ^{::t/- (t/Vec l/Numeric-Rhs)} values]
(assoc out id
((fn ^{::t/- [t/Int l/Analysis-Type :-> l/Analysis-Type]} common [index type]
(if (< index (count values))
(recur (inc index) (join type (rhs-type types (nth values index)))) type))
0 :bottom))) {} definitions)]
(if (= types next) next (recur next)))) {}))
(np/defpass analyze {:from [l/Numeric Program] :to [l/Analysis Program] :body true}
[machine]
(let [reachable (graph/reachable (graph/collect-facts (:blocks machine)) (:entry machine))]
{:machine machine :reachable reachable :types (solve (definitions reachable machine))}))