(ns ^:typed.clojure com.tailrecursion.blacktide.compiler.passes.storage
"Select primitive storage only when every producer and consumer agrees.
Object observations and reference-valued native reads retain identity; loop slots
specialize only to long/double. Copies and numeric plans propagate boxing
requirements; the public return boundary boxes the selected representation."
(:require [clojure.set :as set]
[com.tailrecursion.nanopass :as np]
[com.tailrecursion.blacktide.compiler.languages :as l]
[com.tailrecursion.blacktide.compiler.passes.graph :as graph]
[com.tailrecursion.blacktide.compiler.passes.native :as native]
[com.tailrecursion.blacktide.compiler.passes.numeric :as numeric]
[com.tailrecursion.blacktide.compiler.passes.value-facts :as facts]
[typed.clojure :as-alias t]))
(np/defpass loop-slots {:from [l/Joined Expr] :to (t/Set t/Sym)}
[node]
:bind (loop-slots (:body node))
:join (set/union (loop-slots (:value node)) (loop-slots (:body node)))
:branch (set/union (loop-slots (:yes node)) (loop-slots (:no node)))
:switch (into #{} (mapcat loop-slots) (:arms node))
:loop (into (loop-slots (:body node)) (:slots node))
:recur #{} :return #{} :throw #{})
(np/defpass operand-boxes
{:from [l/Machine Operand] :to (t/Set t/Sym) :args [l/Represented-Types] :body true}
[types operand]
(let [type (facts/atom-type types (:value operand))]
(if (and (class? type) (= type (:type (:jvm operand)))) #{} (graph/atom-reads (:value operand)))))
(np/defpass operation-boxes
{:from [l/Numeric Operation] :to (t/Set t/Sym) :args [l/Represented-Types (t/Set t/Sym)] :body true}
[types observed operation]
(let [rhs (:value operation)]
(case (:op rhs)
:value (let [value (:value rhs) target (:target operation)]
(cond
(not (contains? observed target)) #{}
(not (contains? types target)) (graph/atom-reads value)
(and (= :local (:op value)) (not (contains? types (:id value)))) #{target}
:else #{}))
:numeric (if-let [plan (numeric/plan types rhs)]
(into (if (= (get types (:target operation)) (:result plan)) #{}
;; Boxing an operand can change the selected overload's
;; result representation. Its target must follow suit.
(into #{(:target operation)} (mapcat graph/atom-reads) (numeric/origin-values plan rhs)))
(mapcat (fn [arg ^Class parameter]
(if (.isPrimitive parameter) #{} (graph/atom-reads (:value arg))))
(:args rhs) (:parameters plan)))
(let [source (numeric/source-call rhs)]
(cond-> (into #{} (mapcat #(operand-boxes types %)) (:args rhs))
(not= (get types (:target operation)) (facts/rhs-type {} source))
(conj (:target operation)))))
:host (if (#{:adapt} (:op (:operation rhs))) (graph/rhs-reads rhs)
(into #{} (mapcat #(operand-boxes types %)) (:args rhs)))
:convert (let [conversion (:conversion rhs)]
(if (and (:parameter? conversion) (.isPrimitive ^Class (:type conversion)))
(operand-boxes types (:value rhs)) (graph/rhs-reads rhs)))
:dispatch (operand-boxes types (:value rhs))
:native (native/boxed-reads types (:value rhs))
(graph/rhs-reads rhs))))
(np/defpass observed-values
{:from [l/Numeric Program] :to (t/Set t/Sym) :body true}
[machine]
(let [ops (mapcat :ops (vals (:blocks machine)))
initial (into (into #{} (mapcat #(graph/term-reads (:term %))) (vals (:blocks machine)))
(mapcat #(if (= :value (:op (:value %))) #{} (graph/rhs-reads (:value %)))) ops)]
((fn ^{::t/- [(t/Set t/Sym) :-> (t/Set t/Sym)]} solve [observed]
(let [next (reduce (fn [^{::t/- (t/Set t/Sym)} out ^{::t/- l/Numeric-Operation} op]
(if (contains? observed (:target op)) (into out (graph/rhs-reads (:value op))) out)) observed ops)]
(if (= observed next) observed (recur next)))) initial)))
(np/defpass term-boxes
{:from [l/Machine Term] :to (t/Set t/Sym) :args [l/Represented-Types] :body true}
[types term]
(case (:op term)
:return #{}
:branch (if (= Boolean/TYPE (facts/atom-type types (:test term))) #{} (graph/term-reads term))
:switch (if (= Long/TYPE (facts/atom-type types (:test term))) #{} (graph/term-reads term))
(graph/term-reads term)))
(np/defpass select-storage
{:from [l/Joined Expr] :to [l/Represented Program] :args [l/Analysis-Program] :body true}
[analysis expr]
;; Emission preserves the public Object boundary at every exit.
(let [slots (loop-slots expr)
initial (reduce-kv
(fn [^{::t/- l/Represented-Types} out ^{::t/- t/Sym} id ^{::t/- l/Analysis-Type} type]
(if (and (class? type) (or (not (contains? slots id)) (#{Long/TYPE Double/TYPE} type)))
(assoc out id type) out)) {} (:types analysis))
machine (update (:machine analysis) :blocks #(select-keys % (:reachable analysis)))
observed (observed-values machine)
blocks (vals (:blocks machine))
types ((fn ^{::t/- [l/Represented-Types :-> l/Represented-Types]} solve [types]
(let [boxed (into (into #{} (mapcat #(operation-boxes types observed %)) (mapcat :ops blocks))
(mapcat #(term-boxes types (:term %))) blocks)
next (apply dissoc types boxed)]
(if (= types next) types (recur next)))) initial)]
{:body expr :types types}))